diff options
Diffstat (limited to 'lisp')
47 files changed, 52458 insertions, 0 deletions
diff --git a/lisp/calc/INSTALL b/lisp/calc/INSTALL new file mode 100644 index 0000000000..e311f605c3 --- /dev/null +++ b/lisp/calc/INSTALL @@ -0,0 +1,413 @@ + +Installation +************ + +Calc 2.02 comes as a set of GNU Emacs Lisp files, with names like +`calc.el' and `calc-ext.el', and also as a `calc.texinfo' file which +can be used to generate both on-line and printed documentation. + + To install Calc, just follow these simple steps. If you want more +information, each step is discussed at length in the sections below. + + 1. Change (`cd') to the Calc "home" directory. This directory was + created when you unbundled the Calc `.tar' or `.shar' file. + + 2. Type `make' to install Calc privately for your own use, or type + `make install' to install Calc system-wide. This will compile all + the Calc component files, modify your `.emacs' or the system-wide + `lisp/default' file to install Calc as appropriate, and format + the on-line Calc manual. + + Both variants are shorthand for the following three steps: + + * `make compile' to run the byte-compiler. + + * `make private' or `make public', corresponding to `make' and + `make install', respectively. (If `make public' fails + because your system doesn't already have a `default' or + `default.el' file, use Emacs or the Unix `touch' command to + create a zero-sized one first.) + + * `make info' to format the on-line Calc manual. This first + tries to use the `makeinfo' program; if that program is not + present, it uses the Emacs `texinfo-format-buffer' command + instead. + + The Unix `make' utility looks in the file `Makefile' in the + current directory to see what Unix commands correspond to the + various "targets" like `install' or `public'. If your system + doesn't have `make', you will have to examine the `Makefile' and + type in the corresponding commands by hand. + + 3. If you ever move Calc to a new home directory, just give the + `make private' or `make public' command again in the new + directory. + + 4. Test your installation as described at the end of these + instructions. + + 5. (Optional.) To print a hardcopy of the Calc manual (over 500 + pages) or just the Calc Summary (about 20 pages), follow the + instructions under "Printed Documentation" below. + +Calc is now installed and ready to go! + + +Upgrading from Calc 1.07 +========================= + +If you have Calc version 1.07 or earlier, you will find that Calc 2.00 +is organized quite differently. For one, Calc 2.00 is now distributed +already split into many parts; formerly this was done as part of the +installation procedure. Also, some new functions must be autoloaded +and the `M-#' key must be bound to `calc-dispatch' instead of to +`calc'. + + The easiest way to upgrade is to delete your old Calc files and then +install Calc 2.00 from scratch using the above instructions. You +should then go into your `.emacs' or `default' file and remove the old +`autoload' and `global-set-key' commands for Calc, since `make +public'/`make private' has added new, better ones. + + See the `README' and `README.prev' files in the Calc distribution +for more information about what has changed since version 1.07. +(`README.prev' describes changes before 2.00, and is present only in +the FTP and tape versions of the distribution.) + + +The `make public' Command +========================== + +If you are not the regular Emacs administrator on your system, your +account may not be allowed to execute the `make public' command, since +the system-wide `default' file may be write-protected. If this is the +case, you will have to ask your Emacs installer to execute this +command. (Just `cd' to the Calc home directory and type `make +public'.) + + The `make private' command adds exactly the same set of commands to +your `.emacs' file as `make public' adds to `default'. If your Emacs +installer is concerned about typing this command out of the blue, you +can ask her/him instead to copy the necessary text from your `.emacs' +file. (It will be marked by a comment that says "Commands added by +`calc-private-autoloads' on (date and time).") + + +Compilation +============ + +Calc is written in a way that maximizes performance when its code has +been byte-compiled; a side effect is that performance is seriously +degraded if it *isn't* compiled. Thus, it is essential to compile the +Calculator before trying to use it. The function `calc-compile' in +the file `calc-maint.el' runs the Emacs byte-compiler on all the Calc +source files. (Specifically, it runs `M-x byte-compile-file' on all +files in the current directory with names of the form `calc*.el', and +also on the file `macedit.el'.) + + If `calc-compile' finds that certain files have already been +compiled and have not been changed since, then it will not bother to +recompile those files. + + The `calc-compile' command also pre-builds certain tables, such as +the units table (see "The Units Table") and the built-in rewrite +rules (see "Rearranging with Selections") which Calc would otherwise +need to rebuild every time those features were used. + + The `make compile' shell command is simply a convenient way to +start an Emacs and give it a `calc-compile' command. + + +Auto-loading +============= + +To teach Emacs how to load in Calc when you type `M-#' for the first +time, add these lines to your `.emacs' file (if you are installing +Calc just for your own use), or the system's `lisp/default' file (if +you are installing Calc publicly). The `make private' and `make +public' commands, respectively, take care of this. (Note that `make' +runs `make private', and `make install' runs `make public'.) + + (autoload 'calc-dispatch "calc" "Calculator Options" t) + (autoload 'full-calc "calc" "Full-screen Calculator" t) + (autoload 'full-calc-keypad "calc" "Full-screen X Calculator" t) + (autoload 'calc-eval "calc" "Use Calculator from Lisp") + (autoload 'defmath "calc" nil t t) + (autoload 'calc "calc" "Calculator Mode" t) + (autoload 'quick-calc "calc" "Quick Calculator" t) + (autoload 'calc-keypad "calc" "X windows Calculator" t) + (autoload 'calc-embedded "calc" "Use Calc from any buffer" t) + (autoload 'calc-embedded-activate "calc" "Activate =>'s in buffer" t) + (autoload 'calc-grab-region "calc" "Grab region of Calc data" t) + (autoload 'calc-grab-rectangle "calc" "Grab rectangle of data" t) + + Unless you have installed the Calc files in Emacs' main `lisp/' +directory, you will also have to add a command that looks like the +following to tell Emacs where to find them. In this example, we have +put the files in directory `/usr/gnu/src/calc-2.00'. + + (setq load-path (append load-path (list "/usr/gnu/src/calc-2.00"))) + +The `make public' and `make private' commands also do this (they use +the then-current directory as the name to add to the path). If you +move Calc to a new location, just repeat the `make public' or `make +private' command to have this new location added to the `load-path'. + + The `autoload' command for `calc-dispatch' is what loads `calc.elc' +when you type `M-#'. It is the only `autoload' that is absolutely +necessary for Calc to work. The others are for commands and features +that you may wish to use before typing `M-#' for the first time. In +particular, `full-calc' and `full-calc-keypad' are autoloaded to +support "standalone" operation (see "Standalone Operation"), +`calc-eval' and `defmath' are autoloaded to allow other Emacs Lisp +programs to use Calc facilities (see "Calling Calc from Your +Programs"), and `calc-embedded-activate' is autoloaded because some +Embedded Mode files may call it as soon as they are read into Emacs +(see "Assignments in Embedded Mode"). + + +Finding Component Files +======================== + +There is no need to write `autoload' commands that point to all the +various Calc component files like `calc-misc.elc' and `calc-alg.elc'. +The main file, `calc.elc', contains all the necessary `autoload' +commands for these files. + + (Actually, to conserve space `calc.elc' only autoloads a few of the +component files, plus `calc-ext.elc', which in turn autoloads the rest +of the components. This allows Calc to load a little faster in the +beginning, but the net effect is the same.) + + This autoloading mechanism assumes that all the component files can +be found on the `load-path'. The `make public' and `make private' +commands take care of this, but Calc has a few other strategies in +case you have installed it in an unusual way. + + If, when Calc is loaded, it is unable to find its components on the +`load-path' it is given, it checks the file name in the original +`autoload' command for `calc-dispatch'. If that name included +directory information, Calc adds that directory to the `load-path': + + (autoload 'calc-dispatch "calc-2.00/calc" "Calculator" t) + +Suppose the directory `/usr/gnu/src/emacs/lisp' is on the path, and +the above `autoload' allows Emacs to find Calc under the name +`/usr/gnu/src/emacs/lisp/calc-2.00/calc.elc'. Then when Calc starts +up it will add `/usr/gnu/src/emacs/lisp/calc-2.00' to the path so that +it will later be able to find its component files. + + If the above strategy does not locate the component files, Calc +examines the variable `calc-autoload-directory'. This is initially +`nil', but you can store the name of Calc's home directory in it as a +sure-fire way of getting Calc to find its components. + + +Merging Source Files +===================== + +If the `autoload' mechanism is not managing to load each part of Calc +when it is needed, you can concatenate all the `.el' files into one +big file. The order should be `calc.el', then `calc-ext.el', then all +the other files in any order. Byte-compile the resulting big file. +This merged Calculator ought to work just like Calc normally does, +though it will be *substantially* slower to load. + + +Key Bindings +============= + +Calc is normally bound to the `M-#' key. To set up this key binding, +include the following command in your `.emacs' or `lisp/default' file. + (This is done automatically by `make private' or `make public', +respectively.) + + (global-set-key "\e#" 'calc-dispatch) + + Note that `calc-dispatch' actually works as a prefix for various +two-key sequences. If you have a convenient unused function key on +your keyboard, you may wish to bind `calc-dispatch' to that as well. +You may even wish to bind other specific Calc functions like `calc' or +`quick-calc' to other handy function keys. + + Even if you bind `calc-dispatch' to other keys, it is best to bind +it to `M-#' as well if you possibly can: There are references to +`M-#' all throughout the Calc manual which would confuse novice users +if they didn't work as advertised. + + Another key binding issue is the DEL key. Some installations use a +different key (such as backspace) for this purpose. Calc normally +scans the entire keymap and maps all keys defined like DEL to the +`calc-pop' command. However, this may be slow. You can set the +variable `calc-scan-for-dels' to `nil' to cause only the actual DEL +key to be mapped to `calc-pop'; this will speed loading of Calc. + + +The `macedit' Package +====================== + +The file `macedit.el' contains another useful Emacs extension called +`edit-kbd-macro'. It allows you to edit a keyboard macro in +human-readable form. The `Z E' command in Calc knows how to use it to +edit user commands that have been defined by keyboard macros. To +autoload it, you will want to include the commands, + + (autoload 'edit-kbd-macro "macedit" "Edit Keyboard Macro" t) + (autoload 'edit-last-kbd-macro "macedit" "Edit Keyboard Macro" t) + (autoload 'read-kbd-macro "macedit" "Read Keyboard Macro" t) + +The `make public' and `make private' commands do this. + + +The GNUPLOT Program +==================== + +Calc's graphing commands use the GNUPLOT program. If you have GNUPLOT +but you must type some command other than `gnuplot' to get it, you +should add a command to set the Lisp variable `calc-gnuplot-name' to +the appropriate file name. You may also need to change the variables +`calc-gnuplot-plot-command' and `calc-gnuplot-print-command' in order +to get correct displays and hardcopies, respectively, of your plots. + + +On-Line Documentation +====================== + +The documentation for Calc (this manual) comes in a file called +`calc.texinfo'. To format this for use as an on-line manual, type +`make info' (to use the `makeinfo' program), or `make texinfo' (to use +the `texinfmt.el' program which runs inside of Emacs). The former +command is recommended if it works on your system; it is faster and +produces nicer-looking output. + + The `makeinfo' program will report inconsistencies involving the +nodes "Copying" and "Interactive Tutorial"; these messages should be +ignored. + + The result will be a collection of files whose names begin with +`calc.info'. You may wish to add a reference to the first of these, +`calc.info' itself, to your Info system's `dir' file. (This is +optional since the `M-# i' command can access `calc.info' whether or +not it appears in the `dir' file.) + + There is a Lisp variable called `calc-info-filename' which holds +the name of the Info file containing Calc's on-line documentation. +Its default value is `"calc.info"', which will work correctly if the +Info files are stored in Emacs' main `info/' directory, or if they are +in any of the directories listed in the `load-path'. If you keep them +elsewhere, you will want to put a command of the form, + + (setq calc-info-filename ".../calc.info") + +in your `.emacs' or `lisp/default' file, where `...' represents the +directory containing the Info files. This will not be necessary if +you follow the normal installation procedures. + + The `make info' and `make texinfo' commands compare the dates on +the files `calc.texinfo' and `calc.info', and run the appropriate +program only if the latter file is older or does not exist. + + +Printed Documentation +====================== + +Because the Calc manual is so large, you should only make a printed +copy if you really need it. To print the manual, you will need the +TeX typesetting program (this is a free program by Donald Knuth at +Stanford University) as well as the `texindex' program and +`texinfo.tex' file, both of which can be obtained from the FSF as part +of the `texinfo2' package. + + To print the Calc manual in one huge 550 page tome, type `make tex'. +This will take care of running the manual through TeX twice so that +references to later parts of the manual will have correct page numbers. +(Don't worry if you get some "overfull box" warnings.) + + The result will be a device-independent output file called +`calc.dvi', which you must print in whatever way is right for your +system. On many systems, the command is + + lpr -d calc.dvi + + Marginal notes for each function and key sequence normally alternate +between the left and right sides of the page, which is correct if the +manual is going to be bound as double-sided pages. Near the top of +the file `calc.texinfo' you will find alternate definitions of the +`\bumpoddpages' macro that put the marginal notes always on the same +side, best if you plan to be binding single-sided pages. + + Some people find the Calc manual to be too large to handle easily. +In fact, some versions of TeX have too little memory to print it. So +Calc includes a `calc-split-manual' command that splits `calc.texinfo' +into two volumes, the Calc Tutorial and the Calc Reference. The +easiest way to use it is to type `make tex2' instead of `make tex'. +The result will be two smaller files, `calctut.dvi' and `calcref.dvi'. + The former contains the tutorial part of the manual; the latter +contains the reference part. Both volumes include copies of the +"Getting Started" chapter and licensing information. + + To save disk space, you may wish to delete `calctut.*' and +`calcref.*' after you're done. Don't delete `calc.texinfo', because +you will need it to install future patches to Calc. The `make tex2' +command takes care of all of this for you. + + The `make textut' command formats only the Calc Tutorial volume, +producing `calctut.dvi' but not `calcref.dvi'. Likewise, `make +texref' formats only the Calc Reference volume. + + Finally, there is a `calc-split-summary' command that splits off +just the Calc Summary appendix suitable for printing by itself. Type +`make summary' instead of `make tex'. The resulting `calcsum.dvi' +file will print in less than 20 pages. If the Key Index file +`calc.ky' is present, left over from a previous `make tex' command, +then `make summary' will insert a column of page numbers into the +summary using that information. + + The `make isummary' command is like `make summary', but it prints a +summary that is designed to be substituted into the regular manual. +(The two summaries will be identical except for the additional column +of page numbers.) To make a complete manual, run `make tex' and `make +isummary', print the two resulting `.dvi' files, then discard the +Summary pages that came from `calc.dvi' and insert the ones from +`calcsum.dvi' in their place. Also, remember that the table of +contents prints at the end of the manual but should generally be moved +to the front (after the title and copyright pages). + + If you don't have TeX, you can print the summary as a plain text +file by going to the "Summary" node in Calc's Info file, then typing +`M-x print-buffer' (see "Summary"). + + +Settings File +============== + +Another variable you might want to set is `calc-settings-file', which +holds the file name in which commands like `m m' and `Z P' store +"permanent" definitions. The default value for this variable is +`"~/.emacs"'. If `calc-settings-file' does not contain `".emacs"' as +a substring, and if the variable `calc-loaded-settings-file' is `nil', +then Calc will automatically load your settings file (if it exists) +the first time Calc is invoked. + + +Testing the Installation +========================= + +To test your installation of Calc, start a new Emacs and type `M-# c' +to make sure the autoloads and key bindings work. Type `M-# i' to +make sure Calc can find its Info documentation. Press `q' to exit the +Info system and `M-# c' to re-enter the Calculator. Type `20 S' to +compute the sine of 20 degrees; this will test the autoloading of the +extensions modules. The result should be 0.342020143326. Finally, +press `M-# c' again to make sure the Calculator can exit. + + You may also wish to test the GNUPLOT interface; to plot a sine +wave, type `' [0 .. 360], sin(x) RET g f'. Type `g q' when you are +done viewing the plot. + + Calc is now ready to use. If you wish to go through the Calc +Tutorial, press `M-# t' to begin. + + +(The above text is included in both the Calc documentation and the +file INSTALL in the Calc distribution directory.) diff --git a/lisp/calc/Makefile b/lisp/calc/Makefile new file mode 100644 index 0000000000..776fd36cb2 --- /dev/null +++ b/lisp/calc/Makefile @@ -0,0 +1,186 @@ +# Makefile for "Calc", the GNU Emacs Calculator. +# Copyright (C) 1991, 1992, 1993 Free Software Foundation. +# Author: Dave Gillespie. +# Author's address: [email protected]. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation (any version). + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs; see the file COPYING. If not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + + +# To install Calc for private use, type `make'. +# To install Calc for public use, type `make install'. + +# How to read a Makefile: +# The command `make target' looks for `target:' in the Makefile. +# First, any sub-targets after the `:' are made. +# Then, the Unix commands on the following lines are executed. +# `$(SYMBOL)' expands according to the `SYMBOL =' definition below. + + +# Programs. +EMACS = emacs +TEX = tex +TEXINDEX = texindex +MAKEINFO = makeinfo +MAKE = make +ECHO = @echo +REMOVE = -rm -f +# (The leading `@' tells "make" not to echo the command itself during make; +# The leading `-' tells "make" to keep going if the command fails.) + +# Other macros. +EFLAGS = -batch +MAINT = -l calc-maint.elc + +# Control whether intermediate files are kept. +PURGE = -rm -f +#PURGE = echo Not deleting: + + + +# Do full Calc installation. (Note that `make' == `make all'.) +# These are written this way instead of `all: compile private info' +# to make the steps more explicit while the `make' is in progress. +all: + $(MAKE) compile + $(MAKE) private + $(MAKE) info + $(ECHO) "Calc is now installed." + +install: + $(MAKE) compile + $(MAKE) public + $(MAKE) info + $(ECHO) "Calc is now installed." + + +# Compile Calc. +compile: maint + $(EMACS) $(EFLAGS) $(MAINT) -f calc-compile + + +# Add autoload and set-global-key commands to system default file. +public: maint + $(EMACS) $(EFLAGS) $(MAINT) -f calc-public-autoloads + + +# Add autoload and set-global-key commands to ~/.emacs file. +private: maint + $(EMACS) $(EFLAGS) $(MAINT) -f calc-private-autoloads + + +# Format the Calc manual for the Info system using makeinfo. +info: calc.info +calc.info: calc.texinfo + -$(MAKEINFO) calc.texinfo + $(ECHO) "Please ignore warnings for Copying, Getting Started, and Interactive Tutorial." + $(MAKE) texinfo + + +# Format the Calc manual for the Info system using texinfo.el. +# (Use this only if you do not have makeinfo.) +texinfo: calc.info-2 +calc.info-2: calc.texinfo + $(EMACS) $(EFLAGS) calc.texinfo -f texinfo-format-buffer -f save-buffer + + +# Format the Calc manual as one printable volume using TeX. +tex: + $(REMOVE) calc.aux + $(TEX) calc.texinfo + $(TEXINDEX) calc.[cfkptv]? + $(TEX) calc.texinfo + $(PURGE) calc.cp calc.fn calc.pg calc.tp calc.vr + $(PURGE) calc.cps calc.fns calc.kys calc.pgs calc.tps calc.vrs + $(PURGE) calc.toc +# Note, calc.aux and calc.ky are left behind for the benefit of "make summary". + +# Format the Calc manual as two printable volumes (Tutorial and Reference). +tex2: texsplit texvol1 texvol2 + +# Format the Calc Tutorial volume only. +textut: texsplit1 texvol1 + +# Format the Calc Reference volume only. +texref: texsplit2 texvol2 + +texsplit: maint + $(EMACS) $(EFLAGS) $(MAINT) calc.texinfo -f calc-split-manual + +texsplit1: maint + $(EMACS) $(EFLAGS) $(MAINT) calc.texinfo -f calc-split-tutorial + +texsplit2: maint + $(EMACS) $(EFLAGS) $(MAINT) calc.texinfo -f calc-split-reference + +texvol1: + $(TEX) calctut.tex + $(TEXINDEX) calctut.?? + $(TEX) calctut.tex + $(PURGE) calctut.tex calctut.?? calctut.??s calctut.aux calctut.toc + +texvol2: + $(TEX) calcref.tex + $(TEXINDEX) calcref.?? + $(TEX) calcref.tex + $(PURGE) calcref.tex calcref.?? calcref.??s calcref.aux calcref.toc + + +# Format the Calc summary separately using TeX. +summary: texsum + $(TEX) calcsum.tex + $(PURGE) calcsum.?? calcsum.aux calcsum.toc + +texsum: maint + $(EMACS) $(EFLAGS) $(MAINT) calc.texinfo -f calc-split-summary + +isummary: texisum + $(TEX) calcsum.tex + $(PURGE) calcsum.?? calcsum.aux calcsum.toc + +texisum: maint + $(EMACS) $(EFLAGS) $(MAINT) calc.texinfo -f calc-inline-summary + + +# All this because "-l calc-maint" doesn't work. +maint: calc-maint.elc +calc-maint.elc: calc-maint.el + cp calc-maint.el calc-maint.elc + + +# Create an Emacs TAGS file +tags: TAGS +TAGS: + etags *.el + + +# Delete .elc files and other reconstructible files. +clean: clean.elc clean.info clean.tex + +clean.elc: + $(REMOVE) calc-*.elc + $(REMOVE) macedit.elc + +clean.info: + $(REMOVE) calc.info* + +clean.tex: + $(REMOVE) calc.cp calc.fn calc.ky calc.pg calc.tp calc.vr + $(REMOVE) calc.cps calc.fns calc.kys calc.pgs calc.tps calc.vrs + $(REMOVE) calc.aux calc.log calc.toc calc.dvi + $(REMOVE) calcref.* + $(REMOVE) calctut.* + $(REMOVE) calcsum.* + + diff --git a/lisp/calc/README b/lisp/calc/README new file mode 100644 index 0000000000..219e378e6e --- /dev/null +++ b/lisp/calc/README @@ -0,0 +1,235 @@ + +This directory contains version 2.02c of Calc, an advanced desk +calculator for GNU Emacs. + +"Calc" Copyright 1990, 1991, 1992, 1993 Free Software Foundation, Inc. + +Written and maintained by: Dave Gillespie + c/o Synaptics, Inc. + 2698 Orchard Parkway + San Jose CA 95134 + [email protected], uunet!synaptx!daveg + + + +From the introduction to the manual: + + "Calc" is an advanced calculator and mathematical tool that runs as + part of the GNU Emacs environment. Very roughly based on the HP-28/48 + series of calculators, its many features include: + + * Choice of algebraic or RPN (stack-based) entry of calculations. + + * Arbitrary precision integers and floating-point numbers. + + * Arithmetic on rational numbers, complex numbers (rectangular and + polar), error forms with standard deviations, open and closed + intervals, vectors and matrices, dates and times, infinities, + sets, quantities with units, and algebraic formulas. + + * Mathematical operations such as logarithms and trigonometric functions. + + * Programmer's features (bitwise operations, non-decimal numbers). + + * Financial functions such as future value and internal rate of return. + + * Number theoretical features such as prime factorization and + arithmetic modulo M for any M. + + * Algebraic manipulation features, including symbolic calculus. + + * Moving data to and from regular editing buffers. + + * "Embedded mode" for manipulating Calc formulas and data directly + inside any editing buffer. + + * Graphics using GNUPLOT, a versatile (and free) plotting program. + + * Easy programming using keyboard macros, algebraic formulas, + algebraic rewrite rules, or extended Emacs Lisp. + + + + +To install Calc: + + 1. Type "uncompress calc-2.02.tar.Z" + + 2. Type "tar xvf calc-2.02.tar" + +1,2. Alternatively: "zcat calc-2.02.tar.Z | tar xvf -" + + 3. Note that the Calc tar file now creates a "calc-2.02" subdirectory + of the current directory in which to place its files. + + 4. Follow the instructions in the file "INSTALL". + + + +Calc is written entirely in Emacs Lisp, for maximum portability. +You do not need to recompile Emacs to install and use Calc. + +You will need about six megabytes of disk space to install Calc +and its Info documentation. + +See the file INSTALL for installation instructions. The instructions +may seem long, but on typical systems you will only need to follow the +steps shown in the first section. + +Don't even try to run Calc in uncompiled (.el) form! It's far too slow. + + +I am anxious to hear about your experiences using Calc. Send mail to +"[email protected]". A bug report is most useful if you include the +exact input and output that occurred, any modes in effect (such as the +current precision), and so on. If you find Calc is difficult to operate +in any way, or if you have other suggestions, don't hesitate to let me +know. If you find errors (including simple typos) in the manual, let +me know. Even if you find no bugs at all I would love to hear your +opinions. + +The latest Calc tar files and patches are always available for anonymous +FTP on prep.ai.mit.edu. + +Thanks, + + -- Dave + + + + + +Summary of changes to "Calc" +------- -- ------- -- ---- + + +Version 2.02f: + + * Fixed a bug which broke `I', `H', `K' prefix keys in recent Emacs. + + * Fixed a bug in calc.texinfo which prevented "make tex2" from working. + + * Updated `C-y' (calc-yank) to understand Emacs 19 generalized kill ring. + + * Added a copy of "calccard.tex", the Calc quick reference card. + + +Version 2.02e: + + * Fixed an installation bug caused by recent changes to `write-region'. + + +Version 2.02d: + + * Fixed a minor installation problem with a Emacs 19.29 byte-compiler bug. + + * Removed archaic "macedit" package (superseded by "edmacro"). + + +Version 2.02c: + + * Patch to port Calc to Lucid Emacs 19; still works with GNU 18 and GNU 19. + + * Fixed a bug that broke `C-x C-c' after Calc graphics had been used. + + +Version 2.02b: + + * Minor patch to port Calc to GNU Emacs 19. Will be superseded by Calc 3.00. + + +Version 2.02: + + * Revamped the manual a bit; rearranged some sections. + + * Added marginal notes for Key/Function Index refs in printed manual. + + * Changed `M-# r' to deal more gracefully with blank lines. + + * Made reductions like `V R +' and `M-# :' considerably faster. + + * Improved parsing and display of cases like "[a + b]". + + * Added `t +' and `t -' for doing business date arithmetic. + + * Added "syntax tables," the opposite of compositions. + + * Added another Rewrites Tutorial exercise. + + * Added the "vmatches" function. + + * Added the `Modes' variable and `m g' command. + + * Improved `u s' to cancel, e.g., "11 mph hr / yd" to get a number. + + * Added "quick units" commands "u 0" through "u 9". + + * Moved `M-%' to calc.el to avoid autoloading problems. + + * Added `M-=' during algebraic entry, acts like `RET ='. + + * Made `LFD' prevent evaluation when finishing a calc-edit command. + + * Changed calc-store commands to use `t .' mode for trail display. + + * Improved integrator to understand forms involving "erf". + + * Fixed parser to make sense of "[1....1e2]" input. + + * Fixed FORTRAN parser to treat a(i,j) as a_i_j if a is declared matrix. + + * Got rid of some version number stamps to reduce size of patches. + + * Fixed a bug in defmath treating "<=" and ">=" predicates. + + * Fixed a bug in which Calc crashed multiplying two date forms. + + * Fixed a bug in line breaker that crashed for large, nested formulas. + + * Fixed a bug using ` to edit string("foo"). + + * Fixed a bug where `M-# y' in Big mode copied stack level number. + + * Fixed a bug where `g O' used wrong default directory, no completion. + + * Fixed a bug where "foo_bar(i)" parsed in C mode but showed as foo#bar. + + * Fixed several bugs where large calculations got "computation too long." + + +Version 2.01: + + * Added percentage commands `M-%', `b %', and `c %'. + + * Changed Big mode to force radix-10 in superscripts. + + * Improved display of fractions in various language modes. + + * Changed `a n' to work properly with equations and inequalities. + + * The problem with cross references to Index nodes in TeX has been fixed. + + * Fixed a bug where recursive esc-maps make calc-ext/-aent unloadable. + + * Fixed a bug in `M-# k', then `OFF' right away, with fresh Emacs. + + * Fixed a bug in which "S_i_j" was formatted wrong after `j s'. + + * Fixed a bug in which `h k u c' positioned cursor on wrong line. + + * Fixed a bug where `z ?' crashed if `z %' was defined. + + * Fixed a bug in `j O' (calc-select-once-maybe). + + * Fixed "make private" not to ask "Delete excess versions" and crash. + + +Version 2.00: + + * First complete posting of Calc since 1.01. + + * Most parts of Calc have seen changes since version 1.07. See + section "New for Calc 2.00" in the manual for a summary. In + the FTP version of the Calc distribution, the file README.prev + contains a detailed change history from 1.00 up to 2.00. + diff --git a/lisp/calc/README.prev b/lisp/calc/README.prev new file mode 100644 index 0000000000..e9983d5bb7 --- /dev/null +++ b/lisp/calc/README.prev @@ -0,0 +1,981 @@ + + +Summary of changes to "Calc" Preceding 2.00 +------- -- ------- -- ---- --------- ---- + + +Version 2.00: + + * Changed to compile calc-macs/-maint, to allow "cp *.elc new-dir". + + * Improved calc-describe-bindings to avoid showing redundant ESC maps. + + +Version 2.00 beta 3: + + * Removed version numbers from most .el files to reduce size of patches. + + * Added a "calc-version" command. + + * Changed `M-# ? ?' to allow for modified describe-function. + + * Changed date parser to accept "Sept" as an alternative for "Sep". + + * Inhibited answers to exercise from showing up in table of contents. + + * Changed Makefile to say "texindex calc.[cfkptv]?" to avoid "calc.el". + + * Fixed up the Makefile in various other ways. + + * Rearranged banner at top of `h h' command's output. + + * Changed "make summary" to print "Calc Summary" on the title page. + + * Added "IntegSimpRules". + + * Added `M-# :', `M-# _', and `M-# Z' options. + + * Changed `^' to evaluate "[-3..-1]^-2" properly. + + * Improved `f g' to give symbolic answers for, e.g., 101:2 and -3:2. + + * Fixed a bug where `h k RET' didn't find the right place on the page. + + * Fixed a bug that formatted "x*(y ? a : b)" as "x y ? a : b". + + * Fixed a bug where defmath translated (< x 0) as (math-posp x)! + + * Fixed a bug that prevented quick-calc from working sometimes. + + * Fixed the `z ?' bug again (maybe this time for good?). + + * Fixed a bug in which `V ^' (vint) was just plain wrong, wrong, wrong! + + * Scanned for and fixed remaining bugs relating to autoloading. + + +Version 2.00 beta 2: + + * Changed "make info" to try "make texinfo" if "makeinfo" not found. + + * Changed to "New for Calc 2.00"; texinfo.tex chokes on apostrophes. + + * Added List Tutorial Exercise 14 (just in case there weren't enough!). + + * Added a discussion of the `Z F' command to the Programming Tutorial. + + * Improved `H a f' not to lose info if input is partially pre-factored. + + * Improved simplification of expressions like sqrt(3) + 3^3:2. + + * Changed Big mode to omit "*" in expressions like 2 sqrt(3) 5^3:4. + + * Replaced European date format D/M/Y with D.M.Y. + + * Changed `a N' and `a X' to consider the endpoints of the interval. + + * Fixed a bug where TeX mode made c*(1+a/b) look like a function call. + + * Fixed a bug formatting top-level evalto's while using selections. + + * Fixed a bug that caused `z ?' to crash. + + * Fixed a bug where `Z F' broke for argument names "t" and "nil". + + * Fixed several bugs relating to autoloading. + + +Version 2.00 beta 1: + + * Added "What's new in Calc 2.00" to the manual (summary of info below). + + * Added support for many GNUPLOT 3.0 features. + + * Tweaked the Makefile and calc-compile a bit more. + + * Modified to work with Zawinski's/Furuseth's optimizing byte compiler. + + * Modified Calc to garbage-collect less often (raised gc-cons-threshold). + + * Changed quick-calc to avoid autoloading so many parts of Calc. + + * Changed Calc subfiles to work properly if not byte-compiled. + + * Renamed `M-# s' to `M-# j', made `M-# s' be equivalent to `h s'. + + * Changed calc-quit to avoid reapportioning space among other windows. + + * Added `M-DEL' (calc-pop-above) key, to DEL as LFD is to RET. + + * Added `{' and `}' to scroll vertically, analogous to `<' and `>'. + + * Added `m t' for "total" algebraic mode. + + * Added `d , \' option to group digits with "\,". + + * Improved support of "prime" accent in "eqn" language mode. + + * Changed macedit's read-kbd-macro to accept a string argument in Lisp. + + * Changed calc-check-defines to use a more concise run-hooks linkage. + + * Changed auto-why mode not to say [w=more] if next msg is not urgent. + + * Made `a d' able to differentiate "a?b:c" and "a_i" formulas. + + * Changed probability dist. functions to work with `a f' and `a d'. + + * Added special constants "phi" and "gamma". + + * Added "poly" function, simpler cousin of "gpoly". + + * Added "pdeg", "plead", "pcont", "pprim"; cleaned up "pdiv" and "pgcd". + + * Added `a p' command for polynomial interpolation. + + * Added `a I' command for numerical integration; made IntegLimit variable. + + * Added `a f' to factor polynomials; moved old `a f' to `a "'. + + * Added `a a' to do partial fraction decompositions. + + * Improved `a i' to integrate many more kinds of formulas. + + * Modified `a P' to find numerical roots of high-degree polynomials. + + * Modified `c 0' through `c 9' to convert int-valued floats to integers. + + * Made sinh, arctanh, etc., expandable into exps/logs by `a f'. + + * Added more algebraic simplifications having to do with logs and exps. + + * Changed `s s', `s t', `s x', `s l' to accept an equation at prompt. + + * Changed `s i' not to store Decls if its value is the default, []. + + * Changed `s i' to store in `d O' language mode if in Normal or Big mode. + + * Rearranged `V M'/`V R' matrix mapping modes. + + * Added <#1+#2> notation for lambda expressions. + + * Extended `b l' and other binary shifts to have a 2-argument version. + + * Changed `u c' and `u t' to give unitless result for unitless input. + + * Changed sqrt(1-cos(x)^2)-to-sin(x) to be an unsafe simplification. + + * Improved simplification of sqrts, e.g., sqrt(a^2 x + a^2 y). + + * Changed solver to treat (x-a)(x-b)(x-c) more intelligently. + + * Changed Pascal language mode to use "$FFFF" for hexadecimal numbers. + + * Added support for non-decimal display of floats. + + * Changed `p' to refresh stack display if current float format uses it. + + * Changed Big mode to use subscript notation for log10(x), log(x,b), r#nnn. + + * Changed Big mode to format deriv(u,x) and tderiv(u,x) as du/dx. + + * Changed Big mode to format integ(1/x,x) as "dx/x" instead of "1/x dx". + + * Added "tty" output type for graphics commands. + + * Documented Calc's random number generation algorithm in the manual. + + * Fixed a bug involving having "(setq calc-timing t)" in .emacs. + + * Fixed a bug that incorrectly parsed "|x| - 1" in TeX mode. + + * Fixed bugs and made improvements in `a R' when widening the guess. + + * Fixed a bug that where `a S' didn't solve (x - a)^2 = (x - b)^2. + + * Fixed a bug that sometimes crashed `a P' on systems of equations. + + * Fixed a bug that prevented `b p' (calc-pack-bits) from working. + + * Fixed some bugs in which certain functions didn't get autoloaded. + + * Fixed a bug in which the date <1/1/13> was incorrectly parsed. + + * Fixed a bug which prevented `j D' from expanding (a+b)/c. + + * Fixed a bug in solver: bad inverses for sinh and cosh. + + * Fixed a bug in math-possible-signs that failed for x*0. + + * Fixed a bug where sqrt(-a) was rewritten sqrt(a)*i even if a<0. + + * Fixed a bug in line breaker when first "word" of line was too long. + + * Worked around a makeinfo bug that handled @end group/@group badly. + + +Version 2.00 alpha 3: + + * Changed logic for locating component .elc files to be even smarter. + + * Changed "make install" to "make compile"; added different "make install". + + * Improved "make compile" to check file dates and compile only when needed. + + * Made output of "make compile" in batch mode more compact and readable. + + * Replaced "Quick Overview" in manual with "Demonstration of Calc". + + * Changed to use keymaps for dispatching M-# and h prefix keys. + + * Added TAGS target to the Calc Makefile. + + * Removed most doc strings from functions; new help commands are better. + + * Got rid of some crufty "fset" calls that were cluttering the code. + + * Split calc-grab-region into two functions, calc-grab-region/-rectangle. + + * Swapped positions of stack and trail in full-calc-keypad display. + + * Improved line-breaking algorithm for displaying long formulas. + + * Improved display of control characters in vectors shown as strings. + + * Changed `d o' to allow fraction format to specify desired denominator. + + * Changed `M-# y' to respect overwrite mode in target buffer. + + * Added `H' prefix to display-mode commands to suppress stack refresh. + + * Changed "calc-why" mechanism to display urgent messages automatically. + + * Handled taking derivatives of symbolic integrals and vice-versa. + + * Handled integrating vectors of formulas. + + * Incorporated Ewerlid's polynomial division and GCD functions into Calc. + + * Improved algebraic operations on "mod" forms, esp. polynomials. + + * Added some more financial functions (sln, syd, ddb). + + * Added nest, anest, fixp, and afixp (`H V R' and `H V U') functions. + + * Added `a .' (calc-remove-equal) command to take apart equations. + + * Generalized dfact to work for negative odd integers; added !! syntax. + + * Changed `k f' to factor 1, 0, and negative integers. + + * Changed `u M', etc., to accept +/- and [ .. ] forms as distributions. + + * Changed `g q' to remove *Gnuplot Commands/Trail* window if present. + + * Added support for Francois Pinard's "dumb terminal" driver for GNUPLOT. + + * Added ":: remember" feature for rewrite rules. + + * Changed rewrites to let pattern "a*b" match "x/2" with a=x, b=1/2. + + * Added ability to put function names like "simplify" in rewrite schedule. + + * Added "Rewrites Tutorial" to the manual. + + * Changed ` to bind RET as newline instead of finish if editing a vector. + + * Added some new exercises to the List Tutorial. + + * Changed `Z F', `V M', etc. not to remove stored vars from def arg list. + + * Added parsing for /1, 2, 3/ notation for Fortran mode vectors. + + * Added a "%%" syntax for comments in formulas being read. + + * Fixed a bug in which failing `h k' removed an existing Info window. + + * Fixed a bug in `j /' operating on subformulas like "a + b". + + * Fixed a bug in which "inf = inf" undesirably evaluated to 1. + + * Fixed a bug that simplified "0 = 1 + a + 2" to "0 = a". + + * Fixed a bug that failed for rewrite patterns like "fib(1 ||| 2)". + + * Fixed a bug that arose because rewrite programs are non-reentrant. + + +Version 2.00 alpha 2: + + * Changed LFD terminating algebraic entry to push in no-simplify mode. + + * Changed so that `K -' interprets `-' as calc-minus, not neg prefix arg. + + * Improved `h c' command to understand all Calc key sequences. + + * Fixed problems with DistribRules, NegateRules, and FitRules. + + * Fixed several bad node pointers in the manual. + + * Fixed a bug in `h C-w' when used with makeinfo-formatted manuals. + + * Fixed a bug in sqrt(-1) when Polar and HMS modes are enabled. + + * Fixed/improved dscalar and deven functions; added dodd. + + * Fixed a bug in polynomial handling that also affected sum(sin(k),k,1,n). + + * Fixed various other glitches in the manual. + + +Version 2.00 alpha 1: + + * Calc's tar file now creates a calc-(version) directory to unpack into. + + * Calc now comes with a Makefile; install with "make install". + + * Calc now comes already split into many files; installation is much simpler. + + * Changed base file name of the manual from "calc-info" to "calc.info". + + * Key binding for `M-# w' was documented but not implemented. + + * Bound M-# ' to be synonymous with `M-# f' (used to be `M-# q'). + + * Changed M-# M-# to use last interface of C or K; E no longer counts. + + * Changed `i' (and `M-# i') not to return to Top node unnecessarily. + + * Changed `h' to be a prefix key with various help commands. + + * Changed `s' to be a prefix key with various store and recall commands. + + * Keys `i', `r', and `l' are obsolete (moved to `h' and `s' prefixes). + + * Rearranged `K', `X', and `M-RET' keys; `K' is now calc-keep-args. + + * Changed quick-calc to display input formula as well as output if room. + + * Changed quick-calc to interact with the editing buffer and kill ring. + + * Created pack, unpack, unpackt function equivalents of `v p', `v u'. + + * Changed to expand (a/b)^x to a^x/b^x only if b > 0 (not if a > 0). + + * Changed math-possible-signs to understand sqrt function. + + * Changed Z [, rewrites to consider any provably non-zero value as true. + + * Changed normal language modes to accept ** as a synonym for ^. + + * Added "maple" language mode. + + * Changed, e.g., Mathematica "(2 + 3 I)^(1.23*10^20)" to include parens. + + * Generalized math-compose-big properties for all language modes. + + * Introduced "string" and other function for composing expressions. + + * Changed many recursive vector routines to use loops instead. + + * Added evalv, evalvn function equivalents to `=', `N'. + + * Changed "expr =>" not to evaluate at all if in no-simplify mode. + + * Redesigned user interface of `a F' (calc-curve-fit) command. + + * Added "phase" feature to the rewrite rule system. + + * Added "&&&", "|||", "!!!" to the rewrite rule system. + + * Introduced a new notation for rewrites: LHS := RHS :: COND. + + * Changed `a r' (but not `j r') to repeat 100 times by default. + + * Integrated EvalRules more cleanly into the default simplifications. + + * Added `H v l' [mdims] to measure the dimensions of a matrix. + + * Changed `u c' to interpret "/units" as "1/units". + + * Added `u a' to adjust unit prefix letters automatically. + + * Changed `u s' to enable scalar mode while simplifying. + + * Changed `c f' [pfloat] not to float integer powers or subscripts. + + * Added a three-argument form for the "hms" function. + + * Changed, e.g., sin(90) degrees to produce 1 instead of 1.0. + + * Changed symbolic mode to prefer sqrt(int): abs([1 2 3]) => sqrt(14). + + * Enhanced solver to handle, e.g., x + 1/x = a; exp(x) + exp(-x) = a. + + * Enhanced simplifier to handle, e.g., exp(a+2) / e^a => e^2. + + * Enhanced `a s' to simplify sqrt(x) - x^1:2 and exp(x) - e^x to 0. + + * Added -(a + b) to -a - b as a default simplification. + + * Added rules for differentiating sum() and prod() functions. + + * Added a few more energy units (due to Przemek Klosowski). + + * Added overflow/underflow checking for all floating-point arithmetic. + + * Extended error forms to work with complex numbers. + + * Generalized GCD to handle fractional arguments. + + * Changed graphics routines to evaluate "x" values, e.g., [-pi .. pi]. + + * Added `g q', like `g K' but without viewing the Gnuplot Trail. + + * Changed `g p' and `V M' to display better "Working..." messages. + + * Modified `M-# g' to be more robust about grabbing formulas. + + * Added `Y' prefix key reserved for user-written extensions. + + * Added calc-load-hook and calc-ext-load-hook. + + * Prevented calc-install from leaving large ~ files behind. + + * Changed @bullet to @bullet{} in manual to conform to texinfo spec. + + * Rearranged some chapters in the manual to be a bit more logical. + + * Added calc-split-summary command. + + * Fixed several bugs in embedded mode. + + * Fixed a bug in calc-vector-covariance that required a prefix arg. + + * Fixed a bug that prevented parsing "a=>" with no right-hand side. + + * Fixed a bug which allowed incorrectly dividing a vector by a vector. + + * Fixed a bug formatting sum(...)^2 in Big mode. + + * Fixed a bug that prevented Calc from deleting old graphics temp files. + + * Fixed some typos calling calc-inverse-func instead of calc-invert-func. + + * Fixed bugs in the derivatives of conj, deg, and rad; added re, im. + + * Fixed a bug where (r;theta) parsed as r exp(theta i) even in Deg mode. + + * Fixed a bug which gave wrong answer for exp of a polar complex number. + + * Fixed a bug in `Z F' that failed if formula used non-arg variables. + + * Fixed a bad pointer to Info node "Assignments in Embedded Mode". + + * Fixed several errors in the Calc Summary. + + +Version 1.08 beta 1: + + * Calc's copyright has been assigned to FSF, for inclusion in Emacs 19! + + * Changed M-# to be a two-key sequence; use M-# M-# to start Calc now. + + * Rewrote and expanded the introductory chapter of the manual. + + * Added a key and function summary to the manual. + + * Changed the manual to take better advantage of TeX's math formatting. + + * Changed manual to be printable in @smallbook format. + + * Added "calc-embedded" mode. + + * Added "=>" [evalto] operator. + + * Added facilities for date and date/time arithmetic. + + * Added a set of financial functions (pv, fv, etc.). + + * Added infinite quantities inf, uinf, and nan (plus infinite intervals). + + * Added "EvalRules", "SimpRules", and "ExtSimpRules" variables. + + * Added sum and product commands `a +', `a -', `a *', `a T'. + + * Enhanced `a S' and `a P' to solve systems of equations. + + * Enhanced solver to handle eqns like sin(x) = cos(2 x), sqrt(x) + x = 1. + + * Added `a M' (calc-map-equation) command. + + * Added new statistical functions: mean, standard deviation, etc. + + * Added line, polynomial, and curve fitting commands (`a L' and `a F'). + + * Added support for composite units, e.g., "mi+ft+in". + + * Enhanced "Big" mode to format square roots, choose, and powers better. + + * Enhanced "Big" mode to display fractions in large notation. + + * Added several alternate formats for matrix display. + + * Changed TeX mode to write "(1 + x^2)" instead of "\left(1 + x^2\right)". + + * Added support for relational operators in TeX and FORTRAN modes. + + * Added recognition of accents like \dot, \tilde, \underline in TeX mode. + + * Added "eqn" language mode. + + * Added extra control over display justification with `d <', `d =', `d >'. + + * Added calc-left-label and calc-right-label (`d {', `d }'). + + * Added "nn%" syntax for algebraic formulas; equivalent to "nn * .01". + + * Added input syntaxes like a = b = c, a != b != c, a <= b < c. + + * Changed "_" to mean subscripts; old use of "_" in vars is now "#". + + * Introduced "matrix mode" and "scalar mode" (`m v'). + + * Introduced generic identity matrices (idn(1)). + + * Added a method for declaring variables to be real, integer, > 0, etc. + + * Added `Z S' command for editing stored value of a variable. + + * Added "subst" algebraic function equivalent to the `a b' command. + + * Added `a f' command, changed deriv/integ/solve-for to use it. + + * Improved `a s' to simplify (x + y) (y + x) to (x + y)^2. + + * Improved `a s' to simplify i^2 to -1. + + * Improved `a s' to simplify, e.g., sin(pi/3) in Symbolic mode. + + * Improved `a s' to simplify sqrt(8) to 2 sqrt(2), 1/sqrt(2) to sqrt(2)/2. + + * Moved sin(arccos(x)) from `a e' to `a s'; not unsafe after all! + + * Changed (x y)^z => x^z y^z to be a usually-unsafe simplification. + + * Added thorough documentation of `a s' and `a e' to the manual. + + * Improved `a c' to collect "f(a)" even if "a" also appears elsewhere. + + * Introduced lin, linnt, islin, islinnt functions for linearity testing. + + * Improved `a x' to use binomial theorem to give simpler answers. + + * Improved `j D' to distribute powers of sums: (a + b)^n. + + * Improved `j M' to merge products of powers (may need no-simplify mode). + + * Changed to use defvar for DistribRules etc. so `Z V' works with them. + + * Improved `j *' and `j /' to work properly in a few more cases. + + * Improved `V R' to use identity value when reducing empty vectors. + + * Improved `v p' and `v u' to support more complex packing operations. + + * Disabled automatic simplification of sqrt(2)/2 to 1/sqrt(2). + + * Bound SPC and RET to press, TAB to next-menu in *Calc Keypad* buffer. + + * Added C-u ' to do algebraic entry with language mode forced to normal. + + * Added "$1", "$2", etc. input notation for algebraic entry. + + * Changed unary operators like `n', `&' to treat neg prefix args like RET. + + * Changed ` (calc-edit) to show full precision regardless of float format. + + * Enhanced quick-calc to display integers in several formats. + + * Documented `g H' (calc-graph-hide) command (had been left from manual). + + * Enhanced floor/ceil/trunc/round in several ways. + + * Added rounde and roundu functions. + + * Changed `c 1' through `c 9' to change small floats to 0.0; added `c 0'. + + * Enhanced set operations to work on sets of intervals. + + * Fixed erf(0), utpn(x,x,y), and arccosh(-1) to work properly. + + * Changed complex arctan and arctanh to follow Steele 2nd edition. + + * Expanded "Branch Cuts" section of the manual with some useful tables. + + * Rearranged order of words in mode line to be a bit more logical. + + * Changed `m N' (num-simplify) mode to evaluate constant vectors, too. + + * Changed `a r'/`j r' to prompt twice for separate LHS/RHS if necessary. + + * Enhanced `let(v,x)' in rewrites by allowing arbitrary patterns for v. + + * Changed cursor positioning in second prompt for `a b' (calc-substitute). + + * Changed `y' to omit line numbers more consistently. + + * Changed `o' (calc-realign) to reset horizontal scrolling to zero, also. + + * Added "pred" mode for calc-eval. + + * Added "calc-report-bug" as an alias for "report-calc-bug". + + * Added `Z T' and "calc-pass-errors" to aid debugging Calc-related code. + + * Added "calc-load-everything" (`m X' or `M-# L') command. + + * Enhanced calc-install to pre-build units table, CommuteRules, etc. + + * Changed Calc to interact more gracefully with load-path. + + * Changed Lisp Variable Index in manual to include user variables, too. + + * Fixed a bug that prevented calc-install from working under VMS. + + * Fixed a bug that sometimes crashed rewrites dealing with subtractions. + + * Fixed a bug that prevented `a S' from solving "3 - x = 1 + x"! + + * Fixed a bug in solver that crashed for certain cubics and quartics. + + * Fixed a bug in calc-simplify that crashed for equations and ineqs. + + * Fixed a bug which placed the "[" oddly in `d B' + `v /' mode. + + * Fixed a bug where finishing calc-edit improperly obeyed language mode. + + * Fixed a bug formatting (-1)^n in Big mode after selection commands. + + * Fixed a bug that got ">=" and "<=" backwards in rewrite conditions. + + * Fixed a bug that broke the `"x"' key in calc-keypad mode. + + * Fixed a bug in which `MAP$' in calc-keypad didn't display "Working...". + + * Fixed a bug where matrix division gave bad result for singular matrix. + + * Fixed a bug which closed Calc window if calc-grab-region got an error. + + * Fixed a bug where `a s' failed on formulas containing dimension errors. + + * Fixed a bug that caused `m F' to hang. + + * Fixed a bug in complex arithmetic that caused problems with solver. + + * Fixed a bug which raised intervals to interval powers incorrectly. + + * Fixed a bug in utpp/ltpp (order of arguments did not match the manual). + + * Fixed a bug in which `t y' rounded yanked data with old precision. + + * Fixed a bug in which "in(3, [3 .. 3))" returned true. + + * Fixed a bug which simplified abs(abs(x)) incorrectly. + + * Fixed a bug in which (a^2)^1:3 was unsafely simplified to a^2:3. + + * Fixed a bug in rewrite system which missed pattern "2 sin(x) cos(x)". + + * Fixed a bug in rewrite system which missed pattern "a - a cos(x)^2". + + * Fixed obsolete trail tags gsmp, gneg, ginv to jsmp, jneg, jinv. + + * Fixed some errors and made improvements in units table [Ulrich Mueller]. + + +Version 1.07: + + * Added `m F' (calc-settings-file-name) command. + + * Added calc-autoload-directory variable. + + * Extended Z ` to accept a prefix argument. + + * Added keystrokes (v h, v k) for head, tail, cons. + + * Extended `v e' to accept a vector as the filler. + + * Changed `V M', `V R' to accept mapping-mode keys in uppercase, too. + + * Changed V M ' etc. to accept $, $$, ... as argument indicators. + + * Changed `t y' to accept a prefix argument. + + * Put in a cleaner and safer random number generator for `k r' et al. + + * Fixed a bug which completely broke `a r' command! + + * Fixed "0 * matrix" to generate a zero matrix instead of 0. + + * Fixed a bug in `a R' which sometimes caused it to crash. + + * Fixed a fatal typo in the TeX version of the manual. + + * Fixed a bug that prevented C-k, C-w, M-w from working in Trail buffer. + + * Fixed another bug in `Z P' command. + + * Fixed a bug in `u s' which incorrectly simplified subtractions. + + * Fixed an argument-name aliasing bug evaluating lambda( ) formulas. + + * Fixed overfull hboxes in the manual. + + * Fixed various other bugs in the manual. + + +Version 1.06: + + * Added "calc-keypad" mode for X window system users (try it!). + + * Improved "calc-eval" for calling/operating Calc from user-written Lisp. + + * Moved vector accumulate command to `V U' (old `H V R' still supported). + + * Added right-to-left reductions: `I V R' and `I V U'. + + * Added set operations on vectors: intersect, union, diff, xor. + + * Added `I v s' to remove a subvector from a vector. + + * Introduced `H |' to append two vectors with no magical special cases. + + * Introduced rhead, rtail, and rcons for isolating last vector element. + + * Changed `g p' to keep temp files around until data actually change. + + * Improved `a S' to solve many higher-order polynomial equations. + + * Added `a P' to produce a vector of all solutions to an equation. + + * Enhanced `a v' and `j v' to allow top-level-only evaluation. + + * Changed `j DEL' to delete a side of an eqn or ineq, leaving other side. + + * Fixed binding for keys `j 1' through `j 9'. + + * Introduced "let" marker in rewrite rules. + + * Enhanced the "sign" function to provide a two-argument version. + + * Changed "max-specpdl-size exceeded" error message to be user-friendly. + + * Put "<Aborted>" in the trail in above case and when user presses C-g. + + * Changed TeX mode to generate \ldots instead of \dots, recognize both. + + * Changed "sin(0)" etc. (for integer 0) to generate "0" instead of "0.". + + * Enhanced Programming Tutorial exercise 2. + + * Fixed an error in the answer to Types Tutorial exercise 3. + + * Fixed several bugs relating to head, tail, and cons functions. + + * Fixed some other minor typos in the manual. + + * Fixed several bugs in `Z P' (calc-user-define-permanent). + + * Fixed several bugs that broke the `g P' command. + + +Version 1.05: + + * Created a calc-install command to ease installation. + + * Added lots of exercises to the Tutorial section of the manual. + + * Added ability to select and operate on sub-formulas. + + * Substantially improved the algebraic rewrite-rule system. + + * Added a set of graphing commands that use GNUPLOT. + + * Added a command (`a R') for finding numerical roots to equations. + + * Added several new math functions, such as erf and Bessel functions. + + * Added key bindings for miscellaneous commands using the "f" prefix key. + + * Added lots of new vector operations, many of them in the spirit of APL. + + * Added more control over vector display, including an abbreviated mode. + + * Improved keyboard macro editing; added read-kbd-macro to macedit.el. + + * Introduced the `m S' (calc-shift-prefix) command. + + * Enhanced the calc-edit command in several ways. + + * Made it possible to hit ` (calc-edit) during numeric/algebraic entry. + + * Enhanced the calc-solve-for command to handle inequalities. + + * Enhanced calc-simplify to handle equations and inequalities. + + * Taught log10 and log to look for exact integer or rational results. + + * Added ability to take Nth roots directly. + + * Added "increment" and "decrement" commands for integers and floats. + + * Added "full-help" command, changed "h" key to invoke it. + + * Added special help for Inverse and Hyperbolic prefixes. + + * Added an optional prefix argument to `o' (calc-realign). + + * Changed `t s' and `t r' to use RET as the search exit key. + + * Made handling of operator keys for V M, V R, etc. more regular. + + * Improved TeX mode; added support for \matrix format. + + * Added a variant of `m a' mode that only affects ( and [ keys. + + * Fixed "Mismatch" message for algebraic entry of semi-open intervals. + + * Trimmed fat from calc.el to speed loading, moved more to calc-ext.el. + + * Fixed a bug in which minibuffer entry rounded to out-of-date precision. + + * Fixed a bug which crashed Calc 1.04 under Epoch. + + * Fixed a bug which messed up Calc Trail's mode line, among other things. + + * Fixed a bug which caused trail ">" to show only when in Trail buffer. + + * Fixed a bug in which "calc" called "calc-grab-region" with too few args. + + * Fixed bugs in both implementation and documentation of calc-perm. + + * Fixed a bug in which calc-simplify-extended always used radians. + + * Fixed a bug where calc-comma failed to override "polar" mode. + + * Fixed a bug doing mixed arithmetic on rectangular+polar complex numbers. + + * Fixed several bugs in transcendental functions with complex arguments. + + * Fixed a bug in which `a s' simplified "x / .5" to ".5 x". + + * Fixed numerous other bugs in various parts of Calc. + + * Completed the "Hooks" section of the "Internals" chapter of the manual. + + +Version 1.04: + + * Included a copy of revision history (from README) in calc.el. + + * Added the "calc-split" feature to split calc-ext.el into smaller bits. + + * Changed calc-unpack to unpack floats and fractions, too. + + * Added "mant", "xpon", and "scf" functions for decomposing floats. + + * Fixed a bug in the "y" command with positive prefix arguments. + + * Rearranged binary shift/rotate command keys to be a bit more convenient. + + * Fixed a bug in which simplifying "(0/0) * 2" crashed with a Lisp error. + + * Made `H F' [ffloor] and friends faster for very large arguments. + + * Made calc-define-del more robust. + + * Handled pasting of data into the Calculator using the mouse under X. + + * Made overlay-arrow variables buffer-local to avoid interference. + + * Fixed a problem in which Calc Trail buffer got stuck after a C-x C-w. + + +Version 1.03: + + * Changed math-choose to compute n-choose-m faster when m is large. + + * Fixed some problems with TeX mode. + + * Fixed a bug that prevented `b s' from working without a prefix argument. + + * Added "calc-eval" function. + + * Improved calc-grab-region. + + +Version 1.02: + + * Fixed a bug in Tutorial: telephone pole height/distance were switched! + + * Fixed a few other things in the manual. + + * Added "full-calc" command. + + * Added "calc-insert-variables" (`Z I') command. + + * Quick Calc now works even if you are already in the minibuffer. + + * Fixed a bug in math-mul-bignum-digit which affected math-and, etc. + + * Definition of "Hectares" was wrong in units table. + + * Fixed a bug in calc-execute-kbd-macro concerning undo and refresh. + + * Bound "calc-undo" to `C-x u' as well as `C-_' and `U'. + +Version 1.01: + + * Added a tutorial section to the manual. + + * Next and Prev for node Strings in the manual were reversed; fixed. + + * Changed "'bignum" in calc-isqrt-bignum-iter to "'bigpos". + + * Fixed a bug that prevented "$" from working during algebraic entry. + + * Fixed a bug caused by an X (last-X) command following a K (macro) cmd. + + * Fixed a bug in which K command incorrectly formatted stack in Big mode. + + * Added space between unary operators and non-flat compositions. + (Otherwise, "-(a/b)" in Big mode blended the minus sign into the rule!) + + * Fixed formatting of (-1)^n in Big mode. + + * Fixed some problems relating to "not" operator in Pascal language mode. + + * Fixed several bugs relating to V M ' and V M $ sequences. + + * Fixed matrix-vector multiplication to produce a vector. + + * Introduced Z ` ... Z ' commands; renamed old Z ' to Z #. + + * Fixed various other bugs. + + * Added calc-settings-file variable suggested by C. Witty. + + +Version 1.00: + + * First official release of Calc. + + * If you used the Beta test version (0.01), you will find that this + version of Calc is over 50% larger than the original release. + General areas of improvement include much better algebra features; + operations on units; language modes; simplification modes; interval + arithmetic; vector mapping and reduction. Other new commands include + calc-fraction and calc-grab-region. The program has been split into + two parts for faster loading, and the manual is more complete. + diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el new file mode 100644 index 0000000000..f9a135c6d7 --- /dev/null +++ b/lisp/calc/calc-aent.el @@ -0,0 +1,1163 @@ +;; Calculator for GNU Emacs, part I [calc-aent.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc.el. +(require 'calc) + +(require 'calc-macs) + +(defun calc-Need-calc-aent () nil) + + +(defun calc-do-quick-calc () + (calc-check-defines) + (if (eq major-mode 'calc-mode) + (calc-algebraic-entry t) + (let (buf shortbuf) + (save-excursion + (calc-create-buffer) + (let* ((calc-command-flags nil) + (calc-dollar-values calc-quick-prev-results) + (calc-dollar-used 0) + (enable-recursive-minibuffers t) + (calc-language (if (memq calc-language '(nil big)) + 'flat calc-language)) + (entry (calc-do-alg-entry "" "Quick calc: " t)) + (alg-exp (mapcar (function + (lambda (x) + (if (and (not calc-extensions-loaded) + calc-previous-alg-entry + (string-match + "\\`[-0-9._+*/^() ]+\\'" + calc-previous-alg-entry)) + (calc-normalize x) + (calc-extensions) + (math-evaluate-expr x)))) + entry))) + (if (and (= (length alg-exp) 1) + (eq (car-safe (car alg-exp)) 'calcFunc-assign) + (= (length (car alg-exp)) 3) + (eq (car-safe (nth 1 (car alg-exp))) 'var)) + (progn + (calc-extensions) + (set (nth 2 (nth 1 (car alg-exp))) (nth 2 (car alg-exp))) + (calc-refresh-evaltos (nth 2 (nth 1 (car alg-exp)))) + (setq alg-exp (list (nth 2 (car alg-exp)))))) + (setq calc-quick-prev-results alg-exp + buf (mapconcat (function (lambda (x) + (math-format-value x 1000))) + alg-exp + " ") + shortbuf buf) + (if (and (= (length alg-exp) 1) + (memq (car-safe (car alg-exp)) '(nil bigpos bigneg)) + (< (length buf) 20) + (= calc-number-radix 10)) + (setq buf (concat buf " (" + (let ((calc-number-radix 16)) + (math-format-value (car alg-exp) 1000)) + ", " + (let ((calc-number-radix 8)) + (math-format-value (car alg-exp) 1000)) + (if (and (integerp (car alg-exp)) + (> (car alg-exp) 0) + (< (car alg-exp) 127)) + (format ", \"%c\"" (car alg-exp)) + "") + ")"))) + (if (and (< (length buf) (screen-width)) (= (length entry) 1) + calc-extensions-loaded) + (let ((long (concat (math-format-value (car entry) 1000) + " => " buf))) + (if (<= (length long) (- (screen-width) 8)) + (setq buf long)))) + (calc-handle-whys) + (message "Result: %s" buf))) + (if (eq last-command-char 10) + (insert shortbuf) + (setq kill-ring (cons shortbuf kill-ring)) + (if (> (length kill-ring) kill-ring-max) + (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)) + (setq kill-ring-yank-pointer kill-ring)))) +) + +(defun calc-do-calc-eval (str separator args) + (calc-check-defines) + (catch 'calc-error + (save-excursion + (calc-create-buffer) + (cond + ((and (consp str) (not (symbolp (car str)))) + (let ((calc-language nil) + (math-expr-opers math-standard-opers) + (calc-internal-prec 12) + (calc-word-size 32) + (calc-symbolic-mode nil) + (calc-matrix-mode nil) + (calc-angle-mode 'deg) + (calc-number-radix 10) + (calc-leading-zeros nil) + (calc-group-digits nil) + (calc-point-char ".") + (calc-frac-format '(":" nil)) + (calc-prefer-frac nil) + (calc-hms-format "%s@ %s' %s\"") + (calc-date-format '((H ":" mm C SS pp " ") + Www " " Mmm " " D ", " YYYY)) + (calc-float-format '(float 0)) + (calc-full-float-format '(float 0)) + (calc-complex-format nil) + (calc-matrix-just nil) + (calc-full-vectors t) + (calc-break-vectors nil) + (calc-vector-commas ",") + (calc-vector-brackets "[]") + (calc-matrix-brackets '(R O)) + (calc-complex-mode 'cplx) + (calc-infinite-mode nil) + (calc-display-strings nil) + (calc-simplify-mode nil) + (calc-display-working-message 'lots) + (strp (cdr str))) + (while strp + (set (car strp) (nth 1 strp)) + (setq strp (cdr (cdr strp)))) + (calc-do-calc-eval (car str) separator args))) + ((eq separator 'eval) + (eval str)) + ((eq separator 'macro) + (calc-extensions) + (let* ((calc-buffer (current-buffer)) + (calc-window (get-buffer-window calc-buffer)) + (save-window (selected-window))) + (if calc-window + (unwind-protect + (progn + (select-window calc-window) + (calc-execute-kbd-macro str nil (car args))) + (and (window-point save-window) + (select-window save-window))) + (save-window-excursion + (select-window (get-largest-window)) + (switch-to-buffer calc-buffer) + (calc-execute-kbd-macro str nil (car args))))) + nil) + ((eq separator 'pop) + (or (not (integerp str)) + (= str 0) + (calc-pop (min str (calc-stack-size)))) + (calc-stack-size)) + ((eq separator 'top) + (and (integerp str) + (> str 0) + (<= str (calc-stack-size)) + (math-format-value (calc-top-n str (car args)) 1000))) + ((eq separator 'rawtop) + (and (integerp str) + (> str 0) + (<= str (calc-stack-size)) + (calc-top-n str (car args)))) + (t + (let* ((calc-command-flags nil) + (calc-next-why nil) + (calc-language (if (memq calc-language '(nil big)) + 'flat calc-language)) + (calc-dollar-values (mapcar + (function + (lambda (x) + (if (stringp x) + (progn + (setq x (math-read-exprs x)) + (if (eq (car-safe x) + 'error) + (throw 'calc-error + (calc-eval-error + (cdr x))) + (car x))) + x))) + args)) + (calc-dollar-used 0) + (res (if (stringp str) + (math-read-exprs str) + (list str))) + buf) + (if (eq (car res) 'error) + (calc-eval-error (cdr res)) + (setq res (mapcar 'calc-normalize res)) + (and (memq 'clear-message calc-command-flags) + (message "")) + (cond ((eq separator 'pred) + (calc-extensions) + (if (= (length res) 1) + (math-is-true (car res)) + (calc-eval-error '(0 "Single value expected")))) + ((eq separator 'raw) + (if (= (length res) 1) + (car res) + (calc-eval-error '(0 "Single value expected")))) + ((eq separator 'list) + res) + ((memq separator '(num rawnum)) + (if (= (length res) 1) + (if (math-constp (car res)) + (if (eq separator 'num) + (math-format-value (car res) 1000) + (car res)) + (calc-eval-error + (list 0 + (if calc-next-why + (calc-explain-why (car calc-next-why)) + "Number expected")))) + (calc-eval-error '(0 "Single value expected")))) + ((eq separator 'push) + (calc-push-list res) + nil) + (t (while res + (setq buf (concat buf + (and buf (or separator ", ")) + (math-format-value (car res) 1000)) + res (cdr res))) + buf)))))))) +) + +(defun calc-eval-error (msg) + (if (and (boundp 'calc-eval-error) + calc-eval-error) + (if (eq calc-eval-error 'string) + (nth 1 msg) + (error "%s" (nth 1 msg))) + msg) +) + + +;;;; Reading an expression in algebraic form. + +(defun calc-auto-algebraic-entry (&optional prefix) + (interactive "P") + (calc-algebraic-entry prefix t) +) + +(defun calc-algebraic-entry (&optional prefix auto) + (interactive "P") + (calc-wrapper + (let ((calc-language (if prefix nil calc-language)) + (math-expr-opers (if prefix math-standard-opers math-expr-opers))) + (calc-alg-entry (and auto (char-to-string last-command-char))))) +) + +(defun calc-alg-entry (&optional initial prompt) + (let* ((sel-mode nil) + (calc-dollar-values (mapcar 'calc-get-stack-element + (nthcdr calc-stack-top calc-stack))) + (calc-dollar-used 0) + (calc-plain-entry t) + (alg-exp (calc-do-alg-entry initial prompt t))) + (if (stringp alg-exp) + (progn + (calc-extensions) + (calc-alg-edit alg-exp)) + (let* ((calc-simplify-mode (if (eq last-command-char ?\C-j) + 'none + calc-simplify-mode)) + (nvals (mapcar 'calc-normalize alg-exp))) + (while alg-exp + (calc-record (if calc-extensions-loaded (car alg-exp) (car nvals)) + "alg'") + (calc-pop-push-record-list calc-dollar-used + (and (not (equal (car alg-exp) + (car nvals))) + calc-extensions-loaded + "") + (list (car nvals))) + (setq alg-exp (cdr alg-exp) + nvals (cdr nvals) + calc-dollar-used 0))) + (calc-handle-whys))) +) + +(defun calc-do-alg-entry (&optional initial prompt no-normalize) + (let* ((calc-buffer (current-buffer)) + (blink-paren-hook 'calcAlg-blink-matching-open) + (alg-exp 'error)) + (if (boundp 'calc-alg-ent-map) + () + (setq calc-alg-ent-map (copy-keymap minibuffer-local-map)) + (define-key calc-alg-ent-map "'" 'calcAlg-previous) + (define-key calc-alg-ent-map "`" 'calcAlg-edit) + (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter) + (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter) + (or calc-emacs-type-19 + (let ((i 33)) + (setq calc-alg-ent-esc-map (copy-sequence esc-map)) + (while (< i 127) + (aset calc-alg-ent-esc-map i 'calcAlg-escape) + (setq i (1+ i)))))) + (or calc-emacs-type-19 + (define-key calc-alg-ent-map "\e" nil)) + (if (eq calc-algebraic-mode 'total) + (define-key calc-alg-ent-map "\e" calc-alg-ent-esc-map) + (define-key calc-alg-ent-map "\ep" 'calcAlg-plus-minus) + (define-key calc-alg-ent-map "\em" 'calcAlg-mod) + (define-key calc-alg-ent-map "\e=" 'calcAlg-equals) + (define-key calc-alg-ent-map "\e\r" 'calcAlg-equals) + (define-key calc-alg-ent-map "\e%" 'self-insert-command)) + (setq calc-aborted-prefix nil) + (let ((buf (read-from-minibuffer (or prompt "Algebraic: ") + (or initial "") + calc-alg-ent-map nil))) + (if (eq alg-exp 'error) + (if (eq (car-safe (setq alg-exp (math-read-exprs buf))) 'error) + (setq alg-exp nil))) + (setq calc-aborted-prefix "alg'") + (or no-normalize + (and alg-exp (setq alg-exp (mapcar 'calc-normalize alg-exp)))) + alg-exp)) +) + +(defun calcAlg-plus-minus () + (interactive) + (if (calc-minibuffer-contains ".* \\'") + (insert "+/- ") + (insert " +/- ")) +) + +(defun calcAlg-mod () + (interactive) + (if (not (calc-minibuffer-contains ".* \\'")) + (insert " ")) + (if (calc-minibuffer-contains ".* mod +\\'") + (if calc-previous-modulo + (insert (math-format-flat-expr calc-previous-modulo 0)) + (beep)) + (insert "mod ")) +) + +(defun calcAlg-previous () + (interactive) + (if (calc-minibuffer-contains "\\`\\'") + (if calc-previous-alg-entry + (insert calc-previous-alg-entry) + (beep)) + (insert "'")) +) + +(defun calcAlg-equals () + (interactive) + (unwind-protect + (calcAlg-enter) + (if (consp alg-exp) + (progn (setq prefix-arg (length alg-exp)) + (calc-unread-command ?=)))) +) + +(defun calcAlg-escape () + (interactive) + (calc-unread-command) + (save-excursion + (calc-select-buffer) + (use-local-map calc-mode-map)) + (calcAlg-enter) +) + +(defun calcAlg-edit () + (interactive) + (if (or (not calc-plain-entry) + (calc-minibuffer-contains + "\\`\\([^\"]*\"[^\"]*\"\\)*[^\"]*\"[^\"]*\\'")) + (insert "`") + (setq alg-exp (buffer-string)) + (and (> (length alg-exp) 0) (setq calc-previous-alg-entry alg-exp)) + (exit-minibuffer)) +) +(setq calc-plain-entry nil) + +(defun calcAlg-enter () + (interactive) + (let* ((str (buffer-string)) + (exp (and (> (length str) 0) + (save-excursion + (set-buffer calc-buffer) + (math-read-exprs str))))) + (if (eq (car-safe exp) 'error) + (progn + (goto-char (point-min)) + (forward-char (nth 1 exp)) + (beep) + (calc-temp-minibuffer-message + (concat " [" (or (nth 2 exp) "Error") "]")) + (calc-clear-unread-commands)) + (setq alg-exp (if (calc-minibuffer-contains "\\` *\\[ *\\'") + '((incomplete vec)) + exp)) + (and (> (length str) 0) (setq calc-previous-alg-entry str)) + (exit-minibuffer))) +) + +(defun calcAlg-blink-matching-open () + (let ((oldpos (point)) + (blinkpos nil)) + (save-excursion + (condition-case () + (setq blinkpos (scan-sexps oldpos -1)) + (error nil))) + (if (and blinkpos + (> oldpos (1+ (point-min))) + (or (and (= (char-after (1- oldpos)) ?\)) + (= (char-after blinkpos) ?\[)) + (and (= (char-after (1- oldpos)) ?\]) + (= (char-after blinkpos) ?\())) + (save-excursion + (goto-char blinkpos) + (looking-at ".+\\(\\.\\.\\|\\\\dots\\|\\\\ldots\\)"))) + (let ((saved (aref (syntax-table) (char-after blinkpos)))) + (unwind-protect + (progn + (aset (syntax-table) (char-after blinkpos) + (+ (logand saved 255) + (lsh (char-after (1- oldpos)) 8))) + (blink-matching-open)) + (aset (syntax-table) (char-after blinkpos) saved))) + (blink-matching-open))) +) + + +(defun calc-alg-digit-entry () + (calc-alg-entry + (cond ((eq last-command-char ?e) + (if (> calc-number-radix 14) (format "%d.^" calc-number-radix) "1e")) + ((eq last-command-char ?#) (format "%d#" calc-number-radix)) + ((eq last-command-char ?_) "-") + ((eq last-command-char ?@) "0@ ") + (t (char-to-string last-command-char)))) +) + +(defun calcDigit-algebraic () + (interactive) + (if (calc-minibuffer-contains ".*[@oh] *[^'m ]+[^'m]*\\'") + (calcDigit-key) + (setq calc-digit-value (buffer-string)) + (exit-minibuffer)) +) + +(defun calcDigit-edit () + (interactive) + (calc-unread-command) + (setq calc-digit-value (buffer-string)) + (exit-minibuffer) +) + + +;;; Algebraic expression parsing. [Public] + +(defun math-read-exprs (exp-str) + (let ((exp-pos 0) + (exp-old-pos 0) + (exp-keep-spaces nil) + exp-token exp-data) + (if calc-language-input-filter + (setq exp-str (funcall calc-language-input-filter exp-str))) + (while (setq exp-token (string-match "\\.\\.\\([^.]\\|.[^.]\\)" exp-str)) + (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots" + (substring exp-str (+ exp-token 2))))) + (math-build-parse-table) + (math-read-token) + (let ((val (catch 'syntax (math-read-expr-list)))) + (if (stringp val) + (list 'error exp-old-pos val) + (if (equal exp-token 'end) + val + (list 'error exp-old-pos "Syntax error"))))) +) + +(defun math-read-expr-list () + (let* ((exp-keep-spaces nil) + (val (list (math-read-expr-level 0))) + (last val)) + (while (equal exp-data ",") + (math-read-token) + (let ((rest (list (math-read-expr-level 0)))) + (setcdr last rest) + (setq last rest))) + val) +) + +(setq calc-user-parse-table nil) +(setq calc-last-main-parse-table nil) +(setq calc-last-lang-parse-table nil) +(setq calc-user-tokens nil) +(setq calc-user-token-chars nil) + +(defun math-build-parse-table () + (let ((mtab (cdr (assq nil calc-user-parse-tables))) + (ltab (cdr (assq calc-language calc-user-parse-tables)))) + (or (and (eq mtab calc-last-main-parse-table) + (eq ltab calc-last-lang-parse-table)) + (let ((p (append mtab ltab)) + (toks nil)) + (setq calc-user-parse-table p) + (setq calc-user-token-chars nil) + (while p + (math-find-user-tokens (car (car p))) + (setq p (cdr p))) + (setq calc-user-tokens (mapconcat 'identity + (sort (mapcar 'car toks) + (function (lambda (x y) + (> (length x) + (length y))))) + "\\|") + calc-last-main-parse-table mtab + calc-last-lang-parse-table ltab)))) +) + +(defun math-find-user-tokens (p) ; uses "toks" + (while p + (cond ((and (stringp (car p)) + (or (> (length (car p)) 1) (equal (car p) "$") + (equal (car p) "\"")) + (string-match "[^a-zA-Z0-9]" (car p))) + (let ((s (regexp-quote (car p)))) + (if (string-match "\\`[a-zA-Z0-9]" s) + (setq s (concat "\\<" s))) + (if (string-match "[a-zA-Z0-9]\\'" s) + (setq s (concat s "\\>"))) + (or (assoc s toks) + (progn + (setq toks (cons (list s) toks)) + (or (memq (aref (car p) 0) calc-user-token-chars) + (setq calc-user-token-chars + (cons (aref (car p) 0) + calc-user-token-chars))))))) + ((consp (car p)) + (math-find-user-tokens (nth 1 (car p))) + (or (eq (car (car p)) '\?) + (math-find-user-tokens (nth 2 (car p)))))) + (setq p (cdr p))) +) + +(defun math-read-token () + (if (>= exp-pos (length exp-str)) + (setq exp-old-pos exp-pos + exp-token 'end + exp-data "\000") + (let ((ch (aref exp-str exp-pos))) + (setq exp-old-pos exp-pos) + (cond ((memq ch '(32 10 9)) + (setq exp-pos (1+ exp-pos)) + (if exp-keep-spaces + (setq exp-token 'space + exp-data " ") + (math-read-token))) + ((and (memq ch calc-user-token-chars) + (let ((case-fold-search nil)) + (eq (string-match calc-user-tokens exp-str exp-pos) + exp-pos))) + (setq exp-token 'punc + exp-data (math-match-substring exp-str 0) + exp-pos (match-end 0))) + ((or (and (>= ch ?a) (<= ch ?z)) + (and (>= ch ?A) (<= ch ?Z))) + (string-match (if (memq calc-language '(c fortran pascal maple)) + "[a-zA-Z0-9_#]*" + "[a-zA-Z0-9'#]*") + exp-str exp-pos) + (setq exp-token 'symbol + exp-pos (match-end 0) + exp-data (math-restore-dashes + (math-match-substring exp-str 0))) + (if (eq calc-language 'eqn) + (let ((code (assoc exp-data math-eqn-ignore-words))) + (cond ((null code)) + ((null (cdr code)) + (math-read-token)) + ((consp (nth 1 code)) + (math-read-token) + (if (assoc exp-data (cdr code)) + (setq exp-data (format "%s %s" + (car code) exp-data)))) + ((eq (nth 1 code) 'punc) + (setq exp-token 'punc + exp-data (nth 2 code))) + (t + (math-read-token) + (math-read-token)))))) + ((or (and (>= ch ?0) (<= ch ?9)) + (and (eq ch '?\.) + (eq (string-match "\\.[0-9]" exp-str exp-pos) exp-pos)) + (and (eq ch '?_) + (eq (string-match "_\\.?[0-9]" exp-str exp-pos) exp-pos) + (or (eq exp-pos 0) + (and (memq calc-language '(nil flat big unform + tex eqn)) + (eq (string-match "[^])}\"a-zA-Z0-9'$]_" + exp-str (1- exp-pos)) + (1- exp-pos)))))) + (or (and (eq calc-language 'c) + (string-match "0[xX][0-9a-fA-F]+" exp-str exp-pos)) + (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\(0*\\([2-9]\\|1[0-4]\\)\\(#\\|\\^\\^\\)[0-9a-dA-D.]+[eE][-+_]?[0-9]+\\|0*\\([2-9]\\|[0-2][0-9]\\|3[0-6]\\)\\(#\\|\\^\\^\\)[0-9a-zA-Z:.]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?" exp-str exp-pos)) + (setq exp-token 'number + exp-data (math-match-substring exp-str 0) + exp-pos (match-end 0))) + ((eq ch ?\$) + (if (and (eq calc-language 'pascal) + (eq (string-match + "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)" + exp-str exp-pos) + exp-pos)) + (setq exp-token 'number + exp-data (math-match-substring exp-str 1) + exp-pos (match-end 1)) + (if (eq (string-match "\\$\\([1-9][0-9]*\\)" exp-str exp-pos) + exp-pos) + (setq exp-data (- (string-to-int (math-match-substring + exp-str 1)))) + (string-match "\\$+" exp-str exp-pos) + (setq exp-data (- (match-end 0) (match-beginning 0)))) + (setq exp-token 'dollar + exp-pos (match-end 0)))) + ((eq ch ?\#) + (if (eq (string-match "#\\([1-9][0-9]*\\)" exp-str exp-pos) + exp-pos) + (setq exp-data (string-to-int + (math-match-substring exp-str 1)) + exp-pos (match-end 0)) + (setq exp-data 1 + exp-pos (1+ exp-pos))) + (setq exp-token 'hash)) + ((eq (string-match "~=\\|<=\\|>=\\|<>\\|/=\\|\\+/-\\|\\\\dots\\|\\\\ldots\\|\\*\\*\\|<<\\|>>\\|==\\|!=\\|&&&\\||||\\|!!!\\|&&\\|||\\|!!\\|:=\\|::\\|=>" + exp-str exp-pos) + exp-pos) + (setq exp-token 'punc + exp-data (math-match-substring exp-str 0) + exp-pos (match-end 0))) + ((and (eq ch ?\") + (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)" exp-str exp-pos)) + (if (eq calc-language 'eqn) + (progn + (setq exp-str (copy-sequence exp-str)) + (aset exp-str (match-beginning 1) ?\{) + (if (< (match-end 1) (length exp-str)) + (aset exp-str (match-end 1) ?\})) + (math-read-token)) + (setq exp-token 'string + exp-data (math-match-substring exp-str 1) + exp-pos (match-end 0)))) + ((and (= ch ?\\) (eq calc-language 'tex) + (< exp-pos (1- (length exp-str)))) + (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" exp-str exp-pos) + (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" exp-str exp-pos)) + (setq exp-token 'symbol + exp-pos (match-end 0) + exp-data (math-restore-dashes + (math-match-substring exp-str 1))) + (let ((code (assoc exp-data math-tex-ignore-words))) + (cond ((null code)) + ((null (cdr code)) + (math-read-token)) + ((eq (nth 1 code) 'punc) + (setq exp-token 'punc + exp-data (nth 2 code))) + ((and (eq (nth 1 code) 'mat) + (string-match " *{" exp-str exp-pos)) + (setq exp-pos (match-end 0) + exp-token 'punc + exp-data "[") + (let ((right (string-match "}" exp-str exp-pos))) + (and right + (setq exp-str (copy-sequence exp-str)) + (aset exp-str right ?\]))))))) + ((and (= ch ?\.) (eq calc-language 'fortran) + (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\." + exp-str exp-pos) exp-pos)) + (setq exp-token 'punc + exp-data (upcase (math-match-substring exp-str 0)) + exp-pos (match-end 0))) + ((and (eq calc-language 'math) + (eq (string-match "\\[\\[\\|->\\|:>" exp-str exp-pos) + exp-pos)) + (setq exp-token 'punc + exp-data (math-match-substring exp-str 0) + exp-pos (match-end 0))) + ((and (eq calc-language 'eqn) + (eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^" + exp-str exp-pos) + exp-pos)) + (setq exp-token 'punc + exp-data (math-match-substring exp-str 0) + exp-pos (match-end 0)) + (and (eq (string-match "\\\\dots\\." exp-str exp-pos) exp-pos) + (setq exp-pos (match-end 0))) + (if (memq (aref exp-data 0) '(?~ ?^)) + (math-read-token))) + ((eq (string-match "%%.*$" exp-str exp-pos) exp-pos) + (setq exp-pos (match-end 0)) + (math-read-token)) + (t + (if (and (eq ch ?\{) (memq calc-language '(tex eqn))) + (setq ch ?\()) + (if (and (eq ch ?\}) (memq calc-language '(tex eqn))) + (setq ch ?\))) + (if (and (eq ch ?\&) (eq calc-language 'tex)) + (setq ch ?\,)) + (setq exp-token 'punc + exp-data (char-to-string ch) + exp-pos (1+ exp-pos)))))) +) + + +(defun math-read-expr-level (exp-prec &optional exp-term) + (let* ((x (math-read-factor)) (first t) op op2) + (while (and (or (and calc-user-parse-table + (setq op (calc-check-user-syntax x exp-prec)) + (setq x op + op '("2x" ident 999999 -1))) + (and (setq op (assoc exp-data math-expr-opers)) + (/= (nth 2 op) -1) + (or (and (setq op2 (assoc + exp-data + (cdr (memq op math-expr-opers)))) + (eq (= (nth 3 op) -1) + (/= (nth 3 op2) -1)) + (eq (= (nth 3 op2) -1) + (not (math-factor-after))) + (setq op op2)) + t)) + (and (or (eq (nth 2 op) -1) + (memq exp-token '(symbol number dollar hash)) + (equal exp-data "(") + (and (equal exp-data "[") + (not (eq calc-language 'math)) + (not (and exp-keep-spaces + (eq (car-safe x) 'vec))))) + (or (not (setq op (assoc exp-data math-expr-opers))) + (/= (nth 2 op) -1)) + (or (not calc-user-parse-table) + (not (eq exp-token 'symbol)) + (let ((p calc-user-parse-table)) + (while (and p + (or (not (integerp + (car (car (car p))))) + (not (equal + (nth 1 (car (car p))) + exp-data)))) + (setq p (cdr p))) + (not p))) + (setq op (assoc "2x" math-expr-opers)))) + (not (and exp-term (equal exp-data exp-term))) + (>= (nth 2 op) exp-prec)) + (if (not (equal (car op) "2x")) + (math-read-token)) + (and (memq (nth 1 op) '(sdev mod)) + (calc-extensions)) + (setq x (cond ((consp (nth 1 op)) + (funcall (car (nth 1 op)) x op)) + ((eq (nth 3 op) -1) + (if (eq (nth 1 op) 'ident) + x + (if (eq (nth 1 op) 'closing) + (if (eq (nth 2 op) exp-prec) + (progn + (setq exp-prec 1000) + x) + (throw 'syntax "Mismatched delimiters")) + (list (nth 1 op) x)))) + ((and (not first) + (memq (nth 1 op) math-alg-inequalities) + (memq (car-safe x) math-alg-inequalities)) + (calc-extensions) + (math-composite-inequalities x op)) + (t (list (nth 1 op) + x + (math-read-expr-level (nth 3 op) exp-term)))) + first nil)) + x) +) + +(defun calc-check-user-syntax (&optional x prec) + (let ((p calc-user-parse-table) + (matches nil) + match rule) + (while (and p + (or (not (progn + (setq rule (car (car p))) + (if x + (and (integerp (car rule)) + (>= (car rule) prec) + (equal exp-data + (car (setq rule (cdr rule))))) + (equal exp-data (car rule))))) + (let ((save-exp-pos exp-pos) + (save-exp-old-pos exp-old-pos) + (save-exp-token exp-token) + (save-exp-data exp-data)) + (or (not (listp + (setq matches (calc-match-user-syntax rule)))) + (let ((args (progn + (calc-extensions) + calc-arg-values)) + (conds nil) + temp) + (if x + (setq matches (cons x matches))) + (setq match (cdr (car p))) + (while (and (eq (car-safe match) + 'calcFunc-condition) + (= (length match) 3)) + (setq conds (append (math-flatten-lands + (nth 2 match)) + conds) + match (nth 1 match))) + (while (and conds match) + (calc-extensions) + (cond ((eq (car-safe (car conds)) + 'calcFunc-let) + (setq temp (car conds)) + (or (= (length temp) 3) + (and (= (length temp) 2) + (eq (car-safe (nth 1 temp)) + 'calcFunc-assign) + (= (length (nth 1 temp)) 3) + (setq temp (nth 1 temp))) + (setq match nil)) + (setq matches (cons + (math-normalize + (math-multi-subst + (nth 2 temp) + args matches)) + matches) + args (cons (nth 1 temp) + args))) + ((and (eq (car-safe (car conds)) + 'calcFunc-matches) + (= (length (car conds)) 3)) + (setq temp (calcFunc-vmatches + (math-multi-subst + (nth 1 (car conds)) + args matches) + (nth 2 (car conds)))) + (if (eq temp 0) + (setq match nil) + (while (setq temp (cdr temp)) + (setq matches (cons (nth 2 (car temp)) + matches) + args (cons (nth 1 (car temp)) + args))))) + (t + (or (math-is-true (math-simplify + (math-multi-subst + (car conds) + args matches))) + (setq match nil)))) + (setq conds (cdr conds))) + (if match + (not (setq match (math-multi-subst + match args matches))) + (setq exp-old-pos save-exp-old-pos + exp-token save-exp-token + exp-data save-exp-data + exp-pos save-exp-pos))))))) + (setq p (cdr p))) + (and p match)) +) + +(defun calc-match-user-syntax (p &optional term) + (let ((matches nil) + (save-exp-pos exp-pos) + (save-exp-old-pos exp-old-pos) + (save-exp-token exp-token) + (save-exp-data exp-data)) + (while (and p + (cond ((stringp (car p)) + (and (equal exp-data (car p)) + (progn + (math-read-token) + t))) + ((integerp (car p)) + (and (setq m (catch 'syntax + (math-read-expr-level + (car p) + (if (cdr p) + (if (consp (nth 1 p)) + (car (nth 1 (nth 1 p))) + (nth 1 p)) + term)))) + (not (stringp m)) + (setq matches (nconc matches (list m))))) + ((eq (car (car p)) '\?) + (setq m (calc-match-user-syntax (nth 1 (car p)))) + (or (nth 2 (car p)) + (setq matches + (nconc matches + (list + (cons 'vec (and (listp m) m)))))) + (or (listp m) (not (nth 2 (car p))) + (not (eq (aref (car (nth 2 (car p))) 0) ?\$)) + (eq exp-token 'end))) + (t + (setq m (calc-match-user-syntax (nth 1 (car p)) + (car (nth 2 (car p))))) + (if (listp m) + (let ((vec (cons 'vec m)) + opos mm) + (while (and (listp + (setq opos exp-pos + mm (calc-match-user-syntax + (or (nth 2 (car p)) + (nth 1 (car p))) + (car (nth 2 (car p)))))) + (> exp-pos opos)) + (setq vec (nconc vec mm))) + (setq matches (nconc matches (list vec)))) + (and (eq (car (car p)) '*) + (setq matches (nconc matches (list '(vec))))))))) + (setq p (cdr p))) + (if p + (setq exp-pos save-exp-pos + exp-old-pos save-exp-old-pos + exp-token save-exp-token + exp-data save-exp-data + matches "Failed")) + matches) +) + +(defconst math-alg-inequalities + '(calcFunc-lt calcFunc-gt calcFunc-leq calcFunc-geq + calcFunc-eq calcFunc-neq)) + +(defun math-remove-dashes (x) + (if (string-match "\\`\\(.*\\)-\\(.*\\)\\'" x) + (math-remove-dashes + (concat (math-match-substring x 1) "#" (math-match-substring x 2))) + x) +) + +(defun math-restore-dashes (x) + (if (string-match "\\`\\(.*\\)[#_]\\(.*\\)\\'" x) + (math-restore-dashes + (concat (math-match-substring x 1) "-" (math-match-substring x 2))) + x) +) + +(defun math-read-if (cond op) + (let ((then (math-read-expr-level 0))) + (or (equal exp-data ":") + (throw 'syntax "Expected ':'")) + (math-read-token) + (list 'calcFunc-if cond then (math-read-expr-level (nth 3 op)))) +) + +(defun math-factor-after () + (let ((exp-pos exp-pos) + exp-old-pos exp-token exp-data) + (math-read-token) + (or (memq exp-token '(number symbol dollar hash string)) + (and (assoc exp-data '(("-") ("+") ("!") ("|") ("/"))) + (assoc (concat "u" exp-data) math-expr-opers)) + (eq (nth 2 (assoc exp-data math-expr-opers)) -1) + (assoc exp-data '(("(") ("[") ("{"))))) +) + +(defun math-read-factor () + (let (op) + (cond ((eq exp-token 'number) + (let ((num (math-read-number exp-data))) + (if (not num) + (progn + (setq exp-old-pos exp-pos) + (throw 'syntax "Bad format"))) + (math-read-token) + (if (and math-read-expr-quotes + (consp num)) + (list 'quote num) + num))) + ((and calc-user-parse-table + (setq op (calc-check-user-syntax))) + op) + ((or (equal exp-data "-") + (equal exp-data "+") + (equal exp-data "!") + (equal exp-data "|") + (equal exp-data "/")) + (setq exp-data (concat "u" exp-data)) + (math-read-factor)) + ((and (setq op (assoc exp-data math-expr-opers)) + (eq (nth 2 op) -1)) + (if (consp (nth 1 op)) + (funcall (car (nth 1 op)) op) + (math-read-token) + (let ((val (math-read-expr-level (nth 3 op)))) + (cond ((eq (nth 1 op) 'ident) + val) + ((and (Math-numberp val) + (equal (car op) "u-")) + (math-neg val)) + (t (list (nth 1 op) val)))))) + ((eq exp-token 'symbol) + (let ((sym (intern exp-data))) + (math-read-token) + (if (equal exp-data calc-function-open) + (let ((f (assq sym math-expr-function-mapping))) + (math-read-token) + (if (consp (cdr f)) + (funcall (car (cdr f)) f sym) + (let ((args (if (or (equal exp-data calc-function-close) + (eq exp-token 'end)) + nil + (math-read-expr-list)))) + (if (not (or (equal exp-data calc-function-close) + (eq exp-token 'end))) + (throw 'syntax "Expected `)'")) + (math-read-token) + (if (and (eq calc-language 'fortran) args + (calc-extensions) + (let ((calc-matrix-mode 'scalar)) + (math-known-matrixp + (list 'var sym + (intern + (concat "var-" + (symbol-name sym))))))) + (math-parse-fortran-subscr sym args) + (if f + (setq sym (cdr f)) + (and (= (aref (symbol-name sym) 0) ?\\) + (< (prefix-numeric-value calc-language-option) + 0) + (setq sym (intern (substring (symbol-name sym) + 1)))) + (or (string-match "-" (symbol-name sym)) + (setq sym (intern + (concat "calcFunc-" + (symbol-name sym)))))) + (cons sym args))))) + (if math-read-expr-quotes + sym + (let ((val (list 'var + (intern (math-remove-dashes + (symbol-name sym))) + (if (string-match "-" (symbol-name sym)) + sym + (intern (concat "var-" + (symbol-name sym))))))) + (let ((v (assq (nth 1 val) math-expr-variable-mapping))) + (and v (setq val (if (consp (cdr v)) + (funcall (car (cdr v)) v val) + (list 'var + (intern + (substring (symbol-name (cdr v)) + 4)) + (cdr v)))))) + (while (and (memq calc-language '(c pascal maple)) + (equal exp-data "[")) + (math-read-token) + (setq val (append (list 'calcFunc-subscr val) + (math-read-expr-list))) + (if (equal exp-data "]") + (math-read-token) + (throw 'syntax "Expected ']'"))) + val))))) + ((eq exp-token 'dollar) + (let ((abs (if (> exp-data 0) exp-data (- exp-data)))) + (if (>= (length calc-dollar-values) abs) + (let ((num exp-data)) + (math-read-token) + (setq calc-dollar-used (max calc-dollar-used num)) + (math-check-complete (nth (1- abs) calc-dollar-values))) + (throw 'syntax (if calc-dollar-values + "Too many $'s" + "$'s not allowed in this context"))))) + ((eq exp-token 'hash) + (or calc-hashes-used + (throw 'syntax "#'s not allowed in this context")) + (calc-extensions) + (if (<= exp-data (length calc-arg-values)) + (let ((num exp-data)) + (math-read-token) + (setq calc-hashes-used (max calc-hashes-used num)) + (nth (1- num) calc-arg-values)) + (throw 'syntax "Too many # arguments"))) + ((equal exp-data "(") + (let* ((exp (let ((exp-keep-spaces nil)) + (math-read-token) + (if (or (equal exp-data "\\dots") + (equal exp-data "\\ldots")) + '(neg (var inf var-inf)) + (math-read-expr-level 0))))) + (let ((exp-keep-spaces nil)) + (cond + ((equal exp-data ",") + (progn + (math-read-token) + (let ((exp2 (math-read-expr-level 0))) + (setq exp + (if (and exp2 (Math-realp exp) (Math-realp exp2)) + (math-normalize (list 'cplx exp exp2)) + (list '+ exp (list '* exp2 '(var i var-i)))))))) + ((equal exp-data ";") + (progn + (math-read-token) + (let ((exp2 (math-read-expr-level 0))) + (setq exp (if (and exp2 (Math-realp exp) + (Math-anglep exp2)) + (math-normalize (list 'polar exp exp2)) + (calc-extensions) + (list '* exp + (list 'calcFunc-exp + (list '* + (math-to-radians-2 exp2) + '(var i var-i))))))))) + ((or (equal exp-data "\\dots") + (equal exp-data "\\ldots")) + (progn + (math-read-token) + (let ((exp2 (if (or (equal exp-data ")") + (equal exp-data "]") + (eq exp-token 'end)) + '(var inf var-inf) + (math-read-expr-level 0)))) + (setq exp + (list 'intv + (if (equal exp-data ")") 0 1) + exp + exp2))))))) + (if (not (or (equal exp-data ")") + (and (equal exp-data "]") (eq (car-safe exp) 'intv)) + (eq exp-token 'end))) + (throw 'syntax "Expected `)'")) + (math-read-token) + exp)) + ((eq exp-token 'string) + (calc-extensions) + (math-read-string)) + ((equal exp-data "[") + (calc-extensions) + (math-read-brackets t "]")) + ((equal exp-data "{") + (calc-extensions) + (math-read-brackets nil "}")) + ((equal exp-data "<") + (calc-extensions) + (math-read-angle-brackets)) + (t (throw 'syntax "Expected a number")))) +) + + + diff --git a/lisp/calc/calc-alg.el b/lisp/calc/calc-alg.el new file mode 100644 index 0000000000..ab34cadbfc --- /dev/null +++ b/lisp/calc/calc-alg.el @@ -0,0 +1,1699 @@ +;; Calculator for GNU Emacs, part II [calc-alg.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-alg () nil) + + +;;; Algebra commands. + +(defun calc-alg-evaluate (arg) + (interactive "p") + (calc-slow-wrapper + (calc-with-default-simplification + (let ((math-simplify-only nil)) + (calc-modify-simplify-mode arg) + (calc-enter-result 1 "dsmp" (calc-top 1))))) +) + +(defun calc-modify-simplify-mode (arg) + (if (= (math-abs arg) 2) + (setq calc-simplify-mode 'alg) + (if (>= (math-abs arg) 3) + (setq calc-simplify-mode 'ext))) + (if (< arg 0) + (setq calc-simplify-mode (list calc-simplify-mode))) +) + +(defun calc-simplify () + (interactive) + (calc-slow-wrapper + (calc-with-default-simplification + (calc-enter-result 1 "simp" (math-simplify (calc-top-n 1))))) +) + +(defun calc-simplify-extended () + (interactive) + (calc-slow-wrapper + (calc-with-default-simplification + (calc-enter-result 1 "esmp" (math-simplify-extended (calc-top-n 1))))) +) + +(defun calc-expand-formula (arg) + (interactive "p") + (calc-slow-wrapper + (calc-with-default-simplification + (let ((math-simplify-only nil)) + (calc-modify-simplify-mode arg) + (calc-enter-result 1 "expf" + (if (> arg 0) + (let ((math-expand-formulas t)) + (calc-top-n 1)) + (let ((top (calc-top-n 1))) + (or (math-expand-formula top) + top))))))) +) + +(defun calc-factor (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "fctr" (if (calc-is-hyperbolic) + 'calcFunc-factors 'calcFunc-factor) + arg)) +) + +(defun calc-expand (n) + (interactive "P") + (calc-slow-wrapper + (calc-enter-result 1 "expa" + (append (list 'calcFunc-expand + (calc-top-n 1)) + (and n (list (prefix-numeric-value n)))))) +) + +(defun calc-collect (&optional var) + (interactive "sCollect terms involving: ") + (calc-slow-wrapper + (if (or (equal var "") (equal var "$") (null var)) + (calc-enter-result 2 "clct" (cons 'calcFunc-collect + (calc-top-list-n 2))) + (let ((var (math-read-expr var))) + (if (eq (car-safe var) 'error) + (error "Bad format in expression: %s" (nth 1 var))) + (calc-enter-result 1 "clct" (list 'calcFunc-collect + (calc-top-n 1) + var))))) +) + +(defun calc-apart (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "aprt" 'calcFunc-apart arg)) +) + +(defun calc-normalize-rat (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "nrat" 'calcFunc-nrat arg)) +) + +(defun calc-poly-gcd (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "pgcd" 'calcFunc-pgcd arg)) +) + +(defun calc-poly-div (arg) + (interactive "P") + (calc-slow-wrapper + (setq calc-poly-div-remainder nil) + (calc-binary-op "pdiv" 'calcFunc-pdiv arg) + (if (and calc-poly-div-remainder (null arg)) + (progn + (calc-clear-command-flag 'clear-message) + (calc-record calc-poly-div-remainder "prem") + (if (not (Math-zerop calc-poly-div-remainder)) + (message "(Remainder was %s)" + (math-format-flat-expr calc-poly-div-remainder 0)) + (message "(No remainder)"))))) +) + +(defun calc-poly-rem (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "prem" 'calcFunc-prem arg)) +) + +(defun calc-poly-div-rem (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-binary-op "pdvr" 'calcFunc-pdivide arg) + (calc-binary-op "pdvr" 'calcFunc-pdivrem arg))) +) + +(defun calc-substitute (&optional oldname newname) + (interactive "sSubstitute old: ") + (calc-slow-wrapper + (let (old new (num 1) expr) + (if (or (equal oldname "") (equal oldname "$") (null oldname)) + (setq new (calc-top-n 1) + old (calc-top-n 2) + expr (calc-top-n 3) + num 3) + (or newname + (progn (calc-unread-command ?\C-a) + (setq newname (read-string (concat "Substitute old: " + oldname + ", new: ") + oldname)))) + (if (or (equal newname "") (equal newname "$") (null newname)) + (setq new (calc-top-n 1) + expr (calc-top-n 2) + num 2) + (setq new (if (stringp newname) (math-read-expr newname) newname)) + (if (eq (car-safe new) 'error) + (error "Bad format in expression: %s" (nth 1 new))) + (setq expr (calc-top-n 1))) + (setq old (if (stringp oldname) (math-read-expr oldname) oldname)) + (if (eq (car-safe old) 'error) + (error "Bad format in expression: %s" (nth 1 old))) + (or (math-expr-contains expr old) + (error "No occurrences found."))) + (calc-enter-result num "sbst" (math-expr-subst expr old new)))) +) + + +(defun calc-has-rules (name) + (setq name (calc-var-value name)) + (and (consp name) + (memq (car name) '(vec calcFunc-assign calcFunc-condition)) + name) +) + +(defun math-recompile-eval-rules () + (setq math-eval-rules-cache (and (calc-has-rules 'var-EvalRules) + (math-compile-rewrites + '(var EvalRules var-EvalRules))) + math-eval-rules-cache-other (assq nil math-eval-rules-cache) + math-eval-rules-cache-tag (calc-var-value 'var-EvalRules)) +) + + +;;; Try to expand a formula according to its definition. +(defun math-expand-formula (expr) + (and (consp expr) + (symbolp (car expr)) + (or (get (car expr) 'calc-user-defn) + (get (car expr) 'math-expandable)) + (let ((res (let ((math-expand-formulas t)) + (apply (car expr) (cdr expr))))) + (and (not (eq (car-safe res) (car expr))) + res))) +) + + + + +;;; True if A comes before B in a canonical ordering of expressions. [P X X] +(defun math-beforep (a b) ; [Public] + (cond ((and (Math-realp a) (Math-realp b)) + (let ((comp (math-compare a b))) + (or (eq comp -1) + (and (eq comp 0) + (not (equal a b)) + (> (length (memq (car-safe a) + '(bigneg nil bigpos frac float))) + (length (memq (car-safe b) + '(bigneg nil bigpos frac float)))))))) + ((equal b '(neg (var inf var-inf))) nil) + ((equal a '(neg (var inf var-inf))) t) + ((equal a '(var inf var-inf)) nil) + ((equal b '(var inf var-inf)) t) + ((Math-realp a) + (if (and (eq (car-safe b) 'intv) (math-intv-constp b)) + (if (or (math-beforep a (nth 2 b)) (Math-equal a (nth 2 b))) + t + nil) + t)) + ((Math-realp b) + (if (and (eq (car-safe a) 'intv) (math-intv-constp a)) + (if (math-beforep (nth 2 a) b) + t + nil) + nil)) + ((and (eq (car a) 'intv) (eq (car b) 'intv) + (math-intv-constp a) (math-intv-constp b)) + (let ((comp (math-compare (nth 2 a) (nth 2 b)))) + (cond ((eq comp -1) t) + ((eq comp 1) nil) + ((and (memq (nth 1 a) '(2 3)) (memq (nth 1 b) '(0 1))) t) + ((and (memq (nth 1 a) '(0 1)) (memq (nth 1 b) '(2 3))) nil) + ((eq (setq comp (math-compare (nth 3 a) (nth 3 b))) -1) t) + ((eq comp 1) nil) + ((and (memq (nth 1 a) '(0 2)) (memq (nth 1 b) '(1 3))) t) + (t nil)))) + ((not (eq (not (Math-objectp a)) (not (Math-objectp b)))) + (Math-objectp a)) + ((eq (car a) 'var) + (if (eq (car b) 'var) + (string-lessp (symbol-name (nth 1 a)) (symbol-name (nth 1 b))) + (not (Math-numberp b)))) + ((eq (car b) 'var) (Math-numberp a)) + ((eq (car a) (car b)) + (while (and (setq a (cdr a) b (cdr b)) a + (equal (car a) (car b)))) + (and b + (or (null a) + (math-beforep (car a) (car b))))) + (t (string-lessp (symbol-name (car a)) (symbol-name (car b))))) +) + + +(defun math-simplify-extended (a) + (let ((math-living-dangerously t)) + (math-simplify a)) +) +(fset 'calcFunc-esimplify (symbol-function 'math-simplify-extended)) + +(defun math-simplify (top-expr) + (let ((math-simplifying t) + (top-only (consp calc-simplify-mode)) + (simp-rules (append (and (calc-has-rules 'var-AlgSimpRules) + '((var AlgSimpRules var-AlgSimpRules))) + (and math-living-dangerously + (calc-has-rules 'var-ExtSimpRules) + '((var ExtSimpRules var-ExtSimpRules))) + (and math-simplifying-units + (calc-has-rules 'var-UnitSimpRules) + '((var UnitSimpRules var-UnitSimpRules))) + (and math-integrating + (calc-has-rules 'var-IntegSimpRules) + '((var IntegSimpRules var-IntegSimpRules))))) + res) + (if top-only + (let ((r simp-rules)) + (setq res (math-simplify-step (math-normalize top-expr)) + calc-simplify-mode '(nil) + top-expr (math-normalize res)) + (while r + (setq top-expr (math-rewrite top-expr (car r) + '(neg (var inf var-inf))) + r (cdr r)))) + (calc-with-default-simplification + (while (let ((r simp-rules)) + (setq res (math-normalize top-expr)) + (while r + (setq res (math-rewrite res (car r)) + r (cdr r))) + (not (equal top-expr (setq res (math-simplify-step res))))) + (setq top-expr res))))) + top-expr +) +(fset 'calcFunc-simplify (symbol-function 'math-simplify)) + +;;; The following has a "bug" in that if any recursive simplifications +;;; occur only the first handler will be tried; this doesn't really +;;; matter, since math-simplify-step is iterated to a fixed point anyway. +(defun math-simplify-step (a) + (if (Math-primp a) + a + (let ((aa (if (or top-only + (memq (car a) '(calcFunc-quote calcFunc-condition + calcFunc-evalto))) + a + (cons (car a) (mapcar 'math-simplify-step (cdr a)))))) + (and (symbolp (car aa)) + (let ((handler (get (car aa) 'math-simplify))) + (and handler + (while (and handler + (equal (setq aa (or (funcall (car handler) aa) + aa)) + a)) + (setq handler (cdr handler)))))) + aa)) +) + + +(defun math-need-std-simps () + ;; Placeholder, to synchronize autoloading. +) + +(math-defsimplify (+ -) + (math-simplify-plus)) + +(defun math-simplify-plus () + (cond ((and (memq (car-safe (nth 1 expr)) '(+ -)) + (Math-numberp (nth 2 (nth 1 expr))) + (not (Math-numberp (nth 2 expr)))) + (let ((x (nth 2 expr)) + (op (car expr))) + (setcar (cdr (cdr expr)) (nth 2 (nth 1 expr))) + (setcar expr (car (nth 1 expr))) + (setcar (cdr (cdr (nth 1 expr))) x) + (setcar (nth 1 expr) op))) + ((and (eq (car expr) '+) + (Math-numberp (nth 1 expr)) + (not (Math-numberp (nth 2 expr)))) + (let ((x (nth 2 expr))) + (setcar (cdr (cdr expr)) (nth 1 expr)) + (setcar (cdr expr) x)))) + (let ((aa expr) + aaa temp) + (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -)) + (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 expr) + (eq (car aaa) '-) (eq (car expr) '-) t)) + (progn + (setcar (cdr (cdr expr)) temp) + (setcar expr '+) + (setcar (cdr (cdr aaa)) 0))) + (setq aa (nth 1 aa))) + (if (setq temp (math-combine-sum aaa (nth 2 expr) + nil (eq (car expr) '-) t)) + (progn + (setcar (cdr (cdr expr)) temp) + (setcar expr '+) + (setcar (cdr aa) 0))) + expr) +) + +(math-defsimplify * + (math-simplify-times)) + +(defun math-simplify-times () + (if (eq (car-safe (nth 2 expr)) '*) + (and (math-beforep (nth 1 (nth 2 expr)) (nth 1 expr)) + (or (math-known-scalarp (nth 1 expr) t) + (math-known-scalarp (nth 1 (nth 2 expr)) t)) + (let ((x (nth 1 expr))) + (setcar (cdr expr) (nth 1 (nth 2 expr))) + (setcar (cdr (nth 2 expr)) x))) + (and (math-beforep (nth 2 expr) (nth 1 expr)) + (or (math-known-scalarp (nth 1 expr) t) + (math-known-scalarp (nth 2 expr) t)) + (let ((x (nth 2 expr))) + (setcar (cdr (cdr expr)) (nth 1 expr)) + (setcar (cdr expr) x)))) + (let ((aa expr) + aaa temp + (safe t) (scalar (math-known-scalarp (nth 1 expr)))) + (if (and (Math-ratp (nth 1 expr)) + (setq temp (math-common-constant-factor (nth 2 expr)))) + (progn + (setcar (cdr (cdr expr)) + (math-cancel-common-factor (nth 2 expr) temp)) + (setcar (cdr expr) (math-mul (nth 1 expr) temp)))) + (while (and (eq (car-safe (setq aaa (nth 2 aa))) '*) + safe) + (if (setq temp (math-combine-prod (nth 1 expr) (nth 1 aaa) nil nil t)) + (progn + (setcar (cdr expr) temp) + (setcar (cdr aaa) 1))) + (setq safe (or scalar (math-known-scalarp (nth 1 aaa) t)) + aa (nth 2 aa))) + (if (and (setq temp (math-combine-prod aaa (nth 1 expr) nil nil t)) + safe) + (progn + (setcar (cdr expr) temp) + (setcar (cdr (cdr aa)) 1))) + (if (and (eq (car-safe (nth 1 expr)) 'frac) + (memq (nth 1 (nth 1 expr)) '(1 -1))) + (math-div (math-mul (nth 2 expr) (nth 1 (nth 1 expr))) + (nth 2 (nth 1 expr))) + expr)) +) + +(math-defsimplify / + (math-simplify-divide)) + +(defun math-simplify-divide () + (let ((np (cdr expr)) + (nover nil) + (nn (and (or (eq (car expr) '/) (not (Math-realp (nth 2 expr)))) + (math-common-constant-factor (nth 2 expr)))) + n op) + (if nn + (progn + (setq n (and (or (eq (car expr) '/) (not (Math-realp (nth 1 expr)))) + (math-common-constant-factor (nth 1 expr)))) + (if (and (eq (car-safe nn) 'frac) (eq (nth 1 nn) 1) (not n)) + (progn + (setcar (cdr expr) (math-mul (nth 2 nn) (nth 1 expr))) + (setcar (cdr (cdr expr)) + (math-cancel-common-factor (nth 2 expr) nn)) + (if (and (math-negp nn) + (setq op (assq (car expr) calc-tweak-eqn-table))) + (setcar expr (nth 1 op)))) + (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1))) + (progn + (setcar (cdr expr) + (math-cancel-common-factor (nth 1 expr) n)) + (setcar (cdr (cdr expr)) + (math-cancel-common-factor (nth 2 expr) n)) + (if (and (math-negp n) + (setq op (assq (car expr) calc-tweak-eqn-table))) + (setcar expr (nth 1 op)))))))) + (if (and (eq (car-safe (car np)) '/) + (math-known-scalarp (nth 2 expr) t)) + (progn + (setq np (cdr (nth 1 expr))) + (while (eq (car-safe (setq n (car np))) '*) + (and (math-known-scalarp (nth 2 n) t) + (math-simplify-divisor (cdr n) (cdr (cdr expr)) nil t)) + (setq np (cdr (cdr n)))) + (math-simplify-divisor np (cdr (cdr expr)) nil t) + (setq nover t + np (cdr (cdr (nth 1 expr)))))) + (while (eq (car-safe (setq n (car np))) '*) + (and (math-known-scalarp (nth 2 n) t) + (math-simplify-divisor (cdr n) (cdr (cdr expr)) nover t)) + (setq np (cdr (cdr n)))) + (math-simplify-divisor np (cdr (cdr expr)) nover t) + expr) +) + +(defun math-simplify-divisor (np dp nover dover) + (cond ((eq (car-safe (car dp)) '/) + (math-simplify-divisor np (cdr (car dp)) nover dover) + (and (math-known-scalarp (nth 1 (car dp)) t) + (math-simplify-divisor np (cdr (cdr (car dp))) + nover (not dover)))) + ((or (or (eq (car expr) '/) + (let ((signs (math-possible-signs (car np)))) + (or (memq signs '(1 4)) + (and (memq (car expr) '(calcFunc-eq calcFunc-neq)) + (eq signs 5)) + math-living-dangerously))) + (math-numberp (car np))) + (let ((n (car np)) + d dd temp op + (safe t) (scalar (math-known-scalarp n))) + (while (and (eq (car-safe (setq d (car dp))) '*) + safe) + (math-simplify-one-divisor np (cdr d)) + (setq safe (or scalar (math-known-scalarp (nth 1 d) t)) + dp (cdr (cdr d)))) + (if safe + (math-simplify-one-divisor np dp))))) +) + +(defun math-simplify-one-divisor (np dp) + (if (setq temp (math-combine-prod (car np) (car dp) nover dover t)) + (progn + (and (not (memq (car expr) '(/ calcFunc-eq calcFunc-neq))) + (math-known-negp (car dp)) + (setq op (assq (car expr) calc-tweak-eqn-table)) + (setcar expr (nth 1 op))) + (setcar np (if nover (math-div 1 temp) temp)) + (setcar dp 1)) + (and dover (not nover) (eq (car expr) '/) + (eq (car-safe (car dp)) 'calcFunc-sqrt) + (Math-integerp (nth 1 (car dp))) + (progn + (setcar np (math-mul (car np) + (list 'calcFunc-sqrt (nth 1 (car dp))))) + (setcar dp (nth 1 (car dp)))))) +) + +(defun math-common-constant-factor (expr) + (if (Math-realp expr) + (if (Math-ratp expr) + (and (not (memq expr '(0 1 -1))) + (math-abs expr)) + (if (math-ratp (setq expr (math-to-simple-fraction expr))) + (math-common-constant-factor expr))) + (if (memq (car expr) '(+ - cplx sdev)) + (let ((f1 (math-common-constant-factor (nth 1 expr))) + (f2 (math-common-constant-factor (nth 2 expr)))) + (and f1 f2 + (not (eq (setq f1 (math-frac-gcd f1 f2)) 1)) + f1)) + (if (memq (car expr) '(* polar)) + (math-common-constant-factor (nth 1 expr)) + (if (eq (car expr) '/) + (or (math-common-constant-factor (nth 1 expr)) + (and (Math-integerp (nth 2 expr)) + (list 'frac 1 (math-abs (nth 2 expr))))))))) +) + +(defun math-cancel-common-factor (expr val) + (if (memq (car-safe expr) '(+ - cplx sdev)) + (progn + (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val)) + (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val)) + expr) + (if (eq (car-safe expr) '*) + (math-mul (math-cancel-common-factor (nth 1 expr) val) (nth 2 expr)) + (math-div expr val))) +) + +(defun math-frac-gcd (a b) + (if (Math-zerop a) + b + (if (Math-zerop b) + a + (if (and (Math-integerp a) + (Math-integerp b)) + (math-gcd a b) + (and (Math-integerp a) (setq a (list 'frac a 1))) + (and (Math-integerp b) (setq b (list 'frac b 1))) + (math-make-frac (math-gcd (nth 1 a) (nth 1 b)) + (math-gcd (nth 2 a) (nth 2 b)))))) +) + +(math-defsimplify % + (math-simplify-mod)) + +(defun math-simplify-mod () + (and (Math-realp (nth 2 expr)) + (Math-posp (nth 2 expr)) + (let ((lin (math-is-linear (nth 1 expr))) + t1 t2 t3) + (or (and lin + (or (math-negp (car lin)) + (not (Math-lessp (car lin) (nth 2 expr)))) + (list '% + (list '+ + (math-mul (nth 1 lin) (nth 2 lin)) + (math-mod (car lin) (nth 2 expr))) + (nth 2 expr))) + (and lin + (not (math-equal-int (nth 1 lin) 1)) + (math-num-integerp (nth 1 lin)) + (math-num-integerp (nth 2 expr)) + (setq t1 (calcFunc-gcd (nth 1 lin) (nth 2 expr))) + (not (math-equal-int t1 1)) + (list '* + t1 + (list '% + (list '+ + (math-mul (math-div (nth 1 lin) t1) + (nth 2 lin)) + (let ((calc-prefer-frac t)) + (math-div (car lin) t1))) + (math-div (nth 2 expr) t1)))) + (and (math-equal-int (nth 2 expr) 1) + (math-known-integerp (if lin + (math-mul (nth 1 lin) (nth 2 lin)) + (nth 1 expr))) + (if lin (math-mod (car lin) 1) 0))))) +) + +(math-defsimplify (calcFunc-eq calcFunc-neq calcFunc-lt + calcFunc-gt calcFunc-leq calcFunc-geq) + (if (= (length expr) 3) + (math-simplify-ineq))) + +(defun math-simplify-ineq () + (let ((np (cdr expr)) + n) + (while (memq (car-safe (setq n (car np))) '(+ -)) + (math-simplify-add-term (cdr (cdr n)) (cdr (cdr expr)) + (eq (car n) '-) nil) + (setq np (cdr n))) + (math-simplify-add-term np (cdr (cdr expr)) nil (eq np (cdr expr))) + (math-simplify-divide) + (let ((signs (math-possible-signs (cons '- (cdr expr))))) + (or (cond ((eq (car expr) 'calcFunc-eq) + (or (and (eq signs 2) 1) + (and (memq signs '(1 4 5)) 0))) + ((eq (car expr) 'calcFunc-neq) + (or (and (eq signs 2) 0) + (and (memq signs '(1 4 5)) 1))) + ((eq (car expr) 'calcFunc-lt) + (or (and (eq signs 1) 1) + (and (memq signs '(2 4 6)) 0))) + ((eq (car expr) 'calcFunc-gt) + (or (and (eq signs 4) 1) + (and (memq signs '(1 2 3)) 0))) + ((eq (car expr) 'calcFunc-leq) + (or (and (eq signs 4) 0) + (and (memq signs '(1 2 3)) 1))) + ((eq (car expr) 'calcFunc-geq) + (or (and (eq signs 1) 0) + (and (memq signs '(2 4 6)) 1)))) + expr))) +) + +(defun math-simplify-add-term (np dp minus lplain) + (or (math-vectorp (car np)) + (let ((rplain t) + n d dd temp) + (while (memq (car-safe (setq n (car np) d (car dp))) '(+ -)) + (setq rplain nil) + (if (setq temp (math-combine-sum n (nth 2 d) + minus (eq (car d) '+) t)) + (if (or lplain (eq (math-looks-negp temp) minus)) + (progn + (setcar np (setq n (if minus (math-neg temp) temp))) + (setcar (cdr (cdr d)) 0)) + (progn + (setcar np 0) + (setcar (cdr (cdr d)) (setq n (if (eq (car d) '+) + (math-neg temp) + temp)))))) + (setq dp (cdr d))) + (if (setq temp (math-combine-sum n d minus t t)) + (if (or lplain + (and (not rplain) + (eq (math-looks-negp temp) minus))) + (progn + (setcar np (setq n (if minus (math-neg temp) temp))) + (setcar dp 0)) + (progn + (setcar np 0) + (setcar dp (setq n (math-neg temp)))))))) +) + +(math-defsimplify calcFunc-sin + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-sin (math-neg (nth 1 expr))))) + (and (eq calc-angle-mode 'rad) + (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi)))) + (and n + (math-known-sin (car n) (nth 1 n) 120 0)))) + (and (eq calc-angle-mode 'deg) + (let ((n (math-integer-plus (nth 1 expr)))) + (and n + (math-known-sin (car n) (nth 1 n) '(frac 2 3) 0)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos) + (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan) + (math-div (nth 1 (nth 1 expr)) + (list 'calcFunc-sqrt + (math-add 1 (math-sqr (nth 1 (nth 1 expr))))))) + (let ((m (math-should-expand-trig (nth 1 expr)))) + (and m (integerp (car m)) + (let ((n (car m)) (a (nth 1 m))) + (list '+ + (list '* (list 'calcFunc-sin (list '* (1- n) a)) + (list 'calcFunc-cos a)) + (list '* (list 'calcFunc-cos (list '* (1- n) a)) + (list 'calcFunc-sin a))))))) +) + +(math-defsimplify calcFunc-cos + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (list 'calcFunc-cos (math-neg (nth 1 expr)))) + (and (eq calc-angle-mode 'rad) + (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi)))) + (and n + (math-known-sin (car n) (nth 1 n) 120 300)))) + (and (eq calc-angle-mode 'deg) + (let ((n (math-integer-plus (nth 1 expr)))) + (and n + (math-known-sin (car n) (nth 1 n) '(frac 2 3) 300)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin) + (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan) + (math-div 1 + (list 'calcFunc-sqrt + (math-add 1 (math-sqr (nth 1 (nth 1 expr))))))) + (let ((m (math-should-expand-trig (nth 1 expr)))) + (and m (integerp (car m)) + (let ((n (car m)) (a (nth 1 m))) + (list '- + (list '* (list 'calcFunc-cos (list '* (1- n) a)) + (list 'calcFunc-cos a)) + (list '* (list 'calcFunc-sin (list '* (1- n) a)) + (list 'calcFunc-sin a))))))) +) + +(defun math-should-expand-trig (x &optional hyperbolic) + (let ((m (math-is-multiple x))) + (and math-living-dangerously + m (or (and (integerp (car m)) (> (car m) 1)) + (equal (car m) '(frac 1 2))) + (or math-integrating + (memq (car-safe (nth 1 m)) + (if hyperbolic + '(calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh) + '(calcFunc-arcsin calcFunc-arccos calcFunc-arctan))) + (and (eq (car-safe (nth 1 m)) 'calcFunc-ln) + (eq hyperbolic 'exp))) + m)) +) + +(defun math-known-sin (plus n mul off) + (setq n (math-mul n mul)) + (and (math-num-integerp n) + (setq n (math-mod (math-add (math-trunc n) off) 240)) + (if (>= n 120) + (and (setq n (math-known-sin plus (- n 120) 1 0)) + (math-neg n)) + (if (> n 60) + (setq n (- 120 n))) + (if (math-zerop plus) + (and (or calc-symbolic-mode + (memq n '(0 20 60))) + (cdr (assq n + '( (0 . 0) + (10 . (/ (calcFunc-sqrt + (- 2 (calcFunc-sqrt 3))) 2)) + (12 . (/ (- (calcFunc-sqrt 5) 1) 4)) + (15 . (/ (calcFunc-sqrt + (- 2 (calcFunc-sqrt 2))) 2)) + (20 . (/ 1 2)) + (24 . (* (^ (/ 1 2) (/ 3 2)) + (calcFunc-sqrt + (- 5 (calcFunc-sqrt 5))))) + (30 . (/ (calcFunc-sqrt 2) 2)) + (36 . (/ (+ (calcFunc-sqrt 5) 1) 4)) + (40 . (/ (calcFunc-sqrt 3) 2)) + (45 . (/ (calcFunc-sqrt + (+ 2 (calcFunc-sqrt 2))) 2)) + (48 . (* (^ (/ 1 2) (/ 3 2)) + (calcFunc-sqrt + (+ 5 (calcFunc-sqrt 5))))) + (50 . (/ (calcFunc-sqrt + (+ 2 (calcFunc-sqrt 3))) 2)) + (60 . 1))))) + (cond ((eq n 0) (math-normalize (list 'calcFunc-sin plus))) + ((eq n 60) (math-normalize (list 'calcFunc-cos plus))) + (t nil))))) +) + +(math-defsimplify calcFunc-tan + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-tan (math-neg (nth 1 expr))))) + (and (eq calc-angle-mode 'rad) + (let ((n (math-linear-in (nth 1 expr) '(var pi var-pi)))) + (and n + (math-known-tan (car n) (nth 1 n) 120)))) + (and (eq calc-angle-mode 'deg) + (let ((n (math-integer-plus (nth 1 expr)))) + (and n + (math-known-tan (car n) (nth 1 n) '(frac 2 3))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin) + (math-div (nth 1 (nth 1 expr)) + (list 'calcFunc-sqrt + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos) + (math-div (list 'calcFunc-sqrt + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))) + (nth 1 (nth 1 expr)))) + (let ((m (math-should-expand-trig (nth 1 expr)))) + (and m + (if (equal (car m) '(frac 1 2)) + (math-div (math-sub 1 (list 'calcFunc-cos (nth 1 m))) + (list 'calcFunc-sin (nth 1 m))) + (math-div (list 'calcFunc-sin (nth 1 expr)) + (list 'calcFunc-cos (nth 1 expr))))))) +) + +(defun math-known-tan (plus n mul) + (setq n (math-mul n mul)) + (and (math-num-integerp n) + (setq n (math-mod (math-trunc n) 120)) + (if (> n 60) + (and (setq n (math-known-tan plus (- 120 n) 1)) + (math-neg n)) + (if (math-zerop plus) + (and (or calc-symbolic-mode + (memq n '(0 30 60))) + (cdr (assq n '( (0 . 0) + (10 . (- 2 (calcFunc-sqrt 3))) + (12 . (calcFunc-sqrt + (- 1 (* (/ 2 5) (calcFunc-sqrt 5))))) + (15 . (- (calcFunc-sqrt 2) 1)) + (20 . (/ (calcFunc-sqrt 3) 3)) + (24 . (calcFunc-sqrt + (- 5 (* 2 (calcFunc-sqrt 5))))) + (30 . 1) + (36 . (calcFunc-sqrt + (+ 1 (* (/ 2 5) (calcFunc-sqrt 5))))) + (40 . (calcFunc-sqrt 3)) + (45 . (+ (calcFunc-sqrt 2) 1)) + (48 . (calcFunc-sqrt + (+ 5 (* 2 (calcFunc-sqrt 5))))) + (50 . (+ 2 (calcFunc-sqrt 3))) + (60 . (var uinf var-uinf)))))) + (cond ((eq n 0) (math-normalize (list 'calcFunc-tan plus))) + ((eq n 60) (math-normalize (list '/ -1 + (list 'calcFunc-tan plus)))) + (t nil))))) +) + +(math-defsimplify calcFunc-sinh + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-sinh (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh) + math-living-dangerously + (list 'calcFunc-sqrt (math-sub (math-sqr (nth 1 (nth 1 expr))) 1))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh) + math-living-dangerously + (math-div (nth 1 (nth 1 expr)) + (list 'calcFunc-sqrt + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))) + (let ((m (math-should-expand-trig (nth 1 expr) t))) + (and m (integerp (car m)) + (let ((n (car m)) (a (nth 1 m))) + (if (> n 1) + (list '+ + (list '* (list 'calcFunc-sinh (list '* (1- n) a)) + (list 'calcFunc-cosh a)) + (list '* (list 'calcFunc-cosh (list '* (1- n) a)) + (list 'calcFunc-sinh a)))))))) +) + +(math-defsimplify calcFunc-cosh + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (list 'calcFunc-cosh (math-neg (nth 1 expr)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh) + math-living-dangerously + (list 'calcFunc-sqrt (math-add (math-sqr (nth 1 (nth 1 expr))) 1))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh) + math-living-dangerously + (math-div 1 + (list 'calcFunc-sqrt + (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))) + (let ((m (math-should-expand-trig (nth 1 expr) t))) + (and m (integerp (car m)) + (let ((n (car m)) (a (nth 1 m))) + (if (> n 1) + (list '+ + (list '* (list 'calcFunc-cosh (list '* (1- n) a)) + (list 'calcFunc-cosh a)) + (list '* (list 'calcFunc-sinh (list '* (1- n) a)) + (list 'calcFunc-sinh a)))))))) +) + +(math-defsimplify calcFunc-tanh + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh) + (nth 1 (nth 1 expr))) + (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-tanh (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh) + math-living-dangerously + (math-div (nth 1 (nth 1 expr)) + (list 'calcFunc-sqrt + (math-add (math-sqr (nth 1 (nth 1 expr))) 1)))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh) + math-living-dangerously + (math-div (list 'calcFunc-sqrt + (math-sub (math-sqr (nth 1 (nth 1 expr))) 1)) + (nth 1 (nth 1 expr)))) + (let ((m (math-should-expand-trig (nth 1 expr) t))) + (and m + (if (equal (car m) '(frac 1 2)) + (math-div (math-sub (list 'calcFunc-cosh (nth 1 m)) 1) + (list 'calcFunc-sinh (nth 1 m))) + (math-div (list 'calcFunc-sinh (nth 1 expr)) + (list 'calcFunc-cosh (nth 1 expr))))))) +) + +(math-defsimplify calcFunc-arcsin + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 expr))))) + (and (eq (nth 1 expr) 1) + (math-quarter-circle t)) + (and (equal (nth 1 expr) '(frac 1 2)) + (math-div (math-half-circle t) 6)) + (and math-living-dangerously + (eq (car-safe (nth 1 expr)) 'calcFunc-sin) + (nth 1 (nth 1 expr))) + (and math-living-dangerously + (eq (car-safe (nth 1 expr)) 'calcFunc-cos) + (math-sub (math-quarter-circle t) + (nth 1 (nth 1 expr))))) +) + +(math-defsimplify calcFunc-arccos + (or (and (eq (nth 1 expr) 0) + (math-quarter-circle t)) + (and (eq (nth 1 expr) -1) + (math-half-circle t)) + (and (equal (nth 1 expr) '(frac 1 2)) + (math-div (math-half-circle t) 3)) + (and (equal (nth 1 expr) '(frac -1 2)) + (math-div (math-mul (math-half-circle t) 2) 3)) + (and math-living-dangerously + (eq (car-safe (nth 1 expr)) 'calcFunc-cos) + (nth 1 (nth 1 expr))) + (and math-living-dangerously + (eq (car-safe (nth 1 expr)) 'calcFunc-sin) + (math-sub (math-quarter-circle t) + (nth 1 (nth 1 expr))))) +) + +(math-defsimplify calcFunc-arctan + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-arctan (math-neg (nth 1 expr))))) + (and (eq (nth 1 expr) 1) + (math-div (math-half-circle t) 4)) + (and math-living-dangerously + (eq (car-safe (nth 1 expr)) 'calcFunc-tan) + (nth 1 (nth 1 expr)))) +) + +(math-defsimplify calcFunc-arcsinh + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-arcsinh (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-sinh) + (or math-living-dangerously + (math-known-realp (nth 1 (nth 1 expr)))) + (nth 1 (nth 1 expr)))) +) + +(math-defsimplify calcFunc-arccosh + (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh) + (or math-living-dangerously + (math-known-realp (nth 1 (nth 1 expr)))) + (nth 1 (nth 1 expr))) +) + +(math-defsimplify calcFunc-arctanh + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-arctanh (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-tanh) + (or math-living-dangerously + (math-known-realp (nth 1 (nth 1 expr)))) + (nth 1 (nth 1 expr)))) +) + +(math-defsimplify calcFunc-sqrt + (math-simplify-sqrt) +) + +(defun math-simplify-sqrt () + (or (and (eq (car-safe (nth 1 expr)) 'frac) + (math-div (list 'calcFunc-sqrt (math-mul (nth 1 (nth 1 expr)) + (nth 2 (nth 1 expr)))) + (nth 2 (nth 1 expr)))) + (let ((fac (if (math-objectp (nth 1 expr)) + (math-squared-factor (nth 1 expr)) + (math-common-constant-factor (nth 1 expr))))) + (and fac (not (eq fac 1)) + (math-mul (math-normalize (list 'calcFunc-sqrt fac)) + (math-normalize + (list 'calcFunc-sqrt + (math-cancel-common-factor (nth 1 expr) fac)))))) + (and math-living-dangerously + (or (and (eq (car-safe (nth 1 expr)) '-) + (math-equal-int (nth 1 (nth 1 expr)) 1) + (eq (car-safe (nth 2 (nth 1 expr))) '^) + (math-equal-int (nth 2 (nth 2 (nth 1 expr))) 2) + (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr)))) + 'calcFunc-sin) + (list 'calcFunc-cos + (nth 1 (nth 1 (nth 2 (nth 1 expr)))))) + (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr)))) + 'calcFunc-cos) + (list 'calcFunc-sin + (nth 1 (nth 1 (nth 2 (nth 1 expr)))))))) + (and (eq (car-safe (nth 1 expr)) '-) + (math-equal-int (nth 2 (nth 1 expr)) 1) + (eq (car-safe (nth 1 (nth 1 expr))) '^) + (math-equal-int (nth 2 (nth 1 (nth 1 expr))) 2) + (and (eq (car-safe (nth 1 (nth 1 (nth 1 expr)))) + 'calcFunc-cosh) + (list 'calcFunc-sinh + (nth 1 (nth 1 (nth 1 (nth 1 expr))))))) + (and (eq (car-safe (nth 1 expr)) '+) + (let ((a (nth 1 (nth 1 expr))) + (b (nth 2 (nth 1 expr)))) + (and (or (and (math-equal-int a 1) + (setq a b b (nth 1 (nth 1 expr)))) + (math-equal-int b 1)) + (eq (car-safe a) '^) + (math-equal-int (nth 2 a) 2) + (or (and (eq (car-safe (nth 1 a)) 'calcFunc-sinh) + (list 'calcFunc-cosh (nth 1 (nth 1 a)))) + (and (eq (car-safe (nth 1 a)) 'calcFunc-tan) + (list '/ 1 (list 'calcFunc-cos + (nth 1 (nth 1 a))))))))) + (and (eq (car-safe (nth 1 expr)) '^) + (list '^ + (nth 1 (nth 1 expr)) + (math-div (nth 2 (nth 1 expr)) 2))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt) + (list '^ (nth 1 (nth 1 expr)) (math-div 1 4))) + (and (memq (car-safe (nth 1 expr)) '(* /)) + (list (car (nth 1 expr)) + (list 'calcFunc-sqrt (nth 1 (nth 1 expr))) + (list 'calcFunc-sqrt (nth 2 (nth 1 expr))))) + (and (memq (car-safe (nth 1 expr)) '(+ -)) + (not (math-any-floats (nth 1 expr))) + (let ((f (calcFunc-factors (calcFunc-expand + (nth 1 expr))))) + (and (math-vectorp f) + (or (> (length f) 2) + (> (nth 2 (nth 1 f)) 1)) + (let ((out 1) (rest 1) (sums 1) fac pow) + (while (setq f (cdr f)) + (setq fac (nth 1 (car f)) + pow (nth 2 (car f))) + (if (> pow 1) + (setq out (math-mul out (math-pow + fac (/ pow 2))) + pow (% pow 2))) + (if (> pow 0) + (if (memq (car-safe fac) '(+ -)) + (setq sums (math-mul-thru sums fac)) + (setq rest (math-mul rest fac))))) + (and (not (and (eq out 1) (memq rest '(1 -1)))) + (math-mul + out + (list 'calcFunc-sqrt + (math-mul sums rest))))))))))) +) + +;;; Rather than factoring x into primes, just check for the first ten primes. +(defun math-squared-factor (x) + (if (Math-integerp x) + (let ((prsqr '(4 9 25 49 121 169 289 361 529 841)) + (fac 1) + res) + (while prsqr + (if (eq (cdr (setq res (math-idivmod x (car prsqr)))) 0) + (setq x (car res) + fac (math-mul fac (car prsqr))) + (setq prsqr (cdr prsqr)))) + fac)) +) + +(math-defsimplify calcFunc-exp + (math-simplify-exp (nth 1 expr)) +) + +(defun math-simplify-exp (x) + (or (and (eq (car-safe x) 'calcFunc-ln) + (nth 1 x)) + (and math-living-dangerously + (or (and (eq (car-safe x) 'calcFunc-arcsinh) + (math-add (nth 1 x) + (list 'calcFunc-sqrt + (math-add (math-sqr (nth 1 x)) 1)))) + (and (eq (car-safe x) 'calcFunc-arccosh) + (math-add (nth 1 x) + (list 'calcFunc-sqrt + (math-sub (math-sqr (nth 1 x)) 1)))) + (and (eq (car-safe x) 'calcFunc-arctanh) + (math-div (list 'calcFunc-sqrt (math-add 1 (nth 1 x))) + (list 'calcFunc-sqrt (math-sub 1 (nth 1 x))))) + (let ((m (math-should-expand-trig x 'exp))) + (and m (integerp (car m)) + (list '^ (list 'calcFunc-exp (nth 1 m)) (car m)))))) + (and calc-symbolic-mode + (math-known-imagp x) + (let* ((ip (calcFunc-im x)) + (n (math-linear-in ip '(var pi var-pi))) + s c) + (and n + (setq s (math-known-sin (car n) (nth 1 n) 120 0)) + (setq c (math-known-sin (car n) (nth 1 n) 120 300)) + (list '+ c (list '* s '(var i var-i))))))) +) + +(math-defsimplify calcFunc-ln + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp) + (or math-living-dangerously + (math-known-realp (nth 1 (nth 1 expr)))) + (nth 1 (nth 1 expr))) + (and (eq (car-safe (nth 1 expr)) '^) + (equal (nth 1 (nth 1 expr)) '(var e var-e)) + (or math-living-dangerously + (math-known-realp (nth 2 (nth 1 expr)))) + (nth 2 (nth 1 expr))) + (and calc-symbolic-mode + (math-known-negp (nth 1 expr)) + (math-add (list 'calcFunc-ln (math-neg (nth 1 expr))) + '(var pi var-pi))) + (and calc-symbolic-mode + (math-known-imagp (nth 1 expr)) + (let* ((ip (calcFunc-im (nth 1 expr))) + (ips (math-possible-signs ip))) + (or (and (memq ips '(4 6)) + (math-add (list 'calcFunc-ln ip) + '(/ (* (var pi var-pi) (var i var-i)) 2))) + (and (memq ips '(1 3)) + (math-sub (list 'calcFunc-ln (math-neg ip)) + '(/ (* (var pi var-pi) (var i var-i)) 2))))))) +) + +(math-defsimplify ^ + (math-simplify-pow)) + +(defun math-simplify-pow () + (or (and math-living-dangerously + (or (and (eq (car-safe (nth 1 expr)) '^) + (list '^ + (nth 1 (nth 1 expr)) + (math-mul (nth 2 expr) (nth 2 (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt) + (list '^ + (nth 1 (nth 1 expr)) + (math-div (nth 2 expr) 2))) + (and (memq (car-safe (nth 1 expr)) '(* /)) + (list (car (nth 1 expr)) + (list '^ (nth 1 (nth 1 expr)) (nth 2 expr)) + (list '^ (nth 2 (nth 1 expr)) (nth 2 expr)))))) + (and (math-equal-int (nth 1 expr) 10) + (eq (car-safe (nth 2 expr)) 'calcFunc-log10) + (nth 1 (nth 2 expr))) + (and (equal (nth 1 expr) '(var e var-e)) + (math-simplify-exp (nth 2 expr))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-exp) + (not math-integrating) + (list 'calcFunc-exp (math-mul (nth 1 (nth 1 expr)) (nth 2 expr)))) + (and (equal (nth 1 expr) '(var i var-i)) + (math-imaginary-i) + (math-num-integerp (nth 2 expr)) + (let ((x (math-mod (math-trunc (nth 2 expr)) 4))) + (cond ((eq x 0) 1) + ((eq x 1) (nth 1 expr)) + ((eq x 2) -1) + ((eq x 3) (math-neg (nth 1 expr)))))) + (and math-integrating + (integerp (nth 2 expr)) + (>= (nth 2 expr) 2) + (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-cos) + (math-mul (math-pow (nth 1 expr) (- (nth 2 expr) 2)) + (math-sub 1 + (math-sqr + (list 'calcFunc-sin + (nth 1 (nth 1 expr))))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-cosh) + (math-mul (math-pow (nth 1 expr) (- (nth 2 expr) 2)) + (math-add 1 + (math-sqr + (list 'calcFunc-sinh + (nth 1 (nth 1 expr))))))))) + (and (eq (car-safe (nth 2 expr)) 'frac) + (Math-ratp (nth 1 expr)) + (Math-posp (nth 1 expr)) + (if (equal (nth 2 expr) '(frac 1 2)) + (list 'calcFunc-sqrt (nth 1 expr)) + (let ((flr (math-floor (nth 2 expr)))) + (and (not (Math-zerop flr)) + (list '* (list '^ (nth 1 expr) flr) + (list '^ (nth 1 expr) + (math-sub (nth 2 expr) flr))))))) + (and (eq (math-quarter-integer (nth 2 expr)) 2) + (let ((temp (math-simplify-sqrt))) + (and temp + (list '^ temp (math-mul (nth 2 expr) 2)))))) +) + +(math-defsimplify calcFunc-log10 + (and (eq (car-safe (nth 1 expr)) '^) + (math-equal-int (nth 1 (nth 1 expr)) 10) + (or math-living-dangerously + (math-known-realp (nth 2 (nth 1 expr)))) + (nth 2 (nth 1 expr))) +) + + +(math-defsimplify calcFunc-erf + (or (and (math-looks-negp (nth 1 expr)) + (math-neg (list 'calcFunc-erf (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-conj) + (list 'calcFunc-conj (list 'calcFunc-erf (nth 1 (nth 1 expr)))))) +) + +(math-defsimplify calcFunc-erfc + (or (and (math-looks-negp (nth 1 expr)) + (math-sub 2 (list 'calcFunc-erfc (math-neg (nth 1 expr))))) + (and (eq (car-safe (nth 1 expr)) 'calcFunc-conj) + (list 'calcFunc-conj (list 'calcFunc-erfc (nth 1 (nth 1 expr)))))) +) + + +(defun math-linear-in (expr term &optional always) + (if (math-expr-contains expr term) + (let* ((calc-prefer-frac t) + (p (math-is-polynomial expr term 1))) + (and (cdr p) + p)) + (and always (list expr 0))) +) + +(defun math-multiple-of (expr term) + (let ((p (math-linear-in expr term))) + (and p + (math-zerop (car p)) + (nth 1 p))) +) + +(defun math-integer-plus (expr) + (cond ((Math-integerp expr) + (list 0 expr)) + ((and (memq (car expr) '(+ -)) + (Math-integerp (nth 1 expr))) + (list (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr))) + (nth 1 expr))) + ((and (memq (car expr) '(+ -)) + (Math-integerp (nth 2 expr))) + (list (nth 1 expr) + (if (eq (car expr) '+) (nth 2 expr) (math-neg (nth 2 expr))))) + (t nil)) ; not perfect, but it'll do +) + +(defun math-is-linear (expr &optional always) + (let ((offset nil) + (coef nil)) + (if (eq (car-safe expr) '+) + (if (Math-objectp (nth 1 expr)) + (setq offset (nth 1 expr) + expr (nth 2 expr)) + (if (Math-objectp (nth 2 expr)) + (setq offset (nth 2 expr) + expr (nth 1 expr)))) + (if (eq (car-safe expr) '-) + (if (Math-objectp (nth 1 expr)) + (setq offset (nth 1 expr) + expr (math-neg (nth 2 expr))) + (if (Math-objectp (nth 2 expr)) + (setq offset (math-neg (nth 2 expr)) + expr (nth 1 expr)))))) + (setq coef (math-is-multiple expr always)) + (if offset + (list offset (or (car coef) 1) (or (nth 1 coef) expr)) + (if coef + (cons 0 coef)))) +) + +(defun math-is-multiple (expr &optional always) + (or (if (eq (car-safe expr) '*) + (if (Math-objectp (nth 1 expr)) + (list (nth 1 expr) (nth 2 expr))) + (if (eq (car-safe expr) '/) + (if (and (Math-objectp (nth 1 expr)) + (not (math-equal-int (nth 1 expr) 1))) + (list (nth 1 expr) (math-div 1 (nth 2 expr))) + (if (Math-objectp (nth 2 expr)) + (list (math-div 1 (nth 2 expr)) (nth 1 expr)) + (let ((res (math-is-multiple (nth 1 expr)))) + (if res + (list (car res) + (math-div (nth 2 (nth 1 expr)) (nth 2 expr))) + (setq res (math-is-multiple (nth 2 expr))) + (if res + (list (math-div 1 (car res)) + (math-div (nth 1 expr) + (nth 2 (nth 2 expr))))))))) + (if (eq (car-safe expr) 'neg) + (list -1 (nth 1 expr))))) + (if (Math-objvecp expr) + (and (eq always 1) + (list expr 1)) + (and always + (list 1 expr)))) +) + +(defun calcFunc-lin (expr &optional var) + (if var + (let ((res (math-linear-in expr var t))) + (or res (math-reject-arg expr "Linear term expected")) + (list 'vec (car res) (nth 1 res) var)) + (let ((res (math-is-linear expr t))) + (or res (math-reject-arg expr "Linear term expected")) + (cons 'vec res))) +) + +(defun calcFunc-linnt (expr &optional var) + (if var + (let ((res (math-linear-in expr var))) + (or res (math-reject-arg expr "Linear term expected")) + (list 'vec (car res) (nth 1 res) var)) + (let ((res (math-is-linear expr))) + (or res (math-reject-arg expr "Linear term expected")) + (cons 'vec res))) +) + +(defun calcFunc-islin (expr &optional var) + (if (and (Math-objvecp expr) (not var)) + 0 + (calcFunc-lin expr var) + 1) +) + +(defun calcFunc-islinnt (expr &optional var) + (if (Math-objvecp expr) + 0 + (calcFunc-linnt expr var) + 1) +) + + + + +;;; Simple operations on expressions. + +;;; Return number of ocurrences of thing in expr, or nil if none. +(defun math-expr-contains-count (expr thing) + (cond ((equal expr thing) 1) + ((Math-primp expr) nil) + (t + (let ((num 0)) + (while (setq expr (cdr expr)) + (setq num (+ num (or (math-expr-contains-count + (car expr) thing) 0)))) + (and (> num 0) + num)))) +) + +(defun math-expr-contains (expr thing) + (cond ((equal expr thing) 1) + ((Math-primp expr) nil) + (t + (while (and (setq expr (cdr expr)) + (not (math-expr-contains (car expr) thing)))) + expr)) +) + +;;; Return non-nil if any variable of thing occurs in expr. +(defun math-expr-depends (expr thing) + (if (Math-primp thing) + (and (eq (car-safe thing) 'var) + (math-expr-contains expr thing)) + (while (and (setq thing (cdr thing)) + (not (math-expr-depends expr (car thing))))) + thing) +) + +;;; Substitute all occurrences of old for new in expr (non-destructive). +(defun math-expr-subst (expr old new) + (math-expr-subst-rec expr) +) +(fset 'calcFunc-subst (symbol-function 'math-expr-subst)) + +(defun math-expr-subst-rec (expr) + (cond ((equal expr old) new) + ((Math-primp expr) expr) + ((memq (car expr) '(calcFunc-deriv + calcFunc-tderiv)) + (if (= (length expr) 2) + (if (equal (nth 1 expr) old) + (append expr (list new)) + expr) + (list (car expr) (nth 1 expr) + (math-expr-subst-rec (nth 2 expr))))) + (t + (cons (car expr) + (mapcar 'math-expr-subst-rec (cdr expr))))) +) + +;;; Various measures of the size of an expression. +(defun math-expr-weight (expr) + (if (Math-primp expr) + 1 + (let ((w 1)) + (while (setq expr (cdr expr)) + (setq w (+ w (math-expr-weight (car expr))))) + w)) +) + +(defun math-expr-height (expr) + (if (Math-primp expr) + 0 + (let ((h 0)) + (while (setq expr (cdr expr)) + (setq h (max h (math-expr-height (car expr))))) + (1+ h))) +) + + + + +;;; Polynomial operations (to support the integrator and solve-for). + +(defun calcFunc-collect (expr base) + (let ((p (math-is-polynomial expr base 50 t))) + (if (cdr p) + (math-normalize ; fix selection bug + (math-build-polynomial-expr p base)) + expr)) +) + +;;; If expr is of the form "a + bx + cx^2 + ...", return the list (a b c ...), +;;; else return nil if not in polynomial form. If "loose", coefficients +;;; may contain x, e.g., sin(x) + cos(x) x^2 is a loose polynomial in x. +(defun math-is-polynomial (expr var &optional degree loose) + (let* ((math-poly-base-variable (if loose + (if (eq loose 'gen) var '(var XXX XXX)) + math-poly-base-variable)) + (poly (math-is-poly-rec expr math-poly-neg-powers))) + (and (or (null degree) + (<= (length poly) (1+ degree))) + poly)) +) + +(defun math-is-poly-rec (expr negpow) + (math-poly-simplify + (or (cond ((or (equal expr var) + (eq (car-safe expr) '^)) + (let ((pow 1) + (expr expr)) + (or (equal expr var) + (setq pow (nth 2 expr) + expr (nth 1 expr))) + (or (eq math-poly-mult-powers 1) + (setq pow (let ((m (math-is-multiple pow 1))) + (and (eq (car-safe (car m)) 'cplx) + (Math-zerop (nth 1 (car m))) + (setq m (list (nth 2 (car m)) + (math-mul (nth 1 m) + '(var i var-i))))) + (and (if math-poly-mult-powers + (equal math-poly-mult-powers + (nth 1 m)) + (setq math-poly-mult-powers (nth 1 m))) + (or (equal expr var) + (eq math-poly-mult-powers 1)) + (car m))))) + (if (consp pow) + (progn + (setq pow (math-to-simple-fraction pow)) + (and (eq (car-safe pow) 'frac) + math-poly-frac-powers + (equal expr var) + (setq math-poly-frac-powers + (calcFunc-lcm math-poly-frac-powers + (nth 2 pow)))))) + (or (memq math-poly-frac-powers '(1 nil)) + (setq pow (math-mul pow math-poly-frac-powers))) + (if (integerp pow) + (if (and (= pow 1) + (equal expr var)) + (list 0 1) + (if (natnump pow) + (let ((p1 (if (equal expr var) + (list 0 1) + (math-is-poly-rec expr nil))) + (n pow) + (accum (list 1))) + (and p1 + (or (null degree) + (<= (* (1- (length p1)) n) degree)) + (progn + (while (>= n 1) + (setq accum (math-poly-mul accum p1) + n (1- n))) + accum))) + (and negpow + (math-is-poly-rec expr nil) + (setq math-poly-neg-powers + (cons (math-pow expr (- pow)) + math-poly-neg-powers)) + (list (list '^ expr pow)))))))) + ((Math-objectp expr) + (list expr)) + ((memq (car expr) '(+ -)) + (let ((p1 (math-is-poly-rec (nth 1 expr) negpow))) + (and p1 + (let ((p2 (math-is-poly-rec (nth 2 expr) negpow))) + (and p2 + (math-poly-mix p1 1 p2 + (if (eq (car expr) '+) 1 -1))))))) + ((eq (car expr) 'neg) + (mapcar 'math-neg (math-is-poly-rec (nth 1 expr) negpow))) + ((eq (car expr) '*) + (let ((p1 (math-is-poly-rec (nth 1 expr) negpow))) + (and p1 + (let ((p2 (math-is-poly-rec (nth 2 expr) negpow))) + (and p2 + (or (null degree) + (<= (- (+ (length p1) (length p2)) 2) degree)) + (math-poly-mul p1 p2)))))) + ((eq (car expr) '/) + (and (or (not (math-poly-depends (nth 2 expr) var)) + (and negpow + (math-is-poly-rec (nth 2 expr) nil) + (setq math-poly-neg-powers + (cons (nth 2 expr) math-poly-neg-powers)))) + (not (Math-zerop (nth 2 expr))) + (let ((p1 (math-is-poly-rec (nth 1 expr) negpow))) + (mapcar (function (lambda (x) (math-div x (nth 2 expr)))) + p1)))) + ((and (eq (car expr) 'calcFunc-exp) + (equal var '(var e var-e))) + (math-is-poly-rec (list '^ var (nth 1 expr)) negpow)) + ((and (eq (car expr) 'calcFunc-sqrt) + math-poly-frac-powers) + (math-is-poly-rec (list '^ (nth 1 expr) '(frac 1 2)) negpow)) + (t nil)) + (and (or (not (math-poly-depends expr var)) + loose) + (not (eq (car expr) 'vec)) + (list expr)))) +) + +;;; Check if expr is a polynomial in var; if so, return its degree. +(defun math-polynomial-p (expr var) + (cond ((equal expr var) 1) + ((Math-primp expr) 0) + ((memq (car expr) '(+ -)) + (let ((p1 (math-polynomial-p (nth 1 expr) var)) + p2) + (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var)) + (max p1 p2)))) + ((eq (car expr) '*) + (let ((p1 (math-polynomial-p (nth 1 expr) var)) + p2) + (and p1 (setq p2 (math-polynomial-p (nth 2 expr) var)) + (+ p1 p2)))) + ((eq (car expr) 'neg) + (math-polynomial-p (nth 1 expr) var)) + ((and (eq (car expr) '/) + (not (math-poly-depends (nth 2 expr) var))) + (math-polynomial-p (nth 1 expr) var)) + ((and (eq (car expr) '^) + (natnump (nth 2 expr))) + (let ((p1 (math-polynomial-p (nth 1 expr) var))) + (and p1 (* p1 (nth 2 expr))))) + ((math-poly-depends expr var) nil) + (t 0)) +) + +(defun math-poly-depends (expr var) + (if math-poly-base-variable + (math-expr-contains expr math-poly-base-variable) + (math-expr-depends expr var)) +) + +;;; Find the variable (or sub-expression) which is the base of polynomial expr. +(defun math-polynomial-base (mpb-top-expr &optional mpb-pred) + (or mpb-pred + (setq mpb-pred (function (lambda (base) (math-polynomial-p + mpb-top-expr base))))) + (or (let ((const-ok nil)) + (math-polynomial-base-rec mpb-top-expr)) + (let ((const-ok t)) + (math-polynomial-base-rec mpb-top-expr))) +) + +(defun math-polynomial-base-rec (mpb-expr) + (and (not (Math-objvecp mpb-expr)) + (or (and (memq (car mpb-expr) '(+ - *)) + (or (math-polynomial-base-rec (nth 1 mpb-expr)) + (math-polynomial-base-rec (nth 2 mpb-expr)))) + (and (memq (car mpb-expr) '(/ neg)) + (math-polynomial-base-rec (nth 1 mpb-expr))) + (and (eq (car mpb-expr) '^) + (math-polynomial-base-rec (nth 1 mpb-expr))) + (and (eq (car mpb-expr) 'calcFunc-exp) + (math-polynomial-base-rec '(var e var-e))) + (and (or const-ok (math-expr-contains-vars mpb-expr)) + (funcall mpb-pred mpb-expr) + mpb-expr))) +) + +;;; Return non-nil if expr refers to any variables. +(defun math-expr-contains-vars (expr) + (or (eq (car-safe expr) 'var) + (and (not (Math-primp expr)) + (progn + (while (and (setq expr (cdr expr)) + (not (math-expr-contains-vars (car expr))))) + expr))) +) + +;;; Simplify a polynomial in list form by stripping off high-end zeros. +;;; This always leaves the constant part, i.e., nil->nil and nonnil->nonnil. +(defun math-poly-simplify (p) + (and p + (if (Math-zerop (nth (1- (length p)) p)) + (let ((pp (copy-sequence p))) + (while (and (cdr pp) + (Math-zerop (nth (1- (length pp)) pp))) + (setcdr (nthcdr (- (length pp) 2) pp) nil)) + pp) + p)) +) + +;;; Compute ac*a + bc*b for polynomials in list form a, b and +;;; coefficients ac, bc. Result may be unsimplified. +(defun math-poly-mix (a ac b bc) + (and (or a b) + (cons (math-add (math-mul (or (car a) 0) ac) + (math-mul (or (car b) 0) bc)) + (math-poly-mix (cdr a) ac (cdr b) bc))) +) + +(defun math-poly-zerop (a) + (or (null a) + (and (null (cdr a)) (Math-zerop (car a)))) +) + +;;; Multiply two polynomials in list form. +(defun math-poly-mul (a b) + (and a b + (math-poly-mix b (car a) + (math-poly-mul (cdr a) (cons 0 b)) 1)) +) + +;;; Build an expression from a polynomial list. +(defun math-build-polynomial-expr (p var) + (if p + (if (Math-numberp var) + (math-with-extra-prec 1 + (let* ((rp (reverse p)) + (accum (car rp))) + (while (setq rp (cdr rp)) + (setq accum (math-add (car rp) (math-mul accum var)))) + accum)) + (let* ((rp (reverse p)) + (n (1- (length rp))) + (accum (math-mul (car rp) (math-pow var n))) + term) + (while (setq rp (cdr rp)) + (setq n (1- n)) + (or (math-zerop (car rp)) + (setq accum (list (if (math-looks-negp (car rp)) '- '+) + accum + (math-mul (if (math-looks-negp (car rp)) + (math-neg (car rp)) + (car rp)) + (math-pow var n)))))) + accum)) + 0) +) + + +(defun math-to-simple-fraction (f) + (or (and (eq (car-safe f) 'float) + (or (and (>= (nth 2 f) 0) + (math-scale-int (nth 1 f) (nth 2 f))) + (and (integerp (nth 1 f)) + (> (nth 1 f) -1000) + (< (nth 1 f) 1000) + (math-make-frac (nth 1 f) + (math-scale-int 1 (- (nth 2 f))))))) + f) +) + diff --git a/lisp/calc/calc-arith.el b/lisp/calc/calc-arith.el new file mode 100644 index 0000000000..6673238187 --- /dev/null +++ b/lisp/calc/calc-arith.el @@ -0,0 +1,2924 @@ +;; Calculator for GNU Emacs, part II [calc-arith.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-arith () nil) + + +;;; Arithmetic. + +(defun calc-min (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "min" 'calcFunc-min arg '(var inf var-inf))) +) + +(defun calc-max (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "max" 'calcFunc-max arg '(neg (var inf var-inf)))) +) + +(defun calc-abs (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "abs" 'calcFunc-abs arg)) +) + + +(defun calc-idiv (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "\\" 'calcFunc-idiv arg 1)) +) + + +(defun calc-floor (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (if (calc-is-hyperbolic) + (calc-unary-op "ceil" 'calcFunc-fceil arg) + (calc-unary-op "ceil" 'calcFunc-ceil arg)) + (if (calc-is-hyperbolic) + (calc-unary-op "flor" 'calcFunc-ffloor arg) + (calc-unary-op "flor" 'calcFunc-floor arg)))) +) + +(defun calc-ceiling (arg) + (interactive "P") + (calc-invert-func) + (calc-floor arg) +) + +(defun calc-round (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (if (calc-is-hyperbolic) + (calc-unary-op "trnc" 'calcFunc-ftrunc arg) + (calc-unary-op "trnc" 'calcFunc-trunc arg)) + (if (calc-is-hyperbolic) + (calc-unary-op "rond" 'calcFunc-fround arg) + (calc-unary-op "rond" 'calcFunc-round arg)))) +) + +(defun calc-trunc (arg) + (interactive "P") + (calc-invert-func) + (calc-round arg) +) + +(defun calc-mant-part (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "mant" 'calcFunc-mant arg)) +) + +(defun calc-xpon-part (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "xpon" 'calcFunc-xpon arg)) +) + +(defun calc-scale-float (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "scal" 'calcFunc-scf arg)) +) + +(defun calc-abssqr (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "absq" 'calcFunc-abssqr arg)) +) + +(defun calc-sign (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "sign" 'calcFunc-sign arg)) +) + +(defun calc-increment (arg) + (interactive "p") + (calc-wrapper + (calc-enter-result 1 "incr" (list 'calcFunc-incr (calc-top-n 1) arg))) +) + +(defun calc-decrement (arg) + (interactive "p") + (calc-wrapper + (calc-enter-result 1 "decr" (list 'calcFunc-decr (calc-top-n 1) arg))) +) + + +(defun math-abs-approx (a) + (cond ((Math-negp a) + (math-neg a)) + ((Math-anglep a) + a) + ((eq (car a) 'cplx) + (math-add (math-abs (nth 1 a)) (math-abs (nth 2 a)))) + ((eq (car a) 'polar) + (nth 1 a)) + ((eq (car a) 'sdev) + (math-abs-approx (nth 1 a))) + ((eq (car a) 'intv) + (math-max (math-abs (nth 2 a)) (math-abs (nth 3 a)))) + ((eq (car a) 'date) + a) + ((eq (car a) 'vec) + (math-reduce-vec 'math-add-abs-approx a)) + ((eq (car a) 'calcFunc-abs) + (car a)) + (t a)) +) + +(defun math-add-abs-approx (a b) + (math-add (math-abs-approx a) (math-abs-approx b)) +) + + +;;;; Declarations. + +(setq math-decls-cache-tag nil) +(setq math-decls-cache nil) +(setq math-decls-all nil) + +;;; Math-decls-cache is an a-list where each entry is a list of the form: +;;; (VAR TYPES RANGE) +;;; where VAR is a variable name (with var- prefix) or function name; +;;; TYPES is a list of type symbols (any, int, frac, ...) +;;; RANGE is a sorted vector of intervals describing the range. + +(defun math-setup-declarations () + (or (eq math-decls-cache-tag (calc-var-value 'var-Decls)) + (let ((p (calc-var-value 'var-Decls)) + vec type range) + (setq math-decls-cache-tag p + math-decls-cache nil) + (and (eq (car-safe p) 'vec) + (while (setq p (cdr p)) + (and (eq (car-safe (car p)) 'vec) + (setq vec (nth 2 (car p))) + (condition-case err + (let ((v (nth 1 (car p)))) + (setq type nil range nil) + (or (eq (car-safe vec) 'vec) + (setq vec (list 'vec vec))) + (while (and (setq vec (cdr vec)) + (not (Math-objectp (car vec)))) + (and (eq (car-safe (car vec)) 'var) + (let ((st (assq (nth 1 (car vec)) + math-super-types))) + (cond (st (setq type (append type st))) + ((eq (nth 1 (car vec)) 'pos) + (setq type (append type + '(real number)) + range + '(intv 1 0 (var inf var-inf)))) + ((eq (nth 1 (car vec)) 'nonneg) + (setq type (append type + '(real number)) + range + '(intv 3 0 + (var inf var-inf)))))))) + (if vec + (setq type (append type '(real number)) + range (math-prepare-set (cons 'vec vec)))) + (setq type (list type range)) + (or (eq (car-safe v) 'vec) + (setq v (list 'vec v))) + (while (setq v (cdr v)) + (if (or (eq (car-safe (car v)) 'var) + (not (Math-primp (car v)))) + (setq math-decls-cache + (cons (cons (if (eq (car (car v)) 'var) + (nth 2 (car v)) + (car (car v))) + type) + math-decls-cache))))) + (error nil))))) + (setq math-decls-all (assq 'var-All math-decls-cache)))) +) + +(defvar math-super-types + '( ( int numint rat real number ) + ( numint real number ) + ( frac rat real number ) + ( rat real number ) + ( float real number ) + ( real number ) + ( number ) + ( scalar ) + ( matrix vector ) + ( vector ) + ( const ) +)) + + +(defun math-known-scalarp (a &optional assume-scalar) + (math-setup-declarations) + (if (if calc-matrix-mode + (eq calc-matrix-mode 'scalar) + assume-scalar) + (not (math-check-known-matrixp a)) + (math-check-known-scalarp a)) +) + +(defun math-known-matrixp (a) + (and (not (Math-scalarp a)) + (not (math-known-scalarp a t))) +) + +;;; Try to prove that A is a scalar (i.e., a non-vector). +(defun math-check-known-scalarp (a) + (cond ((Math-objectp a) t) + ((memq (car a) math-scalar-functions) + t) + ((memq (car a) math-real-scalar-functions) + t) + ((memq (car a) math-scalar-if-args-functions) + (while (and (setq a (cdr a)) + (math-check-known-scalarp (car a)))) + (null a)) + ((eq (car a) '^) + (math-check-known-scalarp (nth 1 a))) + ((math-const-var a) t) + (t + (let ((decl (if (eq (car a) 'var) + (or (assq (nth 2 a) math-decls-cache) + math-decls-all) + (assq (car a) math-decls-cache)))) + (memq 'scalar (nth 1 decl))))) +) + +;;; Try to prove that A is *not* a scalar. +(defun math-check-known-matrixp (a) + (cond ((Math-objectp a) nil) + ((memq (car a) math-nonscalar-functions) + t) + ((memq (car a) math-scalar-if-args-functions) + (while (and (setq a (cdr a)) + (not (math-check-known-matrixp (car a))))) + a) + ((eq (car a) '^) + (math-check-known-matrixp (nth 1 a))) + ((math-const-var a) nil) + (t + (let ((decl (if (eq (car a) 'var) + (or (assq (nth 2 a) math-decls-cache) + math-decls-all) + (assq (car a) math-decls-cache)))) + (memq 'vector (nth 1 decl))))) +) + + +;;; Try to prove that A is a real (i.e., not complex). +(defun math-known-realp (a) + (< (math-possible-signs a) 8) +) + +;;; Try to prove that A is real and positive. +(defun math-known-posp (a) + (eq (math-possible-signs a) 4) +) + +;;; Try to prove that A is real and negative. +(defun math-known-negp (a) + (eq (math-possible-signs a) 1) +) + +;;; Try to prove that A is real and nonnegative. +(defun math-known-nonnegp (a) + (memq (math-possible-signs a) '(2 4 6)) +) + +;;; Try to prove that A is real and nonpositive. +(defun math-known-nonposp (a) + (memq (math-possible-signs a) '(1 2 3)) +) + +;;; Try to prove that A is nonzero. +(defun math-known-nonzerop (a) + (memq (math-possible-signs a) '(1 4 5 8 9 12 13)) +) + +;;; Return true if A is negative, or looks negative but we don't know. +(defun math-guess-if-neg (a) + (let ((sgn (math-possible-signs a))) + (if (memq sgn '(1 3)) + t + (if (memq sgn '(2 4 6)) + nil + (math-looks-negp a)))) +) + +;;; Find the possible signs of A, assuming A is a number of some kind. +;;; Returns an integer with bits: 1 may be negative, +;;; 2 may be zero, +;;; 4 may be positive, +;;; 8 may be nonreal. + +(defun math-possible-signs (a &optional origin) + (cond ((Math-objectp a) + (if origin (setq a (math-sub a origin))) + (cond ((Math-posp a) 4) + ((Math-negp a) 1) + ((Math-zerop a) 2) + ((eq (car a) 'intv) + (cond ((Math-zerop (nth 2 a)) 6) + ((Math-zerop (nth 3 a)) 3) + (t 7))) + ((eq (car a) 'sdev) + (if (math-known-realp (nth 1 a)) 7 15)) + (t 8))) + ((memq (car a) '(+ -)) + (cond ((Math-realp (nth 1 a)) + (if (eq (car a) '-) + (math-neg-signs + (math-possible-signs (nth 2 a) + (if origin + (math-add origin (nth 1 a)) + (nth 1 a)))) + (math-possible-signs (nth 2 a) + (if origin + (math-sub origin (nth 1 a)) + (math-neg (nth 1 a)))))) + ((Math-realp (nth 2 a)) + (let ((org (if (eq (car a) '-) + (nth 2 a) + (math-neg (nth 2 a))))) + (math-possible-signs (nth 1 a) + (if origin + (math-add origin org) + org)))) + (t + (let ((s1 (math-possible-signs (nth 1 a) origin)) + (s2 (math-possible-signs (nth 2 a)))) + (if (eq (car a) '-) (setq s2 (math-neg-signs s2))) + (cond ((eq s1 s2) s1) + ((eq s1 2) s2) + ((eq s2 2) s1) + ((>= s1 8) 15) + ((>= s2 8) 15) + ((and (eq s1 4) (eq s2 6)) 4) + ((and (eq s2 4) (eq s1 6)) 4) + ((and (eq s1 1) (eq s2 3)) 1) + ((and (eq s2 1) (eq s1 3)) 1) + (t 7)))))) + ((eq (car a) 'neg) + (math-neg-signs (math-possible-signs + (nth 1 a) + (and origin (math-neg origin))))) + ((and origin (Math-zerop origin) (setq origin nil) + nil)) + ((and (or (eq (car a) '*) + (and (eq (car a) '/) origin)) + (Math-realp (nth 1 a))) + (let ((s (if (eq (car a) '*) + (if (Math-zerop (nth 1 a)) + (math-possible-signs 0 origin) + (math-possible-signs (nth 2 a) + (math-div (or origin 0) + (nth 1 a)))) + (math-neg-signs + (math-possible-signs (nth 2 a) + (math-div (nth 1 a) + origin)))))) + (if (Math-negp (nth 1 a)) (math-neg-signs s) s))) + ((and (memq (car a) '(* /)) (Math-realp (nth 2 a))) + (let ((s (math-possible-signs (nth 1 a) + (if (eq (car a) '*) + (math-mul (or origin 0) (nth 2 a)) + (math-div (or origin 0) (nth 2 a)))))) + (if (Math-negp (nth 2 a)) (math-neg-signs s) s))) + ((eq (car a) 'vec) + (let ((signs 0)) + (while (and (setq a (cdr a)) (< signs 15)) + (setq signs (logior signs (math-possible-signs + (car a) origin)))) + signs)) + (t (let ((sign + (cond + ((memq (car a) '(* /)) + (let ((s1 (math-possible-signs (nth 1 a))) + (s2 (math-possible-signs (nth 2 a)))) + (cond ((>= s1 8) 15) + ((>= s2 8) 15) + ((and (eq (car a) '/) (memq s2 '(2 3 6 7))) 15) + (t + (logior (if (memq s1 '(4 5 6 7)) s2 0) + (if (memq s1 '(2 3 6 7)) 2 0) + (if (memq s1 '(1 3 5 7)) + (math-neg-signs s2) 0)))))) + ((eq (car a) '^) + (let ((s1 (math-possible-signs (nth 1 a))) + (s2 (math-possible-signs (nth 2 a)))) + (cond ((>= s1 8) 15) + ((>= s2 8) 15) + ((eq s1 4) 4) + ((eq s1 2) (if (eq s2 4) 2 15)) + ((eq s2 2) (if (memq s1 '(1 5)) 2 15)) + ((Math-integerp (nth 2 a)) + (if (math-evenp (nth 2 a)) + (if (memq s1 '(3 6 7)) 6 4) + s1)) + ((eq s1 6) (if (eq s2 4) 6 15)) + (t 7)))) + ((eq (car a) '%) + (let ((s2 (math-possible-signs (nth 2 a)))) + (cond ((>= s2 8) 7) + ((eq s2 2) 2) + ((memq s2 '(4 6)) 6) + ((memq s2 '(1 3)) 3) + (t 7)))) + ((and (memq (car a) '(calcFunc-abs calcFunc-abssqr)) + (= (length a) 2)) + (let ((s1 (math-possible-signs (nth 1 a)))) + (cond ((eq s1 2) 2) + ((memq s1 '(1 4 5)) 4) + (t 6)))) + ((and (eq (car a) 'calcFunc-exp) (= (length a) 2)) + (let ((s1 (math-possible-signs (nth 1 a)))) + (if (>= s1 8) + 15 + (if (or (not origin) (math-negp origin)) + 4 + (setq origin (math-sub (or origin 0) 1)) + (if (Math-zerop origin) (setq origin nil)) + s1)))) + ((or (and (memq (car a) '(calcFunc-ln calcFunc-log10)) + (= (length a) 2)) + (and (eq (car a) 'calcFunc-log) + (= (length a) 3) + (math-known-posp (nth 2 a)))) + (if (math-known-nonnegp (nth 1 a)) + (math-possible-signs (nth 1 a) 1) + 15)) + ((and (eq (car a) 'calcFunc-sqrt) (= (length a) 2)) + (let ((s1 (math-possible-signs (nth 1 a)))) + (if (memq s1 '(2 4 6)) s1 15))) + ((memq (car a) math-nonnegative-functions) 6) + ((memq (car a) math-positive-functions) 4) + ((memq (car a) math-real-functions) 7) + ((memq (car a) math-real-scalar-functions) 7) + ((and (memq (car a) math-real-if-arg-functions) + (= (length a) 2)) + (if (math-known-realp (nth 1 a)) 7 15))))) + (cond (sign + (if origin + (+ (logand sign 8) + (if (Math-posp origin) + (if (memq sign '(1 2 3 8 9 10 11)) 1 7) + (if (memq sign '(2 4 6 8 10 12 14)) 4 7))) + sign)) + ((math-const-var a) + (cond ((eq (nth 2 a) 'var-pi) + (if origin + (math-possible-signs (math-pi) origin) + 4)) + ((eq (nth 2 a) 'var-e) + (if origin + (math-possible-signs (math-e) origin) + 4)) + ((eq (nth 2 a) 'var-inf) 4) + ((eq (nth 2 a) 'var-uinf) 13) + ((eq (nth 2 a) 'var-i) 8) + (t 15))) + (t + (math-setup-declarations) + (let ((decl (if (eq (car a) 'var) + (or (assq (nth 2 a) math-decls-cache) + math-decls-all) + (assq (car a) math-decls-cache)))) + (if (and origin + (memq 'int (nth 1 decl)) + (not (Math-num-integerp origin))) + 5 + (if (nth 2 decl) + (math-possible-signs (nth 2 decl) origin) + (if (memq 'real (nth 1 decl)) + 7 + 15))))))))) +) + +(defun math-neg-signs (s1) + (if (>= s1 8) + (+ 8 (math-neg-signs (- s1 8))) + (+ (if (memq s1 '(1 3 5 7)) 4 0) + (if (memq s1 '(2 3 6 7)) 2 0) + (if (memq s1 '(4 5 6 7)) 1 0))) +) + + +;;; Try to prove that A is an integer. +(defun math-known-integerp (a) + (eq (math-possible-types a) 1) +) + +(defun math-known-num-integerp (a) + (<= (math-possible-types a t) 3) +) + +(defun math-known-imagp (a) + (= (math-possible-types a) 16) +) + + +;;; Find the possible types of A. +;;; Returns an integer with bits: 1 may be integer. +;;; 2 may be integer-valued float. +;;; 4 may be fraction. +;;; 8 may be non-integer-valued float. +;;; 16 may be imaginary. +;;; 32 may be non-real, non-imaginary. +;;; Real infinities count as integers for the purposes of this function. +(defun math-possible-types (a &optional num) + (cond ((Math-objectp a) + (cond ((Math-integerp a) (if num 3 1)) + ((Math-messy-integerp a) (if num 3 2)) + ((eq (car a) 'frac) (if num 12 4)) + ((eq (car a) 'float) (if num 12 8)) + ((eq (car a) 'intv) + (if (equal (nth 2 a) (nth 3 a)) + (math-possible-types (nth 2 a)) + 15)) + ((eq (car a) 'sdev) + (if (math-known-realp (nth 1 a)) 15 63)) + ((eq (car a) 'cplx) + (if (math-zerop (nth 1 a)) 16 32)) + ((eq (car a) 'polar) + (if (or (Math-equal (nth 2 a) (math-quarter-circle nil)) + (Math-equal (nth 2 a) + (math-neg (math-quarter-circle nil)))) + 16 48)) + (t 63))) + ((eq (car a) '/) + (let* ((t1 (math-possible-types (nth 1 a) num)) + (t2 (math-possible-types (nth 2 a) num)) + (t12 (logior t1 t2))) + (if (< t12 16) + (if (> (logand t12 10) 0) + 10 + (if (or (= t1 4) (= t2 4) calc-prefer-frac) + 5 + 15)) + (if (< t12 32) + (if (= t1 16) + (if (= t2 16) 15 + (if (< t2 16) 16 31)) + (if (= t2 16) + (if (< t1 16) 16 31) + 31)) + 63)))) + ((memq (car a) '(+ - * %)) + (let* ((t1 (math-possible-types (nth 1 a) num)) + (t2 (math-possible-types (nth 2 a) num)) + (t12 (logior t1 t2))) + (if (eq (car a) '%) + (setq t1 (logand t1 15) t2 (logand t2 15) t12 (logand t12 15))) + (if (< t12 16) + (let ((mask (if (<= t12 3) + 1 + (if (and (or (and (<= t1 3) (= (logand t2 3) 0)) + (and (<= t2 3) (= (logand t1 3) 0))) + (memq (car a) '(+ -))) + 4 + 5)))) + (if num + (* mask 3) + (logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0)) + mask 0) + (if (> (logand t12 10) 0) + (* mask 2) 0)))) + (if (< t12 32) + (if (eq (car a) '*) + (if (= t1 16) + (if (= t2 16) 15 + (if (< t2 16) 16 31)) + (if (= t2 16) + (if (< t1 16) 16 31) + 31)) + (if (= t12 16) 16 + (if (or (and (= t1 16) (< t2 16)) + (and (= t2 16) (< t1 16))) 32 63))) + 63)))) + ((eq (car a) 'neg) + (math-possible-types (nth 1 a))) + ((eq (car a) '^) + (let* ((t1 (math-possible-types (nth 1 a) num)) + (t2 (math-possible-types (nth 2 a) num)) + (t12 (logior t1 t2))) + (if (and (<= t2 3) (math-known-nonnegp (nth 2 a)) (< t1 16)) + (let ((mask (logior (if (> (logand t1 3) 0) 1 0) + (logand t1 4) + (if (> (logand t1 12) 0) 5 0)))) + (if num + (* mask 3) + (logior (if (and (> (logand t1 5) 0) (> (logand t2 5) 0)) + mask 0) + (if (> (logand t12 10) 0) + (* mask 2) 0)))) + (if (and (math-known-nonnegp (nth 1 a)) + (math-known-posp (nth 2 a))) + 15 + 63)))) + ((eq (car a) 'calcFunc-sqrt) + (let ((t1 (math-possible-signs (nth 1 a)))) + (logior (if (> (logand t1 2) 0) 3 0) + (if (> (logand t1 1) 0) 16 0) + (if (> (logand t1 4) 0) 15 0) + (if (> (logand t1 8) 0) 32 0)))) + ((eq (car a) 'vec) + (let ((types 0)) + (while (and (setq a (cdr a)) (< types 63)) + (setq types (logior types (math-possible-types (car a) t)))) + types)) + ((or (memq (car a) math-integer-functions) + (and (memq (car a) math-rounding-functions) + (math-known-nonnegp (or (nth 2 a) 0)))) + 1) + ((or (memq (car a) math-num-integer-functions) + (and (memq (car a) math-float-rounding-functions) + (math-known-nonnegp (or (nth 2 a) 0)))) + 2) + ((eq (car a) 'calcFunc-frac) + 5) + ((and (eq (car a) 'calcFunc-float) (= (length a) 2)) + (let ((t1 (math-possible-types (nth 1 a)))) + (logior (if (> (logand t1 3) 0) 2 0) + (if (> (logand t1 12) 0) 8 0) + (logand t1 48)))) + ((and (memq (car a) '(calcFunc-abs calcFunc-abssqr)) + (= (length a) 2)) + (let ((t1 (math-possible-types (nth 1 a)))) + (if (>= t1 16) + 15 + t1))) + ((math-const-var a) + (cond ((memq (nth 2 a) '(var-e var-pi var-phi var-gamma)) 8) + ((eq (nth 2 a) 'var-inf) 1) + ((eq (nth 2 a) 'var-i) 16) + (t 63))) + (t + (math-setup-declarations) + (let ((decl (if (eq (car a) 'var) + (or (assq (nth 2 a) math-decls-cache) + math-decls-all) + (assq (car a) math-decls-cache)))) + (cond ((memq 'int (nth 1 decl)) + 1) + ((memq 'numint (nth 1 decl)) + 3) + ((memq 'frac (nth 1 decl)) + 4) + ((memq 'rat (nth 1 decl)) + 5) + ((memq 'float (nth 1 decl)) + 10) + ((nth 2 decl) + (math-possible-types (nth 2 decl))) + ((memq 'real (nth 1 decl)) + 15) + (t 63))))) +) + +(defun math-known-evenp (a) + (cond ((Math-integerp a) + (math-evenp a)) + ((Math-messy-integerp a) + (or (> (nth 2 a) 0) + (math-evenp (math-trunc a)))) + ((eq (car a) '*) + (if (math-known-evenp (nth 1 a)) + (math-known-num-integerp (nth 2 a)) + (if (math-known-num-integerp (nth 1 a)) + (math-known-evenp (nth 2 a))))) + ((memq (car a) '(+ -)) + (or (and (math-known-evenp (nth 1 a)) + (math-known-evenp (nth 2 a))) + (and (math-known-oddp (nth 1 a)) + (math-known-oddp (nth 2 a))))) + ((eq (car a) 'neg) + (math-known-evenp (nth 1 a)))) +) + +(defun math-known-oddp (a) + (cond ((Math-integerp a) + (math-oddp a)) + ((Math-messy-integerp a) + (and (<= (nth 2 a) 0) + (math-oddp (math-trunc a)))) + ((memq (car a) '(+ -)) + (or (and (math-known-evenp (nth 1 a)) + (math-known-oddp (nth 2 a))) + (and (math-known-oddp (nth 1 a)) + (math-known-evenp (nth 2 a))))) + ((eq (car a) 'neg) + (math-known-oddp (nth 1 a)))) +) + + +(defun calcFunc-dreal (expr) + (let ((types (math-possible-types expr))) + (if (< types 16) 1 + (if (= (logand types 15) 0) 0 + (math-reject-arg expr 'realp 'quiet)))) +) + +(defun calcFunc-dimag (expr) + (let ((types (math-possible-types expr))) + (if (= types 16) 1 + (if (= (logand types 16) 0) 0 + (math-reject-arg expr "Expected an imaginary number")))) +) + +(defun calcFunc-dpos (expr) + (let ((signs (math-possible-signs expr))) + (if (eq signs 4) 1 + (if (memq signs '(1 2 3)) 0 + (math-reject-arg expr 'posp 'quiet)))) +) + +(defun calcFunc-dneg (expr) + (let ((signs (math-possible-signs expr))) + (if (eq signs 1) 1 + (if (memq signs '(2 4 6)) 0 + (math-reject-arg expr 'negp 'quiet)))) +) + +(defun calcFunc-dnonneg (expr) + (let ((signs (math-possible-signs expr))) + (if (memq signs '(2 4 6)) 1 + (if (eq signs 1) 0 + (math-reject-arg expr 'posp 'quiet)))) +) + +(defun calcFunc-dnonzero (expr) + (let ((signs (math-possible-signs expr))) + (if (memq signs '(1 4 5 8 9 12 13)) 1 + (if (eq signs 2) 0 + (math-reject-arg expr 'nonzerop 'quiet)))) +) + +(defun calcFunc-dint (expr) + (let ((types (math-possible-types expr))) + (if (= types 1) 1 + (if (= (logand types 1) 0) 0 + (math-reject-arg expr 'integerp 'quiet)))) +) + +(defun calcFunc-dnumint (expr) + (let ((types (math-possible-types expr t))) + (if (<= types 3) 1 + (if (= (logand types 3) 0) 0 + (math-reject-arg expr 'integerp 'quiet)))) +) + +(defun calcFunc-dnatnum (expr) + (let ((res (calcFunc-dint expr))) + (if (eq res 1) + (calcFunc-dnonneg expr) + res)) +) + +(defun calcFunc-deven (expr) + (if (math-known-evenp expr) + 1 + (if (or (math-known-oddp expr) + (= (logand (math-possible-types expr) 3) 0)) + 0 + (math-reject-arg expr "Can't tell if expression is odd or even"))) +) + +(defun calcFunc-dodd (expr) + (if (math-known-oddp expr) + 1 + (if (or (math-known-evenp expr) + (= (logand (math-possible-types expr) 3) 0)) + 0 + (math-reject-arg expr "Can't tell if expression is odd or even"))) +) + +(defun calcFunc-drat (expr) + (let ((types (math-possible-types expr))) + (if (memq types '(1 4 5)) 1 + (if (= (logand types 5) 0) 0 + (math-reject-arg expr "Rational number expected")))) +) + +(defun calcFunc-drange (expr) + (math-setup-declarations) + (let (range) + (if (Math-realp expr) + (list 'vec expr) + (if (eq (car-safe expr) 'intv) + expr + (if (eq (car-safe expr) 'var) + (setq range (nth 2 (or (assq (nth 2 expr) math-decls-cache) + math-decls-all))) + (setq range (nth 2 (assq (car-safe expr) math-decls-cache)))) + (if range + (math-clean-set (copy-sequence range)) + (setq range (math-possible-signs expr)) + (if (< range 8) + (aref [(vec) + (intv 2 (neg (var inf var-inf)) 0) + (vec 0) + (intv 3 (neg (var inf var-inf)) 0) + (intv 1 0 (var inf var-inf)) + (vec (intv 2 (neg (var inf var-inf)) 0) + (intv 1 0 (var inf var-inf))) + (intv 3 0 (var inf var-inf)) + (intv 3 (neg (var inf var-inf)) (var inf var-inf))] range) + (math-reject-arg expr 'realp 'quiet)))))) +) + +(defun calcFunc-dscalar (a) + (if (math-known-scalarp a) 1 + (if (math-known-matrixp a) 0 + (math-reject-arg a 'objectp 'quiet))) +) + + +;;; The following lists are not exhaustive. +(defvar math-scalar-functions '(calcFunc-det + calcFunc-cnorm calcFunc-rnorm + calcFunc-vlen calcFunc-vcount + calcFunc-vsum calcFunc-vprod + calcFunc-vmin calcFunc-vmax +)) + +(defvar math-nonscalar-functions '(vec calcFunc-idn calcFunc-diag + calcFunc-cvec calcFunc-index + calcFunc-trn + | calcFunc-append + calcFunc-cons calcFunc-rcons + calcFunc-tail calcFunc-rhead +)) + +(defvar math-scalar-if-args-functions '(+ - * / neg)) + +(defvar math-real-functions '(calcFunc-arg + calcFunc-re calcFunc-im + calcFunc-floor calcFunc-ceil + calcFunc-trunc calcFunc-round + calcFunc-rounde calcFunc-roundu + calcFunc-ffloor calcFunc-fceil + calcFunc-ftrunc calcFunc-fround + calcFunc-frounde calcFunc-froundu +)) + +(defvar math-positive-functions '( +)) + +(defvar math-nonnegative-functions '(calcFunc-cnorm calcFunc-rnorm + calcFunc-vlen calcFunc-vcount +)) + +(defvar math-real-scalar-functions '(% calcFunc-idiv calcFunc-abs + calcFunc-choose calcFunc-perm + calcFunc-eq calcFunc-neq + calcFunc-lt calcFunc-gt + calcFunc-leq calcFunc-geq + calcFunc-lnot + calcFunc-max calcFunc-min +)) + +(defvar math-real-if-arg-functions '(calcFunc-sin calcFunc-cos + calcFunc-tan calcFunc-arctan + calcFunc-sinh calcFunc-cosh + calcFunc-tanh calcFunc-exp + calcFunc-gamma calcFunc-fact +)) + +(defvar math-integer-functions '(calcFunc-idiv + calcFunc-isqrt calcFunc-ilog + calcFunc-vlen calcFunc-vcount +)) + +(defvar math-num-integer-functions '( +)) + +(defvar math-rounding-functions '(calcFunc-floor + calcFunc-ceil + calcFunc-round calcFunc-trunc + calcFunc-rounde calcFunc-roundu +)) + +(defvar math-float-rounding-functions '(calcFunc-ffloor + calcFunc-fceil + calcFunc-fround calcFunc-ftrunc + calcFunc-frounde calcFunc-froundu +)) + +(defvar math-integer-if-args-functions '(+ - * % neg calcFunc-abs + calcFunc-min calcFunc-max + calcFunc-choose calcFunc-perm +)) + + +;;;; Arithmetic. + +(defun calcFunc-neg (a) + (math-normalize (list 'neg a)) +) + +(defun math-neg-fancy (a) + (cond ((eq (car a) 'polar) + (list 'polar + (nth 1 a) + (if (math-posp (nth 2 a)) + (math-sub (nth 2 a) (math-half-circle nil)) + (math-add (nth 2 a) (math-half-circle nil))))) + ((eq (car a) 'mod) + (if (math-zerop (nth 1 a)) + a + (list 'mod (math-sub (nth 2 a) (nth 1 a)) (nth 2 a)))) + ((eq (car a) 'sdev) + (list 'sdev (math-neg (nth 1 a)) (nth 2 a))) + ((eq (car a) 'intv) + (math-make-intv (aref [0 2 1 3] (nth 1 a)) + (math-neg (nth 3 a)) + (math-neg (nth 2 a)))) + ((and math-simplify-only + (not (equal a math-simplify-only))) + (list 'neg a)) + ((eq (car a) '+) + (math-sub (math-neg (nth 1 a)) (nth 2 a))) + ((eq (car a) '-) + (math-sub (nth 2 a) (nth 1 a))) + ((and (memq (car a) '(* /)) + (math-okay-neg (nth 1 a))) + (list (car a) (math-neg (nth 1 a)) (nth 2 a))) + ((and (memq (car a) '(* /)) + (math-okay-neg (nth 2 a))) + (list (car a) (nth 1 a) (math-neg (nth 2 a)))) + ((and (memq (car a) '(* /)) + (or (math-objectp (nth 1 a)) + (and (eq (car (nth 1 a)) '*) + (math-objectp (nth 1 (nth 1 a)))))) + (list (car a) (math-neg (nth 1 a)) (nth 2 a))) + ((and (eq (car a) '/) + (or (math-objectp (nth 2 a)) + (and (eq (car (nth 2 a)) '*) + (math-objectp (nth 1 (nth 2 a)))))) + (list (car a) (nth 1 a) (math-neg (nth 2 a)))) + ((and (eq (car a) 'var) (memq (nth 2 a) '(var-uinf var-nan))) + a) + ((eq (car a) 'neg) + (nth 1 a)) + (t (list 'neg a))) +) + +(defun math-okay-neg (a) + (or (math-looks-negp a) + (eq (car-safe a) '-)) +) + +(defun math-neg-float (a) + (list 'float (Math-integer-neg (nth 1 a)) (nth 2 a)) +) + + +(defun calcFunc-add (&rest rest) + (if rest + (let ((a (car rest))) + (while (setq rest (cdr rest)) + (setq a (list '+ a (car rest)))) + (math-normalize a)) + 0) +) + +(defun calcFunc-sub (&rest rest) + (if rest + (let ((a (car rest))) + (while (setq rest (cdr rest)) + (setq a (list '- a (car rest)))) + (math-normalize a)) + 0) +) + +(defun math-add-objects-fancy (a b) + (cond ((and (Math-numberp a) (Math-numberp b)) + (let ((aa (math-complex a)) + (bb (math-complex b))) + (math-normalize + (let ((res (list 'cplx + (math-add (nth 1 aa) (nth 1 bb)) + (math-add (nth 2 aa) (nth 2 bb))))) + (if (math-want-polar a b) + (math-polar res) + res))))) + ((or (Math-vectorp a) (Math-vectorp b)) + (math-map-vec-2 'math-add a b)) + ((eq (car-safe a) 'sdev) + (if (eq (car-safe b) 'sdev) + (math-make-sdev (math-add (nth 1 a) (nth 1 b)) + (math-hypot (nth 2 a) (nth 2 b))) + (and (or (Math-scalarp b) + (not (Math-objvecp b))) + (math-make-sdev (math-add (nth 1 a) b) (nth 2 a))))) + ((and (eq (car-safe b) 'sdev) + (or (Math-scalarp a) + (not (Math-objvecp a)))) + (math-make-sdev (math-add a (nth 1 b)) (nth 2 b))) + ((eq (car-safe a) 'intv) + (if (eq (car-safe b) 'intv) + (math-make-intv (logior (logand (nth 1 a) (nth 1 b)) + (if (equal (nth 2 a) + '(neg (var inf var-inf))) + (logand (nth 1 a) 2) 0) + (if (equal (nth 2 b) + '(neg (var inf var-inf))) + (logand (nth 1 b) 2) 0) + (if (equal (nth 3 a) '(var inf var-inf)) + (logand (nth 1 a) 1) 0) + (if (equal (nth 3 b) '(var inf var-inf)) + (logand (nth 1 b) 1) 0)) + (math-add (nth 2 a) (nth 2 b)) + (math-add (nth 3 a) (nth 3 b))) + (and (or (Math-anglep b) + (eq (car b) 'date) + (not (Math-objvecp b))) + (math-make-intv (nth 1 a) + (math-add (nth 2 a) b) + (math-add (nth 3 a) b))))) + ((and (eq (car-safe b) 'intv) + (or (Math-anglep a) + (eq (car a) 'date) + (not (Math-objvecp a)))) + (math-make-intv (nth 1 b) + (math-add a (nth 2 b)) + (math-add a (nth 3 b)))) + ((eq (car-safe a) 'date) + (cond ((eq (car-safe b) 'date) + (math-add (nth 1 a) (nth 1 b))) + ((eq (car-safe b) 'hms) + (let ((parts (math-date-parts (nth 1 a)))) + (list 'date + (math-add (car parts) ; this minimizes roundoff + (math-div (math-add + (math-add (nth 1 parts) + (nth 2 parts)) + (math-add + (math-mul (nth 1 b) 3600) + (math-add (math-mul (nth 2 b) 60) + (nth 3 b)))) + 86400))))) + ((Math-realp b) + (list 'date (math-add (nth 1 a) b))) + (t nil))) + ((eq (car-safe b) 'date) + (math-add-objects-fancy b a)) + ((and (eq (car-safe a) 'mod) + (eq (car-safe b) 'mod) + (equal (nth 2 a) (nth 2 b))) + (math-make-mod (math-add (nth 1 a) (nth 1 b)) (nth 2 a))) + ((and (eq (car-safe a) 'mod) + (Math-anglep b)) + (math-make-mod (math-add (nth 1 a) b) (nth 2 a))) + ((and (eq (car-safe b) 'mod) + (Math-anglep a)) + (math-make-mod (math-add a (nth 1 b)) (nth 2 b))) + ((and (or (eq (car-safe a) 'hms) (eq (car-safe b) 'hms)) + (and (Math-anglep a) (Math-anglep b))) + (or (eq (car-safe a) 'hms) (setq a (math-to-hms a))) + (or (eq (car-safe b) 'hms) (setq b (math-to-hms b))) + (math-normalize + (if (math-negp a) + (math-neg (math-add (math-neg a) (math-neg b))) + (if (math-negp b) + (let* ((s (math-add (nth 3 a) (nth 3 b))) + (m (math-add (nth 2 a) (nth 2 b))) + (h (math-add (nth 1 a) (nth 1 b)))) + (if (math-negp s) + (setq s (math-add s 60) + m (math-add m -1))) + (if (math-negp m) + (setq m (math-add m 60) + h (math-add h -1))) + (if (math-negp h) + (math-add b a) + (list 'hms h m s))) + (let* ((s (math-add (nth 3 a) (nth 3 b))) + (m (math-add (nth 2 a) (nth 2 b))) + (h (math-add (nth 1 a) (nth 1 b)))) + (list 'hms h m s)))))) + (t (calc-record-why "*Incompatible arguments for +" a b))) +) + +(defun math-add-symb-fancy (a b) + (or (and math-simplify-only + (not (equal a math-simplify-only)) + (list '+ a b)) + (and (eq (car-safe b) '+) + (math-add (math-add a (nth 1 b)) + (nth 2 b))) + (and (eq (car-safe b) '-) + (math-sub (math-add a (nth 1 b)) + (nth 2 b))) + (and (eq (car-safe b) 'neg) + (eq (car-safe (nth 1 b)) '+) + (math-sub (math-sub a (nth 1 (nth 1 b))) + (nth 2 (nth 1 b)))) + (and (or (and (Math-vectorp a) (math-known-scalarp b)) + (and (Math-vectorp b) (math-known-scalarp a))) + (math-map-vec-2 'math-add a b)) + (let ((inf (math-infinitep a))) + (cond + (inf + (let ((inf2 (math-infinitep b))) + (if inf2 + (if (or (memq (nth 2 inf) '(var-uinf var-nan)) + (memq (nth 2 inf2) '(var-uinf var-nan))) + '(var nan var-nan) + (let ((dir (math-infinite-dir a inf)) + (dir2 (math-infinite-dir b inf2))) + (if (and (Math-objectp dir) (Math-objectp dir2)) + (if (Math-equal dir dir2) + a + '(var nan var-nan))))) + (if (and (equal a '(var inf var-inf)) + (eq (car-safe b) 'intv) + (memq (nth 1 b) '(2 3)) + (equal (nth 2 b) '(neg (var inf var-inf)))) + (list 'intv 3 (nth 2 b) a) + (if (and (equal a '(neg (var inf var-inf))) + (eq (car-safe b) 'intv) + (memq (nth 1 b) '(1 3)) + (equal (nth 3 b) '(var inf var-inf))) + (list 'intv 3 a (nth 3 b)) + a))))) + ((math-infinitep b) + (if (eq (car-safe a) 'intv) + (math-add b a) + b)) + ((eq (car-safe a) '+) + (let ((temp (math-combine-sum (nth 2 a) b nil nil t))) + (and temp + (math-add (nth 1 a) temp)))) + ((eq (car-safe a) '-) + (let ((temp (math-combine-sum (nth 2 a) b t nil t))) + (and temp + (math-add (nth 1 a) temp)))) + ((and (Math-objectp a) (Math-objectp b)) + nil) + (t + (math-combine-sum a b nil nil nil)))) + (and (Math-looks-negp b) + (list '- a (math-neg b))) + (and (Math-looks-negp a) + (list '- b (math-neg a))) + (and (eq (car-safe a) 'calcFunc-idn) + (= (length a) 2) + (or (and (eq (car-safe b) 'calcFunc-idn) + (= (length b) 2) + (list 'calcFunc-idn (math-add (nth 1 a) (nth 1 b)))) + (and (math-square-matrixp b) + (math-add (math-mimic-ident (nth 1 a) b) b)) + (and (math-known-scalarp b) + (math-add (nth 1 a) b)))) + (and (eq (car-safe b) 'calcFunc-idn) + (= (length a) 2) + (or (and (math-square-matrixp a) + (math-add a (math-mimic-ident (nth 1 b) a))) + (and (math-known-scalarp a) + (math-add a (nth 1 b))))) + (list '+ a b)) +) + + +(defun calcFunc-mul (&rest rest) + (if rest + (let ((a (car rest))) + (while (setq rest (cdr rest)) + (setq a (list '* a (car rest)))) + (math-normalize a)) + 1) +) + +(defun math-mul-objects-fancy (a b) + (cond ((and (Math-numberp a) (Math-numberp b)) + (math-normalize + (if (math-want-polar a b) + (let ((a (math-polar a)) + (b (math-polar b))) + (list 'polar + (math-mul (nth 1 a) (nth 1 b)) + (math-fix-circular (math-add (nth 2 a) (nth 2 b))))) + (setq a (math-complex a) + b (math-complex b)) + (list 'cplx + (math-sub (math-mul (nth 1 a) (nth 1 b)) + (math-mul (nth 2 a) (nth 2 b))) + (math-add (math-mul (nth 1 a) (nth 2 b)) + (math-mul (nth 2 a) (nth 1 b))))))) + ((Math-vectorp a) + (if (Math-vectorp b) + (if (math-matrixp a) + (if (math-matrixp b) + (if (= (length (nth 1 a)) (length b)) + (math-mul-mats a b) + (math-dimension-error)) + (if (= (length (nth 1 a)) 2) + (if (= (length a) (length b)) + (math-mul-mats a (list 'vec b)) + (math-dimension-error)) + (if (= (length (nth 1 a)) (length b)) + (math-mul-mat-vec a b) + (math-dimension-error)))) + (if (math-matrixp b) + (if (= (length a) (length b)) + (nth 1 (math-mul-mats (list 'vec a) b)) + (math-dimension-error)) + (if (= (length a) (length b)) + (math-dot-product a b) + (math-dimension-error)))) + (math-map-vec-2 'math-mul a b))) + ((Math-vectorp b) + (math-map-vec-2 'math-mul a b)) + ((eq (car-safe a) 'sdev) + (if (eq (car-safe b) 'sdev) + (math-make-sdev (math-mul (nth 1 a) (nth 1 b)) + (math-hypot (math-mul (nth 2 a) (nth 1 b)) + (math-mul (nth 2 b) (nth 1 a)))) + (and (or (Math-scalarp b) + (not (Math-objvecp b))) + (math-make-sdev (math-mul (nth 1 a) b) + (math-mul (nth 2 a) b))))) + ((and (eq (car-safe b) 'sdev) + (or (Math-scalarp a) + (not (Math-objvecp a)))) + (math-make-sdev (math-mul a (nth 1 b)) (math-mul a (nth 2 b)))) + ((and (eq (car-safe a) 'intv) (Math-anglep b)) + (if (Math-negp b) + (math-neg (math-mul a (math-neg b))) + (math-make-intv (nth 1 a) + (math-mul (nth 2 a) b) + (math-mul (nth 3 a) b)))) + ((and (eq (car-safe b) 'intv) (Math-anglep a)) + (math-mul b a)) + ((and (eq (car-safe a) 'intv) (math-intv-constp a) + (eq (car-safe b) 'intv) (math-intv-constp b)) + (let ((lo (math-mul a (nth 2 b))) + (hi (math-mul a (nth 3 b)))) + (or (eq (car-safe lo) 'intv) + (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0) lo lo))) + (or (eq (car-safe hi) 'intv) + (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0) hi hi))) + (math-combine-intervals + (nth 2 lo) (and (or (memq (nth 1 b) '(2 3)) + (math-infinitep (nth 2 lo))) + (memq (nth 1 lo) '(2 3))) + (nth 3 lo) (and (or (memq (nth 1 b) '(2 3)) + (math-infinitep (nth 3 lo))) + (memq (nth 1 lo) '(1 3))) + (nth 2 hi) (and (or (memq (nth 1 b) '(1 3)) + (math-infinitep (nth 2 hi))) + (memq (nth 1 hi) '(2 3))) + (nth 3 hi) (and (or (memq (nth 1 b) '(1 3)) + (math-infinitep (nth 3 hi))) + (memq (nth 1 hi) '(1 3)))))) + ((and (eq (car-safe a) 'mod) + (eq (car-safe b) 'mod) + (equal (nth 2 a) (nth 2 b))) + (math-make-mod (math-mul (nth 1 a) (nth 1 b)) (nth 2 a))) + ((and (eq (car-safe a) 'mod) + (Math-anglep b)) + (math-make-mod (math-mul (nth 1 a) b) (nth 2 a))) + ((and (eq (car-safe b) 'mod) + (Math-anglep a)) + (math-make-mod (math-mul a (nth 1 b)) (nth 2 b))) + ((and (eq (car-safe a) 'hms) (Math-realp b)) + (math-with-extra-prec 2 + (math-to-hms (math-mul (math-from-hms a 'deg) b) 'deg))) + ((and (eq (car-safe b) 'hms) (Math-realp a)) + (math-mul b a)) + (t (calc-record-why "*Incompatible arguments for *" a b))) +) + +;;; Fast function to multiply floating-point numbers. +(defun math-mul-float (a b) ; [F F F] + (math-make-float (math-mul (nth 1 a) (nth 1 b)) + (+ (nth 2 a) (nth 2 b))) +) + +(defun math-sqr-float (a) ; [F F] + (math-make-float (math-mul (nth 1 a) (nth 1 a)) + (+ (nth 2 a) (nth 2 a))) +) + +(defun math-intv-constp (a &optional finite) + (and (or (Math-anglep (nth 2 a)) + (and (equal (nth 2 a) '(neg (var inf var-inf))) + (or (not finite) + (memq (nth 1 a) '(0 1))))) + (or (Math-anglep (nth 3 a)) + (and (equal (nth 3 a) '(var inf var-inf)) + (or (not finite) + (memq (nth 1 a) '(0 2)))))) +) + +(defun math-mul-zero (a b) + (if (math-known-matrixp b) + (if (math-vectorp b) + (math-map-vec-2 'math-mul a b) + (math-mimic-ident 0 b)) + (if (math-infinitep b) + '(var nan var-nan) + (let ((aa nil) (bb nil)) + (if (and (eq (car-safe b) 'intv) + (progn + (and (equal (nth 2 b) '(neg (var inf var-inf))) + (memq (nth 1 b) '(2 3)) + (setq aa (nth 2 b))) + (and (equal (nth 3 b) '(var inf var-inf)) + (memq (nth 1 b) '(1 3)) + (setq bb (nth 3 b))) + (or aa bb))) + (if (or (math-posp a) + (and (math-zerop a) + (or (memq calc-infinite-mode '(-1 1)) + (setq aa '(neg (var inf var-inf)) + bb '(var inf var-inf))))) + (list 'intv 3 (or aa 0) (or bb 0)) + (if (math-negp a) + (math-neg (list 'intv 3 (or aa 0) (or bb 0))) + '(var nan var-nan))) + (if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0))))) +) + + +(defun math-mul-symb-fancy (a b) + (or (and math-simplify-only + (not (equal a math-simplify-only)) + (list '* a b)) + (and (Math-equal-int a 1) + b) + (and (Math-equal-int a -1) + (math-neg b)) + (and (or (and (Math-vectorp a) (math-known-scalarp b)) + (and (Math-vectorp b) (math-known-scalarp a))) + (math-map-vec-2 'math-mul a b)) + (and (Math-objectp b) (not (Math-objectp a)) + (math-mul b a)) + (and (eq (car-safe a) 'neg) + (math-neg (math-mul (nth 1 a) b))) + (and (eq (car-safe b) 'neg) + (math-neg (math-mul a (nth 1 b)))) + (and (eq (car-safe a) '*) + (math-mul (nth 1 a) + (math-mul (nth 2 a) b))) + (and (eq (car-safe a) '^) + (Math-looks-negp (nth 2 a)) + (not (and (eq (car-safe b) '^) (Math-looks-negp (nth 2 b)))) + (math-known-scalarp b t) + (math-div b (math-normalize + (list '^ (nth 1 a) (math-neg (nth 2 a)))))) + (and (eq (car-safe b) '^) + (Math-looks-negp (nth 2 b)) + (not (and (eq (car-safe a) '^) (Math-looks-negp (nth 2 a)))) + (math-div a (math-normalize + (list '^ (nth 1 b) (math-neg (nth 2 b)))))) + (and (eq (car-safe a) '/) + (or (math-known-scalarp a t) (math-known-scalarp b t)) + (let ((temp (math-combine-prod (nth 2 a) b t nil t))) + (if temp + (math-mul (nth 1 a) temp) + (math-div (math-mul (nth 1 a) b) (nth 2 a))))) + (and (eq (car-safe b) '/) + (math-div (math-mul a (nth 1 b)) (nth 2 b))) + (and (eq (car-safe b) '+) + (Math-numberp a) + (or (Math-numberp (nth 1 b)) + (Math-numberp (nth 2 b))) + (math-add (math-mul a (nth 1 b)) + (math-mul a (nth 2 b)))) + (and (eq (car-safe b) '-) + (Math-numberp a) + (or (Math-numberp (nth 1 b)) + (Math-numberp (nth 2 b))) + (math-sub (math-mul a (nth 1 b)) + (math-mul a (nth 2 b)))) + (and (eq (car-safe b) '*) + (Math-numberp (nth 1 b)) + (not (Math-numberp a)) + (math-mul (nth 1 b) (math-mul a (nth 2 b)))) + (and (eq (car-safe a) 'calcFunc-idn) + (= (length a) 2) + (or (and (eq (car-safe b) 'calcFunc-idn) + (= (length b) 2) + (list 'calcFunc-idn (math-mul (nth 1 a) (nth 1 b)))) + (and (math-known-scalarp b) + (list 'calcFunc-idn (math-mul (nth 1 a) b))) + (and (math-known-matrixp b) + (math-mul (nth 1 a) b)))) + (and (eq (car-safe b) 'calcFunc-idn) + (= (length b) 2) + (or (and (math-known-scalarp a) + (list 'calcFunc-idn (math-mul a (nth 1 b)))) + (and (math-known-matrixp a) + (math-mul a (nth 1 b))))) + (and (math-looks-negp b) + (math-mul (math-neg a) (math-neg b))) + (and (eq (car-safe b) '-) + (math-looks-negp a) + (math-mul (math-neg a) (math-neg b))) + (cond + ((eq (car-safe b) '*) + (let ((temp (math-combine-prod a (nth 1 b) nil nil t))) + (and temp + (math-mul temp (nth 2 b))))) + (t + (math-combine-prod a b nil nil nil))) + (and (equal a '(var nan var-nan)) + a) + (and (equal b '(var nan var-nan)) + b) + (and (equal a '(var uinf var-uinf)) + a) + (and (equal b '(var uinf var-uinf)) + b) + (and (equal b '(var inf var-inf)) + (let ((s1 (math-possible-signs a))) + (cond ((eq s1 4) + b) + ((eq s1 6) + '(intv 3 0 (var inf var-inf))) + ((eq s1 1) + (math-neg b)) + ((eq s1 3) + '(intv 3 (neg (var inf var-inf)) 0)) + ((and (eq (car a) 'intv) (math-intv-constp a)) + '(intv 3 (neg (var inf var-inf)) (var inf var-inf))) + ((and (eq (car a) 'cplx) + (math-zerop (nth 1 a))) + (list '* (list 'cplx 0 (calcFunc-sign (nth 2 a))) b)) + ((eq (car a) 'polar) + (list '* (list 'polar 1 (nth 2 a)) b))))) + (and (equal a '(var inf var-inf)) + (math-mul b a)) + (list '* a b)) +) + + +(defun calcFunc-div (a &rest rest) + (while rest + (setq a (list '/ a (car rest)) + rest (cdr rest))) + (math-normalize a) +) + +(defun math-div-objects-fancy (a b) + (cond ((and (Math-numberp a) (Math-numberp b)) + (math-normalize + (cond ((math-want-polar a b) + (let ((a (math-polar a)) + (b (math-polar b))) + (list 'polar + (math-div (nth 1 a) (nth 1 b)) + (math-fix-circular (math-sub (nth 2 a) + (nth 2 b)))))) + ((Math-realp b) + (setq a (math-complex a)) + (list 'cplx (math-div (nth 1 a) b) + (math-div (nth 2 a) b))) + (t + (setq a (math-complex a) + b (math-complex b)) + (math-div + (list 'cplx + (math-add (math-mul (nth 1 a) (nth 1 b)) + (math-mul (nth 2 a) (nth 2 b))) + (math-sub (math-mul (nth 2 a) (nth 1 b)) + (math-mul (nth 1 a) (nth 2 b)))) + (math-add (math-sqr (nth 1 b)) + (math-sqr (nth 2 b)))))))) + ((math-matrixp b) + (if (math-square-matrixp b) + (let ((n1 (length b))) + (if (Math-vectorp a) + (if (math-matrixp a) + (if (= (length a) n1) + (math-lud-solve (math-matrix-lud b) a b) + (if (= (length (nth 1 a)) n1) + (math-transpose + (math-lud-solve (math-matrix-lud + (math-transpose b)) + (math-transpose a) b)) + (math-dimension-error))) + (if (= (length a) n1) + (math-mat-col (math-lud-solve (math-matrix-lud b) + (math-col-matrix a) b) + 1) + (math-dimension-error))) + (if (Math-equal-int a 1) + (calcFunc-inv b) + (math-mul a (calcFunc-inv b))))) + (math-reject-arg b 'square-matrixp))) + ((and (Math-vectorp a) (Math-objectp b)) + (math-map-vec-2 'math-div a b)) + ((eq (car-safe a) 'sdev) + (if (eq (car-safe b) 'sdev) + (let ((x (math-div (nth 1 a) (nth 1 b)))) + (math-make-sdev x + (math-div (math-hypot (nth 2 a) + (math-mul (nth 2 b) x)) + (nth 1 b)))) + (if (or (Math-scalarp b) + (not (Math-objvecp b))) + (math-make-sdev (math-div (nth 1 a) b) (math-div (nth 2 a) b)) + (math-reject-arg 'realp b)))) + ((and (eq (car-safe b) 'sdev) + (or (Math-scalarp a) + (not (Math-objvecp a)))) + (let ((x (math-div a (nth 1 b)))) + (math-make-sdev x + (math-div (math-mul (nth 2 b) x) (nth 1 b))))) + ((and (eq (car-safe a) 'intv) (Math-anglep b)) + (if (Math-negp b) + (math-neg (math-div a (math-neg b))) + (math-make-intv (nth 1 a) + (math-div (nth 2 a) b) + (math-div (nth 3 a) b)))) + ((and (eq (car-safe b) 'intv) (Math-anglep a)) + (if (or (Math-posp (nth 2 b)) + (and (Math-zerop (nth 2 b)) (or (memq (nth 1 b) '(0 1)) + calc-infinite-mode))) + (if (Math-negp a) + (math-neg (math-div (math-neg a) b)) + (let ((calc-infinite-mode 1)) + (math-make-intv (aref [0 2 1 3] (nth 1 b)) + (math-div a (nth 3 b)) + (math-div a (nth 2 b))))) + (if (or (Math-negp (nth 3 b)) + (and (Math-zerop (nth 3 b)) (or (memq (nth 1 b) '(0 2)) + calc-infinite-mode))) + (math-neg (math-div a (math-neg b))) + (if calc-infinite-mode + '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) + (math-reject-arg b "*Division by zero"))))) + ((and (eq (car-safe a) 'intv) (math-intv-constp a) + (eq (car-safe b) 'intv) (math-intv-constp b)) + (if (or (Math-posp (nth 2 b)) + (and (Math-zerop (nth 2 b)) (or (memq (nth 1 b) '(0 1)) + calc-infinite-mode))) + (let* ((calc-infinite-mode 1) + (lo (math-div a (nth 2 b))) + (hi (math-div a (nth 3 b)))) + (or (eq (car-safe lo) 'intv) + (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0) + lo lo))) + (or (eq (car-safe hi) 'intv) + (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0) + hi hi))) + (math-combine-intervals + (nth 2 lo) (and (or (memq (nth 1 b) '(2 3)) + (and (math-infinitep (nth 2 lo)) + (not (math-zerop (nth 2 b))))) + (memq (nth 1 lo) '(2 3))) + (nth 3 lo) (and (or (memq (nth 1 b) '(2 3)) + (and (math-infinitep (nth 3 lo)) + (not (math-zerop (nth 2 b))))) + (memq (nth 1 lo) '(1 3))) + (nth 2 hi) (and (or (memq (nth 1 b) '(1 3)) + (and (math-infinitep (nth 2 hi)) + (not (math-zerop (nth 3 b))))) + (memq (nth 1 hi) '(2 3))) + (nth 3 hi) (and (or (memq (nth 1 b) '(1 3)) + (and (math-infinitep (nth 3 hi)) + (not (math-zerop (nth 3 b))))) + (memq (nth 1 hi) '(1 3))))) + (if (or (Math-negp (nth 3 b)) + (and (Math-zerop (nth 3 b)) (or (memq (nth 1 b) '(0 2)) + calc-infinite-mode))) + (math-neg (math-div a (math-neg b))) + (if calc-infinite-mode + '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) + (math-reject-arg b "*Division by zero"))))) + ((and (eq (car-safe a) 'mod) + (eq (car-safe b) 'mod) + (equal (nth 2 a) (nth 2 b))) + (math-make-mod (math-div-mod (nth 1 a) (nth 1 b) (nth 2 a)) + (nth 2 a))) + ((and (eq (car-safe a) 'mod) + (Math-anglep b)) + (math-make-mod (math-div-mod (nth 1 a) b (nth 2 a)) (nth 2 a))) + ((and (eq (car-safe b) 'mod) + (Math-anglep a)) + (math-make-mod (math-div-mod a (nth 1 b) (nth 2 b)) (nth 2 b))) + ((eq (car-safe a) 'hms) + (if (eq (car-safe b) 'hms) + (math-with-extra-prec 1 + (math-div (math-from-hms a 'deg) + (math-from-hms b 'deg))) + (math-with-extra-prec 2 + (math-to-hms (math-div (math-from-hms a 'deg) b) 'deg)))) + (t (calc-record-why "*Incompatible arguments for /" a b))) +) + +(defun math-div-by-zero (a b) + (if (math-infinitep a) + (if (or (equal a '(var nan var-nan)) + (equal b '(var uinf var-uinf)) + (memq calc-infinite-mode '(-1 1))) + a + '(var uinf var-uinf)) + (if calc-infinite-mode + (if (math-zerop a) + '(var nan var-nan) + (if (eq calc-infinite-mode 1) + (math-mul a '(var inf var-inf)) + (if (eq calc-infinite-mode -1) + (math-mul a '(neg (var inf var-inf))) + (if (eq (car-safe a) 'intv) + '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) + '(var uinf var-uinf))))) + (math-reject-arg a "*Division by zero"))) +) + +(defun math-div-zero (a b) + (if (math-known-matrixp b) + (if (math-vectorp b) + (math-map-vec-2 'math-div a b) + (math-mimic-ident 0 b)) + (if (equal b '(var nan var-nan)) + b + (if (and (eq (car-safe b) 'intv) (math-intv-constp b) + (not (math-posp b)) (not (math-negp b))) + (if calc-infinite-mode + (list 'intv 3 + (if (and (math-zerop (nth 2 b)) + (memq calc-infinite-mode '(1 -1))) + (nth 2 b) '(neg (var inf var-inf))) + (if (and (math-zerop (nth 3 b)) + (memq calc-infinite-mode '(1 -1))) + (nth 3 b) '(var inf var-inf))) + (math-reject-arg b "*Division by zero")) + a))) +) + +(defun math-div-symb-fancy (a b) + (or (and math-simplify-only + (not (equal a math-simplify-only)) + (list '/ a b)) + (and (Math-equal-int b 1) a) + (and (Math-equal-int b -1) (math-neg a)) + (and (Math-vectorp a) (math-known-scalarp b) + (math-map-vec-2 'math-div a b)) + (and (eq (car-safe b) '^) + (or (Math-looks-negp (nth 2 b)) (Math-equal-int a 1)) + (math-mul a (math-normalize + (list '^ (nth 1 b) (math-neg (nth 2 b)))))) + (and (eq (car-safe a) 'neg) + (math-neg (math-div (nth 1 a) b))) + (and (eq (car-safe b) 'neg) + (math-neg (math-div a (nth 1 b)))) + (and (eq (car-safe a) '/) + (math-div (nth 1 a) (math-mul (nth 2 a) b))) + (and (eq (car-safe b) '/) + (or (math-known-scalarp (nth 1 b) t) + (math-known-scalarp (nth 2 b) t)) + (math-div (math-mul a (nth 2 b)) (nth 1 b))) + (and (eq (car-safe b) 'frac) + (math-mul (math-make-frac (nth 2 b) (nth 1 b)) a)) + (and (eq (car-safe a) '+) + (or (Math-numberp (nth 1 a)) + (Math-numberp (nth 2 a))) + (Math-numberp b) + (math-add (math-div (nth 1 a) b) + (math-div (nth 2 a) b))) + (and (eq (car-safe a) '-) + (or (Math-numberp (nth 1 a)) + (Math-numberp (nth 2 a))) + (Math-numberp b) + (math-sub (math-div (nth 1 a) b) + (math-div (nth 2 a) b))) + (and (or (eq (car-safe a) '-) + (math-looks-negp a)) + (math-looks-negp b) + (math-div (math-neg a) (math-neg b))) + (and (eq (car-safe b) '-) + (math-looks-negp a) + (math-div (math-neg a) (math-neg b))) + (and (eq (car-safe a) 'calcFunc-idn) + (= (length a) 2) + (or (and (eq (car-safe b) 'calcFunc-idn) + (= (length b) 2) + (list 'calcFunc-idn (math-div (nth 1 a) (nth 1 b)))) + (and (math-known-scalarp b) + (list 'calcFunc-idn (math-div (nth 1 a) b))) + (and (math-known-matrixp b) + (math-div (nth 1 a) b)))) + (and (eq (car-safe b) 'calcFunc-idn) + (= (length b) 2) + (or (and (math-known-scalarp a) + (list 'calcFunc-idn (math-div a (nth 1 b)))) + (and (math-known-matrixp a) + (math-div a (nth 1 b))))) + (if (and calc-matrix-mode + (or (math-known-matrixp a) (math-known-matrixp b))) + (math-combine-prod a b nil t nil) + (if (eq (car-safe a) '*) + (if (eq (car-safe b) '*) + (let ((c (math-combine-prod (nth 1 a) (nth 1 b) nil t t))) + (and c + (math-div (math-mul c (nth 2 a)) (nth 2 b)))) + (let ((c (math-combine-prod (nth 1 a) b nil t t))) + (and c + (math-mul c (nth 2 a))))) + (if (eq (car-safe b) '*) + (let ((c (math-combine-prod a (nth 1 b) nil t t))) + (and c + (math-div c (nth 2 b)))) + (math-combine-prod a b nil t nil)))) + (and (math-infinitep a) + (if (math-infinitep b) + '(var nan var-nan) + (if (or (equal a '(var nan var-nan)) + (equal a '(var uinf var-uinf))) + a + (if (equal a '(var inf var-inf)) + (if (or (math-posp b) + (and (eq (car-safe b) 'intv) + (math-zerop (nth 2 b)))) + (if (and (eq (car-safe b) 'intv) + (not (math-intv-constp b t))) + '(intv 3 0 (var inf var-inf)) + a) + (if (or (math-negp b) + (and (eq (car-safe b) 'intv) + (math-zerop (nth 3 b)))) + (if (and (eq (car-safe b) 'intv) + (not (math-intv-constp b t))) + '(intv 3 (neg (var inf var-inf)) 0) + (math-neg a)) + (if (and (eq (car-safe b) 'intv) + (math-negp (nth 2 b)) (math-posp (nth 3 b))) + '(intv 3 (neg (var inf var-inf)) + (var inf var-inf))))))))) + (and (math-infinitep b) + (if (equal b '(var nan var-nan)) + b + (let ((calc-infinite-mode 1)) + (math-mul-zero b a)))) + (list '/ a b)) +) + + +(defun calcFunc-mod (a b) + (math-normalize (list '% a b)) +) + +(defun math-mod-fancy (a b) + (cond ((equal b '(var inf var-inf)) + (if (or (math-posp a) (math-zerop a)) + a + (if (math-negp a) + b + (if (eq (car-safe a) 'intv) + (if (math-negp (nth 2 a)) + '(intv 3 0 (var inf var-inf)) + a) + (list '% a b))))) + ((and (eq (car-safe a) 'mod) (Math-realp b) (math-posp b)) + (math-make-mod (nth 1 a) b)) + ((and (eq (car-safe a) 'intv) (math-intv-constp a t) (math-posp b)) + (math-mod-intv a b)) + (t + (if (Math-anglep a) + (calc-record-why 'anglep b) + (calc-record-why 'anglep a)) + (list '% a b))) +) + + +(defun calcFunc-pow (a b) + (math-normalize (list '^ a b)) +) + +(defun math-pow-of-zero (a b) + (if (Math-zerop b) + (if calc-infinite-mode + '(var nan var-nan) + (math-reject-arg (list '^ a b) "*Indeterminate form")) + (if (math-floatp b) (setq a (math-float a))) + (if (math-posp b) + a + (if (math-negp b) + (math-div 1 a) + (if (math-infinitep b) + '(var nan var-nan) + (if (and (eq (car b) 'intv) (math-intv-constp b) + calc-infinite-mode) + '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) + (if (math-objectp b) + (list '^ a b) + a)))))) +) + +(defun math-pow-zero (a b) + (if (eq (car-safe a) 'mod) + (math-make-mod 1 (nth 2 a)) + (if (math-known-matrixp a) + (math-mimic-ident 1 a) + (if (math-infinitep a) + '(var nan var-nan) + (if (and (eq (car a) 'intv) (math-intv-constp a) + (or (and (not (math-posp a)) (not (math-negp a))) + (not (math-intv-constp a t)))) + '(intv 3 (neg (var inf var-inf)) (var inf var-inf)) + (if (or (math-floatp a) (math-floatp b)) + '(float 1 0) 1))))) +) + +(defun math-pow-fancy (a b) + (cond ((and (Math-numberp a) (Math-numberp b)) + (or (if (memq (math-quarter-integer b) '(1 2 3)) + (let ((sqrt (math-sqrt (if (math-floatp b) + (math-float a) a)))) + (and (Math-numberp sqrt) + (math-pow sqrt (math-mul 2 b)))) + (and (eq (car b) 'frac) + (integerp (nth 2 b)) + (<= (nth 2 b) 10) + (let ((root (math-nth-root a (nth 2 b)))) + (and root (math-ipow root (nth 1 b)))))) + (and (or (eq a 10) (equal a '(float 1 1))) + (math-num-integerp b) + (calcFunc-scf '(float 1 0) b)) + (and calc-symbolic-mode + (list '^ a b)) + (math-with-extra-prec 2 + (math-exp-raw + (math-float (math-mul b (math-ln-raw (math-float a)))))))) + ((or (not (Math-objvecp a)) + (not (Math-objectp b))) + (let (temp) + (cond ((and math-simplify-only + (not (equal a math-simplify-only))) + (list '^ a b)) + ((and (eq (car-safe a) '*) + (or (math-known-num-integerp b) + (math-known-nonnegp (nth 1 a)) + (math-known-nonnegp (nth 2 a)))) + (math-mul (math-pow (nth 1 a) b) + (math-pow (nth 2 a) b))) + ((and (eq (car-safe a) '/) + (or (math-known-num-integerp b) + (math-known-nonnegp (nth 2 a)))) + (math-div (math-pow (nth 1 a) b) + (math-pow (nth 2 a) b))) + ((and (eq (car-safe a) '/) + (math-known-nonnegp (nth 1 a)) + (not (math-equal-int (nth 1 a) 1))) + (math-mul (math-pow (nth 1 a) b) + (math-pow (math-div 1 (nth 2 a)) b))) + ((and (eq (car-safe a) '^) + (or (math-known-num-integerp b) + (math-known-nonnegp (nth 1 a)))) + (math-pow (nth 1 a) (math-mul (nth 2 a) b))) + ((and (eq (car-safe a) 'calcFunc-sqrt) + (or (math-known-num-integerp b) + (math-known-nonnegp (nth 1 a)))) + (math-pow (nth 1 a) (math-div b 2))) + ((and (eq (car-safe a) '^) + (math-known-evenp (nth 2 a)) + (memq (math-quarter-integer b) '(1 2 3)) + (math-known-realp (nth 1 a))) + (math-abs (math-pow (nth 1 a) (math-mul (nth 2 a) b)))) + ((and (math-looks-negp a) + (math-known-integerp b) + (setq temp (or (and (math-known-evenp b) + (math-pow (math-neg a) b)) + (and (math-known-oddp b) + (math-neg (math-pow (math-neg a) + b)))))) + temp) + ((and (eq (car-safe a) 'calcFunc-abs) + (math-known-realp (nth 1 a)) + (math-known-evenp b)) + (math-pow (nth 1 a) b)) + ((math-infinitep a) + (cond ((equal a '(var nan var-nan)) + a) + ((eq (car a) 'neg) + (math-mul (math-pow -1 b) (math-pow (nth 1 a) b))) + ((math-posp b) + a) + ((math-negp b) + (if (math-floatp b) '(float 0 0) 0)) + ((and (eq (car-safe b) 'intv) + (math-intv-constp b)) + '(intv 3 0 (var inf var-inf))) + (t + '(var nan var-nan)))) + ((math-infinitep b) + (let (scale) + (cond ((math-negp b) + (math-pow (math-div 1 a) (math-neg b))) + ((not (math-posp b)) + '(var nan var-nan)) + ((math-equal-int (setq scale (calcFunc-abssqr a)) 1) + '(var nan var-nan)) + ((Math-lessp scale 1) + (if (math-floatp a) '(float 0 0) 0)) + ((Math-lessp 1 a) + b) + ((Math-lessp a -1) + '(var uinf var-uinf)) + ((and (eq (car a) 'intv) + (math-intv-constp a)) + (if (Math-lessp -1 a) + (if (math-equal-int (nth 3 a) 1) + '(intv 3 0 1) + '(intv 3 0 (var inf var-inf))) + '(intv 3 (neg (var inf var-inf)) + (var inf var-inf)))) + (t (list '^ a b))))) + ((and (eq (car-safe a) 'calcFunc-idn) + (= (length a) 2) + (math-known-num-integerp b)) + (list 'calcFunc-idn (math-pow (nth 1 a) b))) + (t (if (Math-objectp a) + (calc-record-why 'objectp b) + (calc-record-why 'objectp a)) + (list '^ a b))))) + ((and (eq (car-safe a) 'sdev) (eq (car-safe b) 'sdev)) + (if (and (math-constp a) (math-constp b)) + (math-with-extra-prec 2 + (let* ((ln (math-ln-raw (math-float (nth 1 a)))) + (pow (math-exp-raw + (math-float (math-mul (nth 1 b) ln))))) + (math-make-sdev + pow + (math-mul + pow + (math-hypot (math-mul (nth 2 a) + (math-div (nth 1 b) (nth 1 a))) + (math-mul (nth 2 b) ln)))))) + (let ((pow (math-pow (nth 1 a) (nth 1 b)))) + (math-make-sdev + pow + (math-mul pow + (math-hypot (math-mul (nth 2 a) + (math-div (nth 1 b) (nth 1 a))) + (math-mul (nth 2 b) (calcFunc-ln + (nth 1 a))))))))) + ((and (eq (car-safe a) 'sdev) (Math-numberp b)) + (if (math-constp a) + (math-with-extra-prec 2 + (let ((pow (math-pow (nth 1 a) (math-sub b 1)))) + (math-make-sdev (math-mul pow (nth 1 a)) + (math-mul pow (math-mul (nth 2 a) b))))) + (math-make-sdev (math-pow (nth 1 a) b) + (math-mul (math-pow (nth 1 a) (math-add b -1)) + (math-mul (nth 2 a) b))))) + ((and (eq (car-safe b) 'sdev) (Math-numberp a)) + (math-with-extra-prec 2 + (let* ((ln (math-ln-raw (math-float a))) + (pow (calcFunc-exp (math-mul (nth 1 b) ln)))) + (math-make-sdev pow (math-mul pow (math-mul (nth 2 b) ln)))))) + ((and (eq (car-safe a) 'intv) (math-intv-constp a) + (Math-realp b) + (or (Math-natnump b) + (Math-posp (nth 2 a)) + (and (math-zerop (nth 2 a)) + (or (Math-posp b) + (and (Math-integerp b) calc-infinite-mode))) + (Math-negp (nth 3 a)) + (and (math-zerop (nth 3 a)) + (or (Math-posp b) + (and (Math-integerp b) calc-infinite-mode))))) + (if (math-evenp b) + (setq a (math-abs a))) + (let ((calc-infinite-mode (if (math-zerop (nth 3 a)) -1 1))) + (math-sort-intv (nth 1 a) + (math-pow (nth 2 a) b) + (math-pow (nth 3 a) b)))) + ((and (eq (car-safe b) 'intv) (math-intv-constp b) + (Math-realp a) (Math-posp a)) + (math-sort-intv (nth 1 b) + (math-pow a (nth 2 b)) + (math-pow a (nth 3 b)))) + ((and (eq (car-safe a) 'intv) (math-intv-constp a) + (eq (car-safe b) 'intv) (math-intv-constp b) + (or (and (not (Math-negp (nth 2 a))) + (not (Math-negp (nth 2 b)))) + (and (Math-posp (nth 2 a)) + (not (Math-posp (nth 3 b)))))) + (let ((lo (math-pow a (nth 2 b))) + (hi (math-pow a (nth 3 b)))) + (or (eq (car-safe lo) 'intv) + (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0) lo lo))) + (or (eq (car-safe hi) 'intv) + (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0) hi hi))) + (math-combine-intervals + (nth 2 lo) (and (or (memq (nth 1 b) '(2 3)) + (math-infinitep (nth 2 lo))) + (memq (nth 1 lo) '(2 3))) + (nth 3 lo) (and (or (memq (nth 1 b) '(2 3)) + (math-infinitep (nth 3 lo))) + (memq (nth 1 lo) '(1 3))) + (nth 2 hi) (and (or (memq (nth 1 b) '(1 3)) + (math-infinitep (nth 2 hi))) + (memq (nth 1 hi) '(2 3))) + (nth 3 hi) (and (or (memq (nth 1 b) '(1 3)) + (math-infinitep (nth 3 hi))) + (memq (nth 1 hi) '(1 3)))))) + ((and (eq (car-safe a) 'mod) (eq (car-safe b) 'mod) + (equal (nth 2 a) (nth 2 b))) + (math-make-mod (math-pow-mod (nth 1 a) (nth 1 b) (nth 2 a)) + (nth 2 a))) + ((and (eq (car-safe a) 'mod) (Math-anglep b)) + (math-make-mod (math-pow-mod (nth 1 a) b (nth 2 a)) (nth 2 a))) + ((and (eq (car-safe b) 'mod) (Math-anglep a)) + (math-make-mod (math-pow-mod a (nth 1 b) (nth 2 b)) (nth 2 b))) + ((not (Math-numberp a)) + (math-reject-arg a 'numberp)) + (t + (math-reject-arg b 'numberp))) +) + +(defun math-quarter-integer (x) + (if (Math-integerp x) + 0 + (if (math-negp x) + (progn + (setq x (math-quarter-integer (math-neg x))) + (and x (- 4 x))) + (if (eq (car x) 'frac) + (if (eq (nth 2 x) 2) + 2 + (and (eq (nth 2 x) 4) + (progn + (setq x (nth 1 x)) + (% (if (consp x) (nth 1 x) x) 4)))) + (if (eq (car x) 'float) + (if (>= (nth 2 x) 0) + 0 + (if (= (nth 2 x) -1) + (progn + (setq x (nth 1 x)) + (and (= (% (if (consp x) (nth 1 x) x) 10) 5) 2)) + (if (= (nth 2 x) -2) + (progn + (setq x (nth 1 x) + x (% (if (consp x) (nth 1 x) x) 100)) + (if (= x 25) 1 + (if (= x 75) 3)))))))))) +) + +;;; This assumes A < M and M > 0. +(defun math-pow-mod (a b m) ; [R R R R] + (if (and (Math-integerp a) (Math-integerp b) (Math-integerp m)) + (if (Math-negp b) + (math-div-mod 1 (math-pow-mod a (Math-integer-neg b) m) m) + (if (eq m 1) + 0 + (math-pow-mod-step a b m))) + (math-mod (math-pow a b) m)) +) + +(defun math-pow-mod-step (a n m) ; [I I I I] + (math-working "pow" a) + (let ((val (cond + ((eq n 0) 1) + ((eq n 1) a) + (t + (let ((rest (math-pow-mod-step + (math-imod (math-mul a a) m) + (math-div2 n) + m))) + (if (math-evenp n) + rest + (math-mod (math-mul a rest) m))))))) + (math-working "pow" val) + val) +) + + +;;; Compute the minimum of two real numbers. [R R R] [Public] +(defun math-min (a b) + (if (and (consp a) (eq (car a) 'intv)) + (if (and (consp b) (eq (car b) 'intv)) + (let ((lo (nth 2 a)) + (lom (memq (nth 1 a) '(2 3))) + (hi (nth 3 a)) + (him (memq (nth 1 a) '(1 3))) + res) + (if (= (setq res (math-compare (nth 2 b) lo)) -1) + (setq lo (nth 2 b) lom (memq (nth 1 b) '(2 3))) + (if (= res 0) + (setq lom (or lom (memq (nth 1 b) '(2 3)))))) + (if (= (setq res (math-compare (nth 3 b) hi)) -1) + (setq hi (nth 3 b) him (memq (nth 1 b) '(1 3))) + (if (= res 0) + (setq him (or him (memq (nth 1 b) '(1 3)))))) + (math-make-intv (+ (if lom 2 0) (if him 1 0)) lo hi)) + (math-min a (list 'intv 3 b b))) + (if (and (consp b) (eq (car b) 'intv)) + (math-min (list 'intv 3 a a) b) + (let ((res (math-compare a b))) + (if (= res 1) + b + (if (= res 2) + '(var nan var-nan) + a))))) +) + +(defun calcFunc-min (&optional a &rest b) + (if (not a) + '(var inf var-inf) + (if (not (or (Math-anglep a) (eq (car a) 'date) + (and (eq (car a) 'intv) (math-intv-constp a)) + (math-infinitep a))) + (math-reject-arg a 'anglep)) + (math-min-list a b)) +) + +(defun math-min-list (a b) + (if b + (if (or (Math-anglep (car b)) (eq (car b) 'date) + (and (eq (car (car b)) 'intv) (math-intv-constp (car b))) + (math-infinitep (car b))) + (math-min-list (math-min a (car b)) (cdr b)) + (math-reject-arg (car b) 'anglep)) + a) +) + +;;; Compute the maximum of two real numbers. [R R R] [Public] +(defun math-max (a b) + (if (or (and (consp a) (eq (car a) 'intv)) + (and (consp b) (eq (car b) 'intv))) + (math-neg (math-min (math-neg a) (math-neg b))) + (let ((res (math-compare a b))) + (if (= res -1) + b + (if (= res 2) + '(var nan var-nan) + a)))) +) + +(defun calcFunc-max (&optional a &rest b) + (if (not a) + '(neg (var inf var-inf)) + (if (not (or (Math-anglep a) (eq (car a) 'date) + (and (eq (car a) 'intv) (math-intv-constp a)) + (math-infinitep a))) + (math-reject-arg a 'anglep)) + (math-max-list a b)) +) + +(defun math-max-list (a b) + (if b + (if (or (Math-anglep (car b)) (eq (car b) 'date) + (and (eq (car (car b)) 'intv) (math-intv-constp (car b))) + (math-infinitep (car b))) + (math-max-list (math-max a (car b)) (cdr b)) + (math-reject-arg (car b) 'anglep)) + a) +) + + +;;; Compute the absolute value of A. [O O; r r] [Public] +(defun math-abs (a) + (cond ((Math-negp a) + (math-neg a)) + ((Math-anglep a) + a) + ((eq (car a) 'cplx) + (math-hypot (nth 1 a) (nth 2 a))) + ((eq (car a) 'polar) + (nth 1 a)) + ((eq (car a) 'vec) + (if (cdr (cdr (cdr a))) + (math-sqrt (calcFunc-abssqr a)) + (if (cdr (cdr a)) + (math-hypot (nth 1 a) (nth 2 a)) + (if (cdr a) + (math-abs (nth 1 a)) + a)))) + ((eq (car a) 'sdev) + (list 'sdev (math-abs (nth 1 a)) (nth 2 a))) + ((and (eq (car a) 'intv) (math-intv-constp a)) + (if (Math-posp a) + a + (let* ((nlo (math-neg (nth 2 a))) + (res (math-compare nlo (nth 3 a)))) + (cond ((= res 1) + (math-make-intv (if (memq (nth 1 a) '(0 1)) 2 3) 0 nlo)) + ((= res 0) + (math-make-intv (if (eq (nth 1 a) 0) 2 3) 0 nlo)) + (t + (math-make-intv (if (memq (nth 1 a) '(0 2)) 2 3) + 0 (nth 3 a))))))) + ((math-looks-negp a) + (list 'calcFunc-abs (math-neg a))) + ((let ((signs (math-possible-signs a))) + (or (and (memq signs '(2 4 6)) a) + (and (memq signs '(1 3)) (math-neg a))))) + ((let ((inf (math-infinitep a))) + (and inf + (if (equal inf '(var nan var-nan)) + inf + '(var inf var-inf))))) + (t (calc-record-why 'numvecp a) + (list 'calcFunc-abs a))) +) +(fset 'calcFunc-abs (symbol-function 'math-abs)) + + +(defun math-float-fancy (a) + (cond ((eq (car a) 'intv) + (cons (car a) (cons (nth 1 a) (mapcar 'math-float (nthcdr 2 a))))) + ((and (memq (car a) '(* /)) + (math-numberp (nth 1 a))) + (list (car a) (math-float (nth 1 a)) + (list 'calcFunc-float (nth 2 a)))) + ((and (eq (car a) '/) + (eq (car (nth 1 a)) '*) + (math-numberp (nth 1 (nth 1 a)))) + (list '* (math-float (nth 1 (nth 1 a))) + (list 'calcFunc-float (list '/ (nth 2 (nth 1 a)) (nth 2 a))))) + ((math-infinitep a) a) + ((eq (car a) 'calcFunc-float) a) + ((let ((func (assq (car a) '((calcFunc-floor . calcFunc-ffloor) + (calcFunc-ceil . calcFunc-fceil) + (calcFunc-trunc . calcFunc-ftrunc) + (calcFunc-round . calcFunc-fround) + (calcFunc-rounde . calcFunc-frounde) + (calcFunc-roundu . calcFunc-froundu))))) + (and func (cons (cdr func) (cdr a))))) + (t (math-reject-arg a 'objectp))) +) +(fset 'calcFunc-float (symbol-function 'math-float)) + + +(defun math-trunc-fancy (a) + (cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a))) + ((eq (car a) 'cplx) (math-trunc (nth 1 a))) + ((eq (car a) 'polar) (math-trunc (math-complex a))) + ((eq (car a) 'hms) (list 'hms (nth 1 a) 0 0)) + ((eq (car a) 'date) (list 'date (math-trunc (nth 1 a)))) + ((eq (car a) 'mod) + (if (math-messy-integerp (nth 2 a)) + (math-trunc (math-make-mod (nth 1 a) (math-trunc (nth 2 a)))) + (math-make-mod (math-trunc (nth 1 a)) (nth 2 a)))) + ((eq (car a) 'intv) + (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf))) + (memq (nth 1 a) '(0 1))) + 0 2) + (if (and (equal (nth 3 a) '(var inf var-inf)) + (memq (nth 1 a) '(0 2))) + 0 1)) + (if (and (Math-negp (nth 2 a)) + (Math-num-integerp (nth 2 a)) + (memq (nth 1 a) '(0 1))) + (math-add (math-trunc (nth 2 a)) 1) + (math-trunc (nth 2 a))) + (if (and (Math-posp (nth 3 a)) + (Math-num-integerp (nth 3 a)) + (memq (nth 1 a) '(0 2))) + (math-add (math-trunc (nth 3 a)) -1) + (math-trunc (nth 3 a))))) + ((math-provably-integerp a) a) + ((Math-vectorp a) + (math-map-vec (function (lambda (x) (math-trunc x prec))) a)) + ((math-infinitep a) + (if (or (math-posp a) (math-negp a)) + a + '(var nan var-nan))) + ((math-to-integer a)) + (t (math-reject-arg a 'numberp))) +) + +(defun math-trunc-special (a prec) + (if (Math-messy-integerp prec) + (setq prec (math-trunc prec))) + (or (integerp prec) + (math-reject-arg prec 'fixnump)) + (if (and (<= prec 0) + (math-provably-integerp a)) + a + (calcFunc-scf (math-trunc (let ((calc-prefer-frac t)) + (calcFunc-scf a prec))) + (- prec))) +) + +(defun math-to-integer (a) + (let ((func (assq (car-safe a) '((calcFunc-ffloor . calcFunc-floor) + (calcFunc-fceil . calcFunc-ceil) + (calcFunc-ftrunc . calcFunc-trunc) + (calcFunc-fround . calcFunc-round) + (calcFunc-frounde . calcFunc-rounde) + (calcFunc-froundu . calcFunc-roundu))))) + (and func (= (length a) 2) + (cons (cdr func) (cdr a)))) +) + +(defun calcFunc-ftrunc (a &optional prec) + (if (and (Math-messy-integerp a) + (or (not prec) (and (integerp prec) + (<= prec 0)))) + a + (math-float (math-trunc a prec))) +) + +(defun math-floor-fancy (a) + (cond ((math-provably-integerp a) a) + ((eq (car a) 'hms) + (if (or (math-posp a) + (and (math-zerop (nth 2 a)) + (math-zerop (nth 3 a)))) + (math-trunc a) + (math-add (math-trunc a) -1))) + ((eq (car a) 'date) (list 'date (math-floor (nth 1 a)))) + ((eq (car a) 'intv) + (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf))) + (memq (nth 1 a) '(0 1))) + 0 2) + (if (and (equal (nth 3 a) '(var inf var-inf)) + (memq (nth 1 a) '(0 2))) + 0 1)) + (math-floor (nth 2 a)) + (if (and (Math-num-integerp (nth 3 a)) + (memq (nth 1 a) '(0 2))) + (math-add (math-floor (nth 3 a)) -1) + (math-floor (nth 3 a))))) + ((Math-vectorp a) + (math-map-vec (function (lambda (x) (math-floor x prec))) a)) + ((math-infinitep a) + (if (or (math-posp a) (math-negp a)) + a + '(var nan var-nan))) + ((math-to-integer a)) + (t (math-reject-arg a 'anglep))) +) + +(defun math-floor-special (a prec) + (if (Math-messy-integerp prec) + (setq prec (math-trunc prec))) + (or (integerp prec) + (math-reject-arg prec 'fixnump)) + (if (and (<= prec 0) + (math-provably-integerp a)) + a + (calcFunc-scf (math-floor (let ((calc-prefer-frac t)) + (calcFunc-scf a prec))) + (- prec))) +) + +(defun calcFunc-ffloor (a &optional prec) + (if (and (Math-messy-integerp a) + (or (not prec) (and (integerp prec) + (<= prec 0)))) + a + (math-float (math-floor a prec))) +) + +;;; Coerce A to be an integer (by truncation toward plus infinity). [I N] +(defun math-ceiling (a &optional prec) ; [Public] + (cond (prec + (if (Math-messy-integerp prec) + (setq prec (math-trunc prec))) + (or (integerp prec) + (math-reject-arg prec 'fixnump)) + (if (and (<= prec 0) + (math-provably-integerp a)) + a + (calcFunc-scf (math-ceiling (let ((calc-prefer-frac t)) + (calcFunc-scf a prec))) + (- prec)))) + ((Math-integerp a) a) + ((Math-messy-integerp a) (math-trunc a)) + ((Math-realp a) + (if (Math-posp a) + (math-add (math-trunc a) 1) + (math-trunc a))) + ((math-provably-integerp a) a) + ((eq (car a) 'hms) + (if (or (math-negp a) + (and (math-zerop (nth 2 a)) + (math-zerop (nth 3 a)))) + (math-trunc a) + (math-add (math-trunc a) 1))) + ((eq (car a) 'date) (list 'date (math-ceiling (nth 1 a)))) + ((eq (car a) 'intv) + (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf))) + (memq (nth 1 a) '(0 1))) + 0 2) + (if (and (equal (nth 3 a) '(var inf var-inf)) + (memq (nth 1 a) '(0 2))) + 0 1)) + (if (and (Math-num-integerp (nth 2 a)) + (memq (nth 1 a) '(0 1))) + (math-add (math-floor (nth 2 a)) 1) + (math-ceiling (nth 2 a))) + (math-ceiling (nth 3 a)))) + ((Math-vectorp a) + (math-map-vec (function (lambda (x) (math-ceiling x prec))) a)) + ((math-infinitep a) + (if (or (math-posp a) (math-negp a)) + a + '(var nan var-nan))) + ((math-to-integer a)) + (t (math-reject-arg a 'anglep))) +) +(fset 'calcFunc-ceil (symbol-function 'math-ceiling)) + +(defun calcFunc-fceil (a &optional prec) + (if (and (Math-messy-integerp a) + (or (not prec) (and (integerp prec) + (<= prec 0)))) + a + (math-float (math-ceiling a prec))) +) + +(setq math-rounding-mode nil) + +;;; Coerce A to be an integer (by rounding to nearest integer). [I N] [Public] +(defun math-round (a &optional prec) + (cond (prec + (if (Math-messy-integerp prec) + (setq prec (math-trunc prec))) + (or (integerp prec) + (math-reject-arg prec 'fixnump)) + (if (and (<= prec 0) + (math-provably-integerp a)) + a + (calcFunc-scf (math-round (let ((calc-prefer-frac t)) + (calcFunc-scf a prec))) + (- prec)))) + ((Math-anglep a) + (if (Math-num-integerp a) + (math-trunc a) + (if (and (Math-negp a) (not (eq math-rounding-mode 'up))) + (math-neg (math-round (math-neg a))) + (setq a (let ((calc-angle-mode 'deg)) ; in case of HMS forms + (math-add a (if (Math-ratp a) + '(frac 1 2) + '(float 5 -1))))) + (if (and (Math-num-integerp a) (eq math-rounding-mode 'even)) + (progn + (setq a (math-floor a)) + (or (math-evenp a) + (setq a (math-sub a 1))) + a) + (math-floor a))))) + ((math-provably-integerp a) a) + ((eq (car a) 'date) (list 'date (math-round (nth 1 a)))) + ((eq (car a) 'intv) + (math-floor (math-add a '(frac 1 2)))) + ((Math-vectorp a) + (math-map-vec (function (lambda (x) (math-round x prec))) a)) + ((math-infinitep a) + (if (or (math-posp a) (math-negp a)) + a + '(var nan var-nan))) + ((math-to-integer a)) + (t (math-reject-arg a 'anglep))) +) +(fset 'calcFunc-round (symbol-function 'math-round)) + +(defun calcFunc-rounde (a &optional prec) + (let ((math-rounding-mode 'even)) + (math-round a prec)) +) + +(defun calcFunc-roundu (a &optional prec) + (let ((math-rounding-mode 'up)) + (math-round a prec)) +) + +(defun calcFunc-fround (a &optional prec) + (if (and (Math-messy-integerp a) + (or (not prec) (and (integerp prec) + (<= prec 0)))) + a + (math-float (math-round a prec))) +) + +(defun calcFunc-frounde (a &optional prec) + (let ((math-rounding-mode 'even)) + (calcFunc-fround a prec)) +) + +(defun calcFunc-froundu (a &optional prec) + (let ((math-rounding-mode 'up)) + (calcFunc-fround a prec)) +) + + +;;; Pull floating-point values apart into mantissa and exponent. +(defun calcFunc-mant (x) + (if (Math-realp x) + (if (or (Math-ratp x) + (eq (nth 1 x) 0)) + x + (list 'float (nth 1 x) (- 1 (math-numdigs (nth 1 x))))) + (calc-record-why 'realp x) + (list 'calcFunc-mant x)) +) + +(defun calcFunc-xpon (x) + (if (Math-realp x) + (if (or (Math-ratp x) + (eq (nth 1 x) 0)) + 0 + (math-normalize (+ (nth 2 x) (1- (math-numdigs (nth 1 x)))))) + (calc-record-why 'realp x) + (list 'calcFunc-xpon x)) +) + +(defun calcFunc-scf (x n) + (if (integerp n) + (cond ((eq n 0) + x) + ((Math-integerp x) + (if (> n 0) + (math-scale-int x n) + (math-div x (math-scale-int 1 (- n))))) + ((eq (car x) 'frac) + (if (> n 0) + (math-make-frac (math-scale-int (nth 1 x) n) (nth 2 x)) + (math-make-frac (nth 1 x) (math-scale-int (nth 2 x) (- n))))) + ((eq (car x) 'float) + (math-make-float (nth 1 x) (+ (nth 2 x) n))) + ((memq (car x) '(cplx sdev)) + (math-normalize + (list (car x) + (calcFunc-scf (nth 1 x) n) + (calcFunc-scf (nth 2 x) n)))) + ((memq (car x) '(polar mod)) + (math-normalize + (list (car x) + (calcFunc-scf (nth 1 x) n) + (nth 2 x)))) + ((eq (car x) 'intv) + (math-normalize + (list (car x) + (nth 1 x) + (calcFunc-scf (nth 2 x) n) + (calcFunc-scf (nth 3 x) n)))) + ((eq (car x) 'vec) + (math-map-vec (function (lambda (x) (calcFunc-scf x n))) x)) + ((math-infinitep x) + x) + (t + (calc-record-why 'realp x) + (list 'calcFunc-scf x n))) + (if (math-messy-integerp n) + (if (< (nth 2 n) 10) + (calcFunc-scf x (math-trunc n)) + (math-overflow n)) + (if (math-integerp n) + (math-overflow n) + (calc-record-why 'integerp n) + (list 'calcFunc-scf x n)))) +) + + +(defun calcFunc-incr (x &optional step relative-to) + (or step (setq step 1)) + (cond ((not (Math-integerp step)) + (math-reject-arg step 'integerp)) + ((Math-integerp x) + (math-add x step)) + ((eq (car x) 'float) + (if (and (math-zerop x) + (eq (car-safe relative-to) 'float)) + (math-mul step + (calcFunc-scf relative-to (- 1 calc-internal-prec))) + (math-add-float x (math-make-float + step + (+ (nth 2 x) + (- (math-numdigs (nth 1 x)) + calc-internal-prec)))))) + ((eq (car x) 'date) + (if (Math-integerp (nth 1 x)) + (math-add x step) + (math-add x (list 'hms 0 0 step)))) + (t + (math-reject-arg x 'realp))) +) + +(defun calcFunc-decr (x &optional step relative-to) + (calcFunc-incr x (math-neg (or step 1)) relative-to) +) + + +(defun calcFunc-percent (x) + (if (math-objectp x) + (let ((calc-prefer-frac nil)) + (math-div x 100)) + (list 'calcFunc-percent x)) +) + +(defun calcFunc-relch (x y) + (if (and (math-objectp x) (math-objectp y)) + (math-div (math-sub y x) x) + (list 'calcFunc-relch x y)) +) + + + +;;; Compute the absolute value squared of A. [F N] [Public] +(defun calcFunc-abssqr (a) + (cond ((Math-realp a) + (math-mul a a)) + ((eq (car a) 'cplx) + (math-add (math-sqr (nth 1 a)) + (math-sqr (nth 2 a)))) + ((eq (car a) 'polar) + (math-sqr (nth 1 a))) + ((and (memq (car a) '(sdev intv)) (math-constp a)) + (math-sqr (math-abs a))) + ((eq (car a) 'vec) + (math-reduce-vec 'math-add (math-map-vec 'calcFunc-abssqr a))) + ((math-known-realp a) + (math-pow a 2)) + ((let ((inf (math-infinitep a))) + (and inf + (math-mul (calcFunc-abssqr (math-infinite-dir a inf)) inf)))) + (t (calc-record-why 'numvecp a) + (list 'calcFunc-abssqr a))) +) +(defun math-sqr (a) + (math-mul a a) +) + + +;;;; Number theory. + +(defun calcFunc-idiv (a b) ; [I I I] [Public] + (cond ((and (Math-natnump a) (Math-natnump b) (not (eq b 0))) + (math-quotient a b)) + ((Math-realp a) + (if (Math-realp b) + (let ((calc-prefer-frac t)) + (math-floor (math-div a b))) + (math-reject-arg b 'realp))) + ((eq (car-safe a) 'hms) + (if (eq (car-safe b) 'hms) + (let ((calc-prefer-frac t)) + (math-floor (math-div a b))) + (math-reject-arg b 'hmsp))) + ((and (or (eq (car-safe a) 'intv) (Math-realp a)) + (or (eq (car-safe b) 'intv) (Math-realp b))) + (math-floor (math-div a b))) + ((or (math-infinitep a) + (math-infinitep b)) + (math-div a b)) + (t (math-reject-arg a 'anglep))) +) + + +;;; Combine two terms being added, if possible. +(defun math-combine-sum (a b nega negb scalar-okay) + (if (and scalar-okay (Math-objvecp a) (Math-objvecp b)) + (math-add-or-sub a b nega negb) + (let ((amult 1) (bmult 1)) + (and (consp a) + (cond ((and (eq (car a) '*) + (Math-objectp (nth 1 a))) + (setq amult (nth 1 a) + a (nth 2 a))) + ((and (eq (car a) '/) + (Math-objectp (nth 2 a))) + (setq amult (if (Math-integerp (nth 2 a)) + (list 'frac 1 (nth 2 a)) + (math-div 1 (nth 2 a))) + a (nth 1 a))) + ((eq (car a) 'neg) + (setq amult -1 + a (nth 1 a))))) + (and (consp b) + (cond ((and (eq (car b) '*) + (Math-objectp (nth 1 b))) + (setq bmult (nth 1 b) + b (nth 2 b))) + ((and (eq (car b) '/) + (Math-objectp (nth 2 b))) + (setq bmult (if (Math-integerp (nth 2 b)) + (list 'frac 1 (nth 2 b)) + (math-div 1 (nth 2 b))) + b (nth 1 b))) + ((eq (car b) 'neg) + (setq bmult -1 + b (nth 1 b))))) + (and (if math-simplifying + (Math-equal a b) + (equal a b)) + (progn + (if nega (setq amult (math-neg amult))) + (if negb (setq bmult (math-neg bmult))) + (setq amult (math-add amult bmult)) + (math-mul amult a))))) +) + +(defun math-add-or-sub (a b aneg bneg) + (if aneg (setq a (math-neg a))) + (if bneg (setq b (math-neg b))) + (if (or (Math-vectorp a) (Math-vectorp b)) + (math-normalize (list '+ a b)) + (math-add a b)) +) + +;;; The following is expanded out four ways for speed. +(defun math-combine-prod (a b inva invb scalar-okay) + (cond + ((or (and inva (Math-zerop a)) + (and invb (Math-zerop b))) + nil) + ((and scalar-okay (Math-objvecp a) (Math-objvecp b)) + (setq a (math-mul-or-div a b inva invb)) + (and (Math-objvecp a) + a)) + ((and (eq (car-safe a) '^) + inva + (math-looks-negp (nth 2 a))) + (math-mul (math-pow (nth 1 a) (math-neg (nth 2 a))) b)) + ((and (eq (car-safe b) '^) + invb + (math-looks-negp (nth 2 b))) + (math-mul a (math-pow (nth 1 b) (math-neg (nth 2 b))))) + (t (let ((apow 1) (bpow 1)) + (and (consp a) + (cond ((and (eq (car a) '^) + (or math-simplifying + (Math-numberp (nth 2 a)))) + (setq apow (nth 2 a) + a (nth 1 a))) + ((eq (car a) 'calcFunc-sqrt) + (setq apow '(frac 1 2) + a (nth 1 a))) + ((and (eq (car a) 'calcFunc-exp) + (or math-simplifying + (Math-numberp (nth 1 a)))) + (setq apow (nth 1 a) + a math-combine-prod-e)))) + (and (consp a) (eq (car a) 'frac) + (Math-lessp (nth 1 a) (nth 2 a)) + (setq a (math-div 1 a) apow (math-neg apow))) + (and (consp b) + (cond ((and (eq (car b) '^) + (or math-simplifying + (Math-numberp (nth 2 b)))) + (setq bpow (nth 2 b) + b (nth 1 b))) + ((eq (car b) 'calcFunc-sqrt) + (setq bpow '(frac 1 2) + b (nth 1 b))) + ((and (eq (car b) 'calcFunc-exp) + (or math-simplifying + (Math-numberp (nth 1 b)))) + (setq bpow (nth 1 b) + b math-combine-prod-e)))) + (and (consp b) (eq (car b) 'frac) + (Math-lessp (nth 1 b) (nth 2 b)) + (setq b (math-div 1 b) bpow (math-neg bpow))) + (if inva (setq apow (math-neg apow))) + (if invb (setq bpow (math-neg bpow))) + (or (and (if math-simplifying + (math-commutative-equal a b) + (equal a b)) + (let ((sumpow (math-add apow bpow))) + (and (or (not (Math-integerp a)) + (Math-zerop sumpow) + (eq (eq (car-safe apow) 'frac) + (eq (car-safe bpow) 'frac))) + (progn + (and (math-looks-negp sumpow) + (Math-ratp a) (Math-posp a) + (setq a (math-div 1 a) + sumpow (math-neg sumpow))) + (cond ((equal sumpow '(frac 1 2)) + (list 'calcFunc-sqrt a)) + ((equal sumpow '(frac -1 2)) + (math-div 1 (list 'calcFunc-sqrt a))) + ((and (eq a math-combine-prod-e) + (eq a b)) + (list 'calcFunc-exp sumpow)) + (t + (condition-case err + (math-pow a sumpow) + (inexact-result (list '^ a sumpow))))))))) + (and math-simplifying-units + math-combining-units + (let* ((ua (math-check-unit-name a)) + ub) + (and ua + (eq ua (setq ub (math-check-unit-name b))) + (progn + (setq ua (if (eq (nth 1 a) (car ua)) + 1 + (nth 1 (assq (aref (symbol-name (nth 1 a)) + 0) + math-unit-prefixes))) + ub (if (eq (nth 1 b) (car ub)) + 1 + (nth 1 (assq (aref (symbol-name (nth 1 b)) + 0) + math-unit-prefixes)))) + (if (Math-lessp ua ub) + (let (temp) + (setq temp a a b b temp + temp ua ua ub ub temp + temp apow apow bpow bpow temp))) + (math-mul (math-pow (math-div ua ub) apow) + (math-pow b (math-add apow bpow))))))) + (and (equal apow bpow) + (Math-natnump a) (Math-natnump b) + (cond ((equal apow '(frac 1 2)) + (list 'calcFunc-sqrt (math-mul a b))) + ((equal apow '(frac -1 2)) + (math-div 1 (list 'calcFunc-sqrt (math-mul a b)))) + (t + (setq a (math-mul a b)) + (condition-case err + (math-pow a apow) + (inexact-result (list '^ a apow)))))))))) +) +(setq math-combine-prod-e '(var e var-e)) + +(defun math-mul-or-div (a b ainv binv) + (if (or (Math-vectorp a) (Math-vectorp b)) + (math-normalize + (if ainv + (if binv + (list '/ (math-div 1 a) b) + (list '/ b a)) + (if binv + (list '/ a b) + (list '* a b)))) + (if ainv + (if binv + (math-div (math-div 1 a) b) + (math-div b a)) + (if binv + (math-div a b) + (math-mul a b)))) +) + +(defun math-commutative-equal (a b) + (if (memq (car-safe a) '(+ -)) + (and (memq (car-safe b) '(+ -)) + (let ((bterms nil) aterms p) + (math-commutative-collect b nil) + (setq aterms bterms bterms nil) + (math-commutative-collect a nil) + (and (= (length aterms) (length bterms)) + (progn + (while (and aterms + (progn + (setq p bterms) + (while (and p (not (equal (car aterms) + (car p)))) + (setq p (cdr p))) + p)) + (setq bterms (delq (car p) bterms) + aterms (cdr aterms))) + (not aterms))))) + (equal a b)) +) + +(defun math-commutative-collect (b neg) + (if (eq (car-safe b) '+) + (progn + (math-commutative-collect (nth 1 b) neg) + (math-commutative-collect (nth 2 b) neg)) + (if (eq (car-safe b) '-) + (progn + (math-commutative-collect (nth 1 b) neg) + (math-commutative-collect (nth 2 b) (not neg))) + (setq bterms (cons (if neg (math-neg b) b) bterms)))) +) + + diff --git a/lisp/calc/calc-bin.el b/lisp/calc/calc-bin.el new file mode 100644 index 0000000000..23c682a0da --- /dev/null +++ b/lisp/calc/calc-bin.el @@ -0,0 +1,847 @@ +;; Calculator for GNU Emacs, part II [calc-bin.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-bin () nil) + + +;;; b-prefix binary commands. + +(defun calc-and (n) + (interactive "P") + (calc-slow-wrapper + (calc-enter-result 2 "and" + (append '(calcFunc-and) + (calc-top-list-n 2) + (and n (list (prefix-numeric-value n)))))) +) + +(defun calc-or (n) + (interactive "P") + (calc-slow-wrapper + (calc-enter-result 2 "or" + (append '(calcFunc-or) + (calc-top-list-n 2) + (and n (list (prefix-numeric-value n)))))) +) + +(defun calc-xor (n) + (interactive "P") + (calc-slow-wrapper + (calc-enter-result 2 "xor" + (append '(calcFunc-xor) + (calc-top-list-n 2) + (and n (list (prefix-numeric-value n)))))) +) + +(defun calc-diff (n) + (interactive "P") + (calc-slow-wrapper + (calc-enter-result 2 "diff" + (append '(calcFunc-diff) + (calc-top-list-n 2) + (and n (list (prefix-numeric-value n)))))) +) + +(defun calc-not (n) + (interactive "P") + (calc-slow-wrapper + (calc-enter-result 1 "not" + (append '(calcFunc-not) + (calc-top-list-n 1) + (and n (list (prefix-numeric-value n)))))) +) + +(defun calc-lshift-binary (n) + (interactive "P") + (calc-slow-wrapper + (let ((hyp (if (calc-is-hyperbolic) 2 1))) + (calc-enter-result hyp "lsh" + (append '(calcFunc-lsh) + (calc-top-list-n hyp) + (and n (list (prefix-numeric-value n))))))) +) + +(defun calc-rshift-binary (n) + (interactive "P") + (calc-slow-wrapper + (let ((hyp (if (calc-is-hyperbolic) 2 1))) + (calc-enter-result hyp "rsh" + (append '(calcFunc-rsh) + (calc-top-list-n hyp) + (and n (list (prefix-numeric-value n))))))) +) + +(defun calc-lshift-arith (n) + (interactive "P") + (calc-slow-wrapper + (let ((hyp (if (calc-is-hyperbolic) 2 1))) + (calc-enter-result hyp "ash" + (append '(calcFunc-ash) + (calc-top-list-n hyp) + (and n (list (prefix-numeric-value n))))))) +) + +(defun calc-rshift-arith (n) + (interactive "P") + (calc-slow-wrapper + (let ((hyp (if (calc-is-hyperbolic) 2 1))) + (calc-enter-result hyp "rash" + (append '(calcFunc-rash) + (calc-top-list-n hyp) + (and n (list (prefix-numeric-value n))))))) +) + +(defun calc-rotate-binary (n) + (interactive "P") + (calc-slow-wrapper + (let ((hyp (if (calc-is-hyperbolic) 2 1))) + (calc-enter-result hyp "rot" + (append '(calcFunc-rot) + (calc-top-list-n hyp) + (and n (list (prefix-numeric-value n))))))) +) + +(defun calc-clip (n) + (interactive "P") + (calc-slow-wrapper + (calc-enter-result 1 "clip" + (append '(calcFunc-clip) + (calc-top-list-n 1) + (and n (list (prefix-numeric-value n)))))) +) + +(defun calc-word-size (n) + (interactive "P") + (calc-wrapper + (or n (setq n (read-string (format "Binary word size: (default %d) " + calc-word-size)))) + (setq n (if (stringp n) + (if (equal n "") + calc-word-size + (if (string-match "\\`[-+]?[0-9]+\\'" n) + (string-to-int n) + (error "Expected an integer"))) + (prefix-numeric-value n))) + (or (= n calc-word-size) + (if (> (math-abs n) 100) + (calc-change-mode 'calc-word-size n calc-leading-zeros) + (calc-change-mode '(calc-word-size calc-previous-modulo) + (list n (math-power-of-2 (math-abs n))) + calc-leading-zeros))) + (if (< n 0) + (message "Binary word size is %d bits (2's complement)." (- n)) + (message "Binary word size is %d bits." n))) +) + + + + + +;;; d-prefix mode commands. + +(defun calc-radix (n) + (interactive "NDisplay radix (2-36): ") + (calc-wrapper + (if (and (>= n 2) (<= n 36)) + (progn + (calc-change-mode 'calc-number-radix n t) + ;; also change global value so minibuffer sees it + (setq-default calc-number-radix calc-number-radix)) + (setq n calc-number-radix)) + (message "Number radix is %d." n)) +) + +(defun calc-decimal-radix () + (interactive) + (calc-radix 10) +) + +(defun calc-binary-radix () + (interactive) + (calc-radix 2) +) + +(defun calc-octal-radix () + (interactive) + (calc-radix 8) +) + +(defun calc-hex-radix () + (interactive) + (calc-radix 16) +) + +(defun calc-leading-zeros (n) + (interactive "P") + (calc-wrapper + (if (calc-change-mode 'calc-leading-zeros n t t) + (message "Zero-padding integers to %d digits (assuming radix %d)." + (let* ((calc-internal-prec 6)) + (math-compute-max-digits (math-abs calc-word-size) + calc-number-radix)) + calc-number-radix) + (message "Omitting leading zeros on integers."))) +) + + +(defvar math-power-of-2-cache (list 1 2 4 8 16 32 64 128 256 512 1024)) +(defvar math-big-power-of-2-cache nil) +(defun math-power-of-2 (n) ; [I I] [Public] + (if (and (natnump n) (<= n 100)) + (or (nth n math-power-of-2-cache) + (let* ((i (length math-power-of-2-cache)) + (val (nth (1- i) math-power-of-2-cache))) + (while (<= i n) + (setq val (math-mul val 2) + math-power-of-2-cache (nconc math-power-of-2-cache + (list val)) + i (1+ i))) + val)) + (let ((found (assq n math-big-power-of-2-cache))) + (if found + (cdr found) + (let ((po2 (math-ipow 2 n))) + (setq math-big-power-of-2-cache + (cons (cons n po2) math-big-power-of-2-cache)) + po2)))) +) + +(defun math-integer-log2 (n) ; [I I] [Public] + (let ((i 0) + (p math-power-of-2-cache) + val) + (while (and p (Math-natnum-lessp (setq val (car p)) n)) + (setq p (cdr p) + i (1+ i))) + (if p + (and (equal val n) + i) + (while (Math-natnum-lessp + (prog1 + (setq val (math-mul val 2)) + (setq math-power-of-2-cache (nconc math-power-of-2-cache + (list val)))) + n) + (setq i (1+ i))) + (and (equal val n) + i))) +) + + + + +;;; Bitwise operations. + +(defun calcFunc-and (a b &optional w) ; [I I I] [Public] + (cond ((Math-messy-integerp w) + (calcFunc-and a b (math-trunc w))) + ((and w (not (integerp w))) + (math-reject-arg w 'fixnump)) + ((and (integerp a) (integerp b)) + (math-clip (logand a b) w)) + ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) + (math-binary-modulo-args 'calcFunc-and a b w)) + ((not (Math-num-integerp a)) + (math-reject-arg a 'integerp)) + ((not (Math-num-integerp b)) + (math-reject-arg b 'integerp)) + (t (math-clip (cons 'bigpos + (math-and-bignum (math-binary-arg a w) + (math-binary-arg b w))) + w))) +) + +(defun math-binary-arg (a w) + (if (not (Math-integerp a)) + (setq a (math-trunc a))) + (if (Math-integer-negp a) + (math-not-bignum (cdr (math-bignum-test (math-sub -1 a))) + (math-abs (if w (math-trunc w) calc-word-size))) + (cdr (Math-bignum-test a))) +) + +(defun math-binary-modulo-args (f a b w) + (let (mod) + (if (eq (car-safe a) 'mod) + (progn + (setq mod (nth 2 a) + a (nth 1 a)) + (if (eq (car-safe b) 'mod) + (if (equal mod (nth 2 b)) + (setq b (nth 1 b)) + (math-reject-arg b "*Inconsistent modulos")))) + (setq mod (nth 2 b) + b (nth 1 b))) + (if (Math-messy-integerp mod) + (setq mod (math-trunc mod)) + (or (Math-integerp mod) + (math-reject-arg mod 'integerp))) + (let ((bits (math-integer-log2 mod))) + (if bits + (if w + (if (/= w bits) + (calc-record-why + "*Warning: Modulo inconsistent with word size")) + (setq w bits)) + (calc-record-why "*Warning: Modulo is not a power of 2")) + (math-make-mod (if b + (funcall f a b w) + (funcall f a w)) + mod))) +) + +(defun math-and-bignum (a b) ; [l l l] + (and a b + (let ((qa (math-div-bignum-digit a 512)) + (qb (math-div-bignum-digit b 512))) + (math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa)) + (math-norm-bignum (car qb))) + 512 + (logand (cdr qa) (cdr qb))))) +) + +(defun calcFunc-or (a b &optional w) ; [I I I] [Public] + (cond ((Math-messy-integerp w) + (calcFunc-or a b (math-trunc w))) + ((and w (not (integerp w))) + (math-reject-arg w 'fixnump)) + ((and (integerp a) (integerp b)) + (math-clip (logior a b) w)) + ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) + (math-binary-modulo-args 'calcFunc-or a b w)) + ((not (Math-num-integerp a)) + (math-reject-arg a 'integerp)) + ((not (Math-num-integerp b)) + (math-reject-arg b 'integerp)) + (t (math-clip (cons 'bigpos + (math-or-bignum (math-binary-arg a w) + (math-binary-arg b w))) + w))) +) + +(defun math-or-bignum (a b) ; [l l l] + (and (or a b) + (let ((qa (math-div-bignum-digit a 512)) + (qb (math-div-bignum-digit b 512))) + (math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa)) + (math-norm-bignum (car qb))) + 512 + (logior (cdr qa) (cdr qb))))) +) + +(defun calcFunc-xor (a b &optional w) ; [I I I] [Public] + (cond ((Math-messy-integerp w) + (calcFunc-xor a b (math-trunc w))) + ((and w (not (integerp w))) + (math-reject-arg w 'fixnump)) + ((and (integerp a) (integerp b)) + (math-clip (logxor a b) w)) + ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) + (math-binary-modulo-args 'calcFunc-xor a b w)) + ((not (Math-num-integerp a)) + (math-reject-arg a 'integerp)) + ((not (Math-num-integerp b)) + (math-reject-arg b 'integerp)) + (t (math-clip (cons 'bigpos + (math-xor-bignum (math-binary-arg a w) + (math-binary-arg b w))) + w))) +) + +(defun math-xor-bignum (a b) ; [l l l] + (and (or a b) + (let ((qa (math-div-bignum-digit a 512)) + (qb (math-div-bignum-digit b 512))) + (math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa)) + (math-norm-bignum (car qb))) + 512 + (logxor (cdr qa) (cdr qb))))) +) + +(defun calcFunc-diff (a b &optional w) ; [I I I] [Public] + (cond ((Math-messy-integerp w) + (calcFunc-diff a b (math-trunc w))) + ((and w (not (integerp w))) + (math-reject-arg w 'fixnump)) + ((and (integerp a) (integerp b)) + (math-clip (logand a (lognot b)) w)) + ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) + (math-binary-modulo-args 'calcFunc-diff a b w)) + ((not (Math-num-integerp a)) + (math-reject-arg a 'integerp)) + ((not (Math-num-integerp b)) + (math-reject-arg b 'integerp)) + (t (math-clip (cons 'bigpos + (math-diff-bignum (math-binary-arg a w) + (math-binary-arg b w))) + w))) +) + +(defun math-diff-bignum (a b) ; [l l l] + (and a + (let ((qa (math-div-bignum-digit a 512)) + (qb (math-div-bignum-digit b 512))) + (math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa)) + (math-norm-bignum (car qb))) + 512 + (logand (cdr qa) (lognot (cdr qb)))))) +) + +(defun calcFunc-not (a &optional w) ; [I I] [Public] + (cond ((Math-messy-integerp w) + (calcFunc-not a (math-trunc w))) + ((eq (car-safe a) 'mod) + (math-binary-modulo-args 'calcFunc-not a nil w)) + ((and w (not (integerp w))) + (math-reject-arg w 'fixnump)) + ((not (Math-num-integerp a)) + (math-reject-arg a 'integerp)) + ((< (or w (setq w calc-word-size)) 0) + (math-clip (calcFunc-not a (- w)) w)) + (t (math-normalize + (cons 'bigpos + (math-not-bignum (math-binary-arg a w) + w))))) +) + +(defun math-not-bignum (a w) ; [l l] + (let ((q (math-div-bignum-digit a 512))) + (if (<= w 9) + (list (logand (lognot (cdr q)) + (1- (lsh 1 w)))) + (math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q)) + (- w 9)) + 512 + (logxor (cdr q) 511)))) +) + +(defun calcFunc-lsh (a &optional n w) ; [I I] [Public] + (setq a (math-trunc a) + n (if n (math-trunc n) 1)) + (if (eq (car-safe a) 'mod) + (math-binary-modulo-args 'calcFunc-lsh a n w) + (setq w (if w (math-trunc w) calc-word-size)) + (or (integerp w) + (math-reject-arg w 'fixnump)) + (or (Math-integerp a) + (math-reject-arg a 'integerp)) + (or (Math-integerp n) + (math-reject-arg n 'integerp)) + (if (< w 0) + (math-clip (calcFunc-lsh a n (- w)) w) + (if (Math-integer-negp a) + (setq a (math-clip a w))) + (cond ((or (Math-lessp n (- w)) + (Math-lessp w n)) + 0) + ((< n 0) + (math-quotient (math-clip a w) (math-power-of-2 (- n)))) + (t + (math-clip (math-mul a (math-power-of-2 n)) w))))) +) + +(defun calcFunc-rsh (a &optional n w) ; [I I] [Public] + (calcFunc-lsh a (math-neg (or n 1)) w) +) + +(defun calcFunc-ash (a &optional n w) ; [I I] [Public] + (if (or (null n) + (not (Math-negp n))) + (calcFunc-lsh a n w) + (setq a (math-trunc a) + n (if n (math-trunc n) 1)) + (if (eq (car-safe a) 'mod) + (math-binary-modulo-args 'calcFunc-ash a n w) + (setq w (if w (math-trunc w) calc-word-size)) + (or (integerp w) + (math-reject-arg w 'fixnump)) + (or (Math-integerp a) + (math-reject-arg a 'integerp)) + (or (Math-integerp n) + (math-reject-arg n 'integerp)) + (if (< w 0) + (math-clip (calcFunc-ash a n (- w)) w) + (if (Math-integer-negp a) + (setq a (math-clip a w))) + (let ((two-to-sizem1 (math-power-of-2 (1- w))) + (sh (calcFunc-lsh a n w))) + (cond ((Math-natnum-lessp a two-to-sizem1) + sh) + ((Math-lessp n (- 1 w)) + (math-add (math-mul two-to-sizem1 2) -1)) + (t (let ((two-to-n (math-power-of-2 (- n)))) + (math-add (calcFunc-lsh (math-add two-to-n -1) + (+ w n) w) + sh)))))))) +) + +(defun calcFunc-rash (a &optional n w) ; [I I] [Public] + (calcFunc-ash a (math-neg (or n 1)) w) +) + +(defun calcFunc-rot (a &optional n w) ; [I I] [Public] + (setq a (math-trunc a) + n (if n (math-trunc n) 1)) + (if (eq (car-safe a) 'mod) + (math-binary-modulo-args 'calcFunc-rot a n w) + (setq w (if w (math-trunc w) calc-word-size)) + (or (integerp w) + (math-reject-arg w 'fixnump)) + (or (Math-integerp a) + (math-reject-arg a 'integerp)) + (or (Math-integerp n) + (math-reject-arg n 'integerp)) + (if (< w 0) + (math-clip (calcFunc-rot a n (- w)) w) + (if (Math-integer-negp a) + (setq a (math-clip a w))) + (cond ((or (Math-integer-negp n) + (not (Math-natnum-lessp n w))) + (calcFunc-rot a (math-mod n w) w)) + (t + (math-add (calcFunc-lsh a (- n w) w) + (calcFunc-lsh a n w)))))) +) + +(defun math-clip (a &optional w) ; [I I] [Public] + (cond ((Math-messy-integerp w) + (math-clip a (math-trunc w))) + ((eq (car-safe a) 'mod) + (math-binary-modulo-args 'math-clip a nil w)) + ((and w (not (integerp w))) + (math-reject-arg w 'fixnump)) + ((not (Math-num-integerp a)) + (math-reject-arg a 'integerp)) + ((< (or w (setq w calc-word-size)) 0) + (setq a (math-clip a (- w))) + (if (Math-natnum-lessp a (math-power-of-2 (- -1 w))) + a + (math-sub a (math-power-of-2 (- w))))) + ((Math-negp a) + (math-normalize (cons 'bigpos (math-binary-arg a w)))) + ((and (integerp a) (< a 1000000)) + (if (>= w 20) + a + (logand a (1- (lsh 1 w))))) + (t + (math-normalize + (cons 'bigpos + (math-clip-bignum (cdr (math-bignum-test (math-trunc a))) + w))))) +) +(fset 'calcFunc-clip (symbol-function 'math-clip)) + +(defun math-clip-bignum (a w) ; [l l] + (let ((q (math-div-bignum-digit a 512))) + (if (<= w 9) + (list (logand (cdr q) + (1- (lsh 1 w)))) + (math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q)) + (- w 9)) + 512 + (cdr q)))) +) + + + + +(defvar math-max-digits-cache nil) +(defun math-compute-max-digits (w r) + (let* ((pair (+ (* r 100000) w)) + (res (assq pair math-max-digits-cache))) + (if res + (cdr res) + (let* ((calc-command-flags nil) + (digs (math-ceiling (math-div w (math-real-log2 r))))) + (setq math-max-digits-cache (cons (cons pair digs) + math-max-digits-cache)) + digs))) +) + +(defvar math-log2-cache (list '(2 . 1) + '(4 . 2) + '(8 . 3) + '(10 . (float 332193 -5)) + '(16 . 4) + '(32 . 5))) +(defun math-real-log2 (x) ;;; calc-internal-prec must be 6 + (let ((res (assq x math-log2-cache))) + (if res + (cdr res) + (let* ((calc-symbolic-mode nil) + (calc-display-working-message nil) + (log (calcFunc-log x 2))) + (setq math-log2-cache (cons (cons x log) math-log2-cache)) + log))) +) + +(defconst math-radix-digits ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" + "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" + "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" + "U" "V" "W" "X" "Y" "Z"]) + +(defun math-format-radix (a) ; [X S] + (if (< a calc-number-radix) + (if (< a 0) + (concat "-" (math-format-radix (- a))) + (math-format-radix-digit a)) + (let ((s "")) + (while (> a 0) + (setq s (concat (math-format-radix-digit (% a calc-number-radix)) s) + a (/ a calc-number-radix))) + s)) +) + +(defconst math-binary-digits ["000" "001" "010" "011" + "100" "101" "110" "111"]) +(defun math-format-binary (a) ; [X S] + (if (< a 8) + (if (< a 0) + (concat "-" (math-format-binary (- a))) + (math-format-radix a)) + (let ((s "")) + (while (> a 7) + (setq s (concat (aref math-binary-digits (% a 8)) s) + a (/ a 8))) + (concat (math-format-radix a) s))) +) + +(defun math-format-bignum-radix (a) ; [X L] + (cond ((null a) "0") + ((and (null (cdr a)) + (< (car a) calc-number-radix)) + (math-format-radix-digit (car a))) + (t + (let ((q (math-div-bignum-digit a calc-number-radix))) + (concat (math-format-bignum-radix (math-norm-bignum (car q))) + (math-format-radix-digit (cdr q)))))) +) + +(defun math-format-bignum-binary (a) ; [X L] + (cond ((null a) "0") + ((null (cdr a)) + (math-format-binary (car a))) + (t + (let ((q (math-div-bignum-digit a 512))) + (concat (math-format-bignum-binary (math-norm-bignum (car q))) + (aref math-binary-digits (/ (cdr q) 64)) + (aref math-binary-digits (% (/ (cdr q) 8) 8)) + (aref math-binary-digits (% (cdr q) 8)))))) +) + +(defun math-format-bignum-octal (a) ; [X L] + (cond ((null a) "0") + ((null (cdr a)) + (math-format-radix (car a))) + (t + (let ((q (math-div-bignum-digit a 512))) + (concat (math-format-bignum-octal (math-norm-bignum (car q))) + (math-format-radix-digit (/ (cdr q) 64)) + (math-format-radix-digit (% (/ (cdr q) 8) 8)) + (math-format-radix-digit (% (cdr q) 8)))))) +) + +(defun math-format-bignum-hex (a) ; [X L] + (cond ((null a) "0") + ((null (cdr a)) + (math-format-radix (car a))) + (t + (let ((q (math-div-bignum-digit a 256))) + (concat (math-format-bignum-hex (math-norm-bignum (car q))) + (math-format-radix-digit (/ (cdr q) 16)) + (math-format-radix-digit (% (cdr q) 16)))))) +) + +;;; Decompose into integer and fractional parts, without depending +;;; on calc-internal-prec. +(defun math-float-parts (a need-frac) ; returns ( int frac fracdigs ) + (if (>= (nth 2 a) 0) + (list (math-scale-rounding (nth 1 a) (nth 2 a)) '(float 0 0) 0) + (let* ((d (math-numdigs (nth 1 a))) + (n (- (nth 2 a)))) + (if need-frac + (if (>= n d) + (list 0 a n) + (let ((qr (math-idivmod (nth 1 a) (math-scale-int 1 n)))) + (list (car qr) (math-make-float (cdr qr) (- n)) n))) + (list (math-scale-rounding (nth 1 a) (nth 2 a)) + '(float 0 0) 0)))) +) + +(defun math-format-radix-float (a prec) + (let ((fmt (car calc-float-format)) + (figs (nth 1 calc-float-format)) + (point calc-point-char) + (str nil)) + (if (eq fmt 'fix) + (let* ((afigs (math-abs figs)) + (fp (math-float-parts a (> afigs 0))) + (calc-internal-prec (+ 3 (max (nth 2 fp) + (math-convert-radix-digits + afigs t)))) + (int (car fp)) + (frac (math-round (math-mul (math-normalize (nth 1 fp)) + (math-radix-float-power afigs))))) + (if (not (and (math-zerop frac) (math-zerop int) (< figs 0))) + (let ((math-radix-explicit-format nil)) + (let ((calc-group-digits nil)) + (setq str (if (> afigs 0) (math-format-number frac) "")) + (if (< (length str) afigs) + (setq str (concat (make-string (- afigs (length str)) ?0) + str)) + (if (> (length str) afigs) + (setq str (substring str 1) + int (math-add int 1)))) + (setq str (concat (math-format-number int) point str))) + (if calc-group-digits + (setq str (math-group-float str)))) + (setq figs 0)))) + (or str + (let* ((prec calc-internal-prec) + (afigs (if (> figs 0) + figs + (max 1 (+ figs + (1- (math-convert-radix-digits + (max prec + (math-numdigs (nth 1 a))))))))) + (calc-internal-prec (+ 3 (math-convert-radix-digits afigs t))) + (explo -1) (vlo (math-radix-float-power explo)) + (exphi 1) (vhi (math-radix-float-power exphi)) + expmid vmid eadj) + (setq a (math-normalize a)) + (if (Math-zerop a) + (setq explo 0) + (if (math-lessp-float '(float 1 0) a) + (while (not (math-lessp-float a vhi)) + (setq explo exphi vlo vhi + exphi (math-mul exphi 2) + vhi (math-radix-float-power exphi))) + (while (math-lessp-float a vlo) + (setq exphi explo vhi vlo + explo (math-mul explo 2) + vlo (math-radix-float-power explo)))) + (while (not (eq (math-sub exphi explo) 1)) + (setq expmid (math-div2 (math-add explo exphi)) + vmid (math-radix-float-power expmid)) + (if (math-lessp-float a vmid) + (setq exphi expmid vhi vmid) + (setq explo expmid vlo vmid))) + (setq a (math-div-float a vlo))) + (let* ((sc (math-round (math-mul a (math-radix-float-power + (1- afigs))))) + (math-radix-explicit-format nil)) + (let ((calc-group-digits nil)) + (setq str (math-format-number sc)))) + (if (> (length str) afigs) + (setq str (substring str 0 -1) + explo (1+ explo))) + (if (and (eq fmt 'float) + (math-lessp explo (+ (if (= figs 0) + (1- (math-convert-radix-digits + prec)) + afigs) + calc-display-sci-high 1)) + (math-lessp calc-display-sci-low explo)) + (let ((dpos (1+ explo))) + (cond ((<= dpos 0) + (setq str (concat "0" point (make-string (- dpos) ?0) + str))) + ((> dpos (length str)) + (setq str (concat str (make-string (- dpos (length str)) + ?0) point))) + (t + (setq str (concat (substring str 0 dpos) point + (substring str dpos))))) + (setq explo nil)) + (setq eadj (if (eq fmt 'eng) + (min (math-mod explo 3) (length str)) + 0) + str (concat (substring str 0 (1+ eadj)) point + (substring str (1+ eadj))))) + (setq pos (length str)) + (while (eq (aref str (1- pos)) ?0) (setq pos (1- pos))) + (and explo (eq (aref str (1- pos)) ?.) (setq pos (1- pos))) + (setq str (substring str 0 pos)) + (if calc-group-digits + (setq str (math-group-float str))) + (if explo + (let ((estr (let ((calc-number-radix 10) + (calc-group-digits nil)) + (setq estr (math-format-number + (math-sub explo eadj)))))) + (setq str (if (or (memq calc-language '(math maple)) + (> calc-number-radix 14)) + (format "%s*%d.^%s" str calc-number-radix estr) + (format "%se%s" str estr))))))) + str) +) + +(defun math-convert-radix-digits (n &optional to-dec) + (let ((key (cons n (cons to-dec calc-number-radix)))) + (or (cdr (assoc key math-radix-digits-cache)) + (let* ((calc-internal-prec 6) + (log (math-div (math-real-log2 calc-number-radix) + '(float 332193 -5)))) + (cdr (car (setq math-radix-digits-cache + (cons (cons key (math-ceiling (if to-dec + (math-mul n log) + (math-div n log)))) + math-radix-digits-cache))))))) +) +(setq math-radix-digits-cache nil) + +(defun math-radix-float-power (n) + (if (eq n 0) + '(float 1 0) + (or (and (eq calc-number-radix (car math-radix-float-cache-tag)) + (<= calc-internal-prec (cdr math-radix-float-cache-tag))) + (setq math-radix-float-cache-tag (cons calc-number-radix + calc-internal-prec) + math-radix-float-cache nil)) + (math-normalize + (or (cdr (assoc n math-radix-float-cache)) + (cdr (car (setq math-radix-float-cache + (cons (cons + n + (let ((calc-internal-prec + (cdr math-radix-float-cache-tag))) + (if (math-negp n) + (math-div-float '(float 1 0) + (math-radix-float-power + (math-neg n))) + (math-mul-float (math-sqr-float + (math-radix-float-power + (math-div2 n))) + (if (math-evenp n) + '(float 1 0) + (math-float + calc-number-radix)))))) + math-radix-float-cache))))))) +) +(setq math-radix-float-cache-tag nil) + diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el new file mode 100644 index 0000000000..f80bce9459 --- /dev/null +++ b/lisp/calc/calc-comb.el @@ -0,0 +1,1056 @@ +;; Calculator for GNU Emacs, part II [calc-comb.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-comb () nil) + + +;;; Combinatorics + +(defun calc-gcd (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "gcd" 'calcFunc-gcd arg)) +) + +(defun calc-lcm (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "lcm" 'calcFunc-lcm arg)) +) + +(defun calc-extended-gcd () + (interactive) + (calc-slow-wrapper + (calc-enter-result 2 "egcd" (cons 'calcFunc-egcd (calc-top-list-n 2)))) +) + +(defun calc-factorial (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "fact" 'calcFunc-fact arg)) +) + +(defun calc-gamma (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "gmma" 'calcFunc-gamma arg)) +) + +(defun calc-double-factorial (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "dfac" 'calcFunc-dfact arg)) +) + +(defun calc-choose (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-binary-op "perm" 'calcFunc-perm arg) + (calc-binary-op "chos" 'calcFunc-choose arg))) +) + +(defun calc-perm (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-choose arg) +) + +(defvar calc-last-random-limit '(float 1 0)) +(defun calc-random (n) + (interactive "P") + (calc-slow-wrapper + (if n + (calc-enter-result 0 "rand" (list 'calcFunc-random + (calc-get-random-limit + (prefix-numeric-value n)))) + (calc-enter-result 1 "rand" (list 'calcFunc-random + (calc-get-random-limit + (calc-top-n 1)))))) +) + +(defun calc-get-random-limit (val) + (if (eq val 0) + calc-last-random-limit + (setq calc-last-random-limit val)) +) + +(defun calc-rrandom () + (interactive) + (calc-slow-wrapper + (setq calc-last-random-limit '(float 1 0)) + (calc-enter-result 0 "rand" (list 'calcFunc-random '(float 1 0)))) +) + +(defun calc-random-again (arg) + (interactive "p") + (calc-slow-wrapper + (while (>= (setq arg (1- arg)) 0) + (calc-enter-result 0 "rand" (list 'calcFunc-random + calc-last-random-limit)))) +) + +(defun calc-shuffle (n) + (interactive "P") + (calc-slow-wrapper + (if n + (calc-enter-result 1 "shuf" (list 'calcFunc-shuffle + (prefix-numeric-value n) + (calc-get-random-limit + (calc-top-n 1)))) + (calc-enter-result 2 "shuf" (list 'calcFunc-shuffle + (calc-top-n 1) + (calc-get-random-limit + (calc-top-n 2)))))) +) + +(defun calc-report-prime-test (res) + (cond ((eq (car res) t) + (calc-record-message "prim" "Prime (guaranteed)")) + ((eq (car res) nil) + (if (cdr res) + (if (eq (nth 1 res) 'unknown) + (calc-record-message + "prim" "Non-prime (factors unknown)") + (calc-record-message + "prim" "Non-prime (%s is a factor)" + (math-format-number (nth 1 res)))) + (calc-record-message "prim" "Non-prime"))) + (t + (calc-record-message + "prim" "Probably prime (%d iters; %s%% chance of error)" + (nth 1 res) + (let ((calc-float-format '(fix 2))) + (math-format-number (nth 2 res)))))) +) + +(defun calc-prime-test (iters) + (interactive "p") + (calc-slow-wrapper + (let* ((n (calc-top-n 1)) + (res (math-prime-test n iters))) + (calc-report-prime-test res))) +) + +(defun calc-next-prime (iters) + (interactive "p") + (calc-slow-wrapper + (let ((calc-verbose-nextprime t)) + (if (calc-is-inverse) + (calc-enter-result 1 "prvp" (list 'calcFunc-prevprime + (calc-top-n 1) (math-abs iters))) + (calc-enter-result 1 "nxtp" (list 'calcFunc-nextprime + (calc-top-n 1) (math-abs iters)))))) +) + +(defun calc-prev-prime (iters) + (interactive "p") + (calc-invert-func) + (calc-next-prime iters) +) + +(defun calc-prime-factors (iters) + (interactive "p") + (calc-slow-wrapper + (let ((res (calcFunc-prfac (calc-top-n 1)))) + (if (not math-prime-factors-finished) + (calc-record-message "pfac" "Warning: May not be fully factored")) + (calc-enter-result 1 "pfac" res))) +) + +(defun calc-totient (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "phi" 'calcFunc-totient arg)) +) + +(defun calc-moebius (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "mu" 'calcFunc-moebius arg)) +) + + + + + +(defun calcFunc-gcd (a b) + (if (Math-messy-integerp a) + (setq a (math-trunc a))) + (if (Math-messy-integerp b) + (setq b (math-trunc b))) + (cond ((and (Math-integerp a) (Math-integerp b)) + (math-gcd a b)) + ((Math-looks-negp a) + (calcFunc-gcd (math-neg a) b)) + ((Math-looks-negp b) + (calcFunc-gcd a (math-neg b))) + ((Math-zerop a) b) + ((Math-zerop b) a) + ((and (Math-ratp a) + (Math-ratp b)) + (math-make-frac (math-gcd (if (eq (car-safe a) 'frac) (nth 1 a) a) + (if (eq (car-safe b) 'frac) (nth 1 b) b)) + (calcFunc-lcm + (if (eq (car-safe a) 'frac) (nth 2 a) 1) + (if (eq (car-safe b) 'frac) (nth 2 b) 1)))) + ((not (Math-integerp a)) + (calc-record-why 'integerp a) + (list 'calcFunc-gcd a b)) + (t + (calc-record-why 'integerp b) + (list 'calcFunc-gcd a b))) +) + +(defun calcFunc-lcm (a b) + (let ((g (calcFunc-gcd a b))) + (if (Math-numberp g) + (math-div (math-mul a b) g) + (list 'calcFunc-lcm a b))) +) + +(defun calcFunc-egcd (a b) ; Knuth section 4.5.2 + (cond + ((not (Math-integerp a)) + (if (Math-messy-integerp a) + (calcFunc-egcd (math-trunc a) b) + (calc-record-why 'integerp a) + (list 'calcFunc-egcd a b))) + ((not (Math-integerp b)) + (if (Math-messy-integerp b) + (calcFunc-egcd a (math-trunc b)) + (calc-record-why 'integerp b) + (list 'calcFunc-egcd a b))) + (t + (let ((u1 1) (u2 0) (u3 a) + (v1 0) (v2 1) (v3 b) + t1 t2 q) + (while (not (eq v3 0)) + (setq q (math-idivmod u3 v3) + t1 (math-sub u1 (math-mul v1 (car q))) + t2 (math-sub u2 (math-mul v2 (car q))) + u1 v1 u2 v2 u3 v3 + v1 t1 v2 t2 v3 (cdr q))) + (list 'vec u3 u1 u2)))) +) + + +;;; Factorial and related functions. + +(defun calcFunc-fact (n) ; [I I] [F F] [Public] + (let (temp) + (cond ((Math-integer-negp n) + (if calc-infinite-mode + '(var uinf var-uinf) + (math-reject-arg n 'range))) + ((integerp n) + (if (<= n 20) + (aref '[1 1 2 6 24 120 720 5040 40320 362880 + (bigpos 800 628 3) (bigpos 800 916 39) + (bigpos 600 1 479) (bigpos 800 20 227 6) + (bigpos 200 291 178 87) (bigpos 0 368 674 307 1) + (bigpos 0 888 789 922 20) (bigpos 0 96 428 687 355) + (bigpos 0 728 705 373 402 6) + (bigpos 0 832 408 100 645 121) + (bigpos 0 640 176 8 902 432 2)] n) + (math-factorial-iter (1- n) 2 1))) + ((and (math-messy-integerp n) + (Math-lessp n 100)) + (math-inexact-result) + (setq temp (math-trunc n)) + (if (>= temp 0) + (if (<= temp 20) + (math-float (calcFunc-fact temp)) + (math-with-extra-prec 1 + (math-factorial-iter (1- temp) 2 '(float 1 0)))) + (math-reject-arg n 'range))) + ((math-numberp n) + (let* ((q (math-quarter-integer n)) + (tn (and q (Math-lessp n 1000) (Math-lessp -1000 n) + (1+ (math-floor n))))) + (cond ((and tn (= q 2) + (or calc-symbolic-mode (< (math-abs tn) 20))) + (let ((q (if (< tn 0) + (math-div + (math-pow -2 (- tn)) + (math-double-factorial-iter (* -2 tn) 3 1 2)) + (math-div + (math-double-factorial-iter (* 2 tn) 3 1 2) + (math-pow 2 tn))))) + (math-mul q (if calc-symbolic-mode + (list 'calcFunc-sqrt '(var pi var-pi)) + (math-sqrt-pi))))) + ((and tn (>= tn 0) (< tn 20) + (memq q '(1 3))) + (math-inexact-result) + (math-div + (math-mul (math-double-factorial-iter (* 4 tn) q 1 4) + (if (= q 1) (math-gamma-1q) (math-gamma-3q))) + (math-pow 4 tn))) + (t + (math-inexact-result) + (math-with-extra-prec 3 + (math-gammap1-raw (math-float n))))))) + ((equal n '(var inf var-inf)) n) + (t (calc-record-why 'numberp n) + (list 'calcFunc-fact n)))) +) + +(math-defcache math-gamma-1q nil + (math-with-extra-prec 3 + (math-gammap1-raw '(float -75 -2)))) + +(math-defcache math-gamma-3q nil + (math-with-extra-prec 3 + (math-gammap1-raw '(float -25 -2)))) + +(defun math-factorial-iter (count n f) + (if (= (% n 5) 1) + (math-working (format "factorial(%d)" (1- n)) f)) + (if (> count 0) + (math-factorial-iter (1- count) (1+ n) (math-mul n f)) + f) +) + +(defun calcFunc-dfact (n) ; [I I] [F F] [Public] + (cond ((Math-integer-negp n) + (if (math-oddp n) + (if (eq n -1) + 1 + (math-div (if (eq (math-mod n 4) 3) 1 -1) + (calcFunc-dfact (math-sub -2 n)))) + (list 'calcFunc-dfact n))) + ((Math-zerop n) 1) + ((integerp n) (math-double-factorial-iter n (+ 2 (% n 2)) 1 2)) + ((math-messy-integerp n) + (let ((temp (math-trunc n))) + (math-inexact-result) + (if (natnump temp) + (if (Math-lessp temp 200) + (math-with-extra-prec 1 + (math-double-factorial-iter temp (+ 2 (% temp 2)) + '(float 1 0) 2)) + (let* ((half (math-div2 temp)) + (even (math-mul (math-pow 2 half) + (calcFunc-fact (math-float half))))) + (if (math-evenp temp) + even + (math-div (calcFunc-fact n) even)))) + (list 'calcFunc-dfact max)))) + ((equal n '(var inf var-inf)) n) + (t (calc-record-why 'natnump n) + (list 'calcFunc-dfact n))) +) + +(defun math-double-factorial-iter (max n f step) + (if (< (% n 12) step) + (math-working (format "dfact(%d)" (- n step)) f)) + (if (<= n max) + (math-double-factorial-iter max (+ n step) (math-mul n f) step) + f) +) + +(defun calcFunc-perm (n m) ; [I I I] [F F F] [Public] + (cond ((and (integerp n) (integerp m) (<= m n) (>= m 0)) + (math-factorial-iter m (1+ (- n m)) 1)) + ((or (not (math-num-integerp n)) + (and (math-messy-integerp n) (Math-lessp 100 n)) + (not (math-num-integerp m)) + (and (math-messy-integerp m) (Math-lessp 100 m))) + (or (math-realp n) (equal n '(var inf var-inf)) + (math-reject-arg n 'realp)) + (or (math-realp m) (equal m '(var inf var-inf)) + (math-reject-arg m 'realp)) + (and (math-num-integerp n) (math-negp n) (math-reject-arg n 'range)) + (and (math-num-integerp m) (math-negp m) (math-reject-arg m 'range)) + (math-div (calcFunc-fact n) (calcFunc-fact (math-sub n m)))) + (t + (let ((tn (math-trunc n)) + (tm (math-trunc m))) + (math-inexact-result) + (or (integerp tn) (math-reject-arg tn 'fixnump)) + (or (integerp tm) (math-reject-arg tm 'fixnump)) + (or (and (<= tm tn) (>= tm 0)) (math-reject-arg tm 'range)) + (math-with-extra-prec 1 + (math-factorial-iter tm (1+ (- tn tm)) '(float 1 0)))))) +) + +(defun calcFunc-choose (n m) ; [I I I] [F F F] [Public] + (cond ((and (integerp n) (integerp m) (<= m n) (>= m 0)) + (if (> m (/ n 2)) + (math-choose-iter (- n m) n 1 1) + (math-choose-iter m n 1 1))) + ((not (math-realp n)) + (math-reject-arg n 'realp)) + ((not (math-realp m)) + (math-reject-arg m 'realp)) + ((not (math-num-integerp m)) + (if (and (math-num-integerp n) (math-negp n)) + (list 'calcFunc-choose n m) + (math-div (calcFunc-fact (math-float n)) + (math-mul (calcFunc-fact m) + (calcFunc-fact (math-sub n m)))))) + ((math-negp m) 0) + ((math-negp n) + (let ((val (calcFunc-choose (math-add (math-add n m) -1) m))) + (if (math-evenp (math-trunc m)) + val + (math-neg val)))) + ((and (math-num-integerp n) + (Math-lessp n m)) + 0) + (t + (math-inexact-result) + (let ((tm (math-trunc m))) + (or (integerp tm) (math-reject-arg tm 'fixnump)) + (if (> tm 100) + (math-div (calcFunc-fact (math-float n)) + (math-mul (calcFunc-fact (math-float m)) + (calcFunc-fact (math-float + (math-sub n m))))) + (math-with-extra-prec 1 + (math-choose-float-iter tm n 1 1)))))) +) + +(defun math-choose-iter (m n i c) + (if (and (= (% i 5) 1) (> i 5)) + (math-working (format "choose(%d)" (1- i)) c)) + (if (<= i m) + (math-choose-iter m (1- n) (1+ i) + (math-quotient (math-mul c n) i)) + c) +) + +(defun math-choose-float-iter (count n i c) + (if (= (% i 5) 1) + (math-working (format "choose(%d)" (1- i)) c)) + (if (> count 0) + (math-choose-float-iter (1- count) (math-sub n 1) (1+ i) + (math-div (math-mul c n) i)) + c) +) + + +;;; Stirling numbers. + +(defun calcFunc-stir1 (n m) + (math-stirling-number n m 1) +) + +(defun calcFunc-stir2 (n m) + (math-stirling-number n m 0) +) + +(defun math-stirling-number (n m k) + (or (math-num-natnump n) (math-reject-arg n 'natnump)) + (or (math-num-natnump m) (math-reject-arg m 'natnump)) + (if (consp n) (setq n (math-trunc n))) + (or (integerp n) (math-reject-arg n 'fixnump)) + (if (consp m) (setq m (math-trunc m))) + (or (integerp m) (math-reject-arg m 'fixnump)) + (if (< n m) + 0 + (let ((cache (aref math-stirling-cache k))) + (while (<= (length cache) n) + (let ((i (1- (length cache))) + row) + (setq cache (vconcat cache (make-vector (length cache) nil))) + (aset math-stirling-cache k cache) + (while (< (setq i (1+ i)) (length cache)) + (aset cache i (setq row (make-vector (1+ i) nil))) + (aset row 0 0) + (aset row i 1)))) + (if (= k 1) + (math-stirling-1 n m) + (math-stirling-2 n m)))) +) +(setq math-stirling-cache (vector [[1]] [[1]])) + +(defun math-stirling-1 (n m) + (or (aref (aref cache n) m) + (aset (aref cache n) m + (math-add (math-stirling-1 (1- n) (1- m)) + (math-mul (- 1 n) (math-stirling-1 (1- n) m))))) +) + +(defun math-stirling-2 (n m) + (or (aref (aref cache n) m) + (aset (aref cache n) m + (math-add (math-stirling-2 (1- n) (1- m)) + (math-mul m (math-stirling-2 (1- n) m))))) +) + + +;;; Produce a random 10-bit integer, with (random) if no seed provided, +;;; or else with Numerical Recipes algorithm ran3 / Knuth 3.2.2-A. +(defun math-init-random-base () + (if (and (boundp 'var-RandSeed) var-RandSeed) + (if (eq (car-safe var-RandSeed) 'vec) + nil + (if (Math-integerp var-RandSeed) + (let* ((seed (math-sub 161803 var-RandSeed)) + (mj (1+ (math-mod seed '(bigpos 0 0 1)))) + (mk (1+ (math-mod (math-quotient seed '(bigpos 0 0 1)) + '(bigpos 0 0 1)))) + (i 0)) + (setq math-random-table (cons 'vec (make-list 55 mj))) + (while (<= (setq i (1+ i)) 54) + (let* ((ii (% (* i 21) 55)) + (p (nthcdr ii math-random-table))) + (setcar p mk) + (setq mk (- mj mk) + mj (car p))))) + (math-reject-arg var-RandSeed "*RandSeed must be an integer")) + (setq var-RandSeed (list 'vec var-RandSeed) + math-random-ptr1 math-random-table + math-random-cache nil + math-random-ptr2 (nthcdr 31 math-random-table)) + (let ((i 200)) + (while (> (setq i (1- i)) 0) + (math-random-base)))) + (random t) + (setq var-RandSeed nil + math-random-cache nil + i 0 + math-random-shift -4) ; assume RAND_MAX >= 16383 + ;; This exercises the random number generator and also helps + ;; deduce a better value for RAND_MAX. + (while (< (setq i (1+ i)) 30) + (if (> (lsh (math-abs (random)) math-random-shift) 4095) + (setq math-random-shift (1- math-random-shift))))) + (setq math-last-RandSeed var-RandSeed + math-gaussian-cache nil) +) + +(defun math-random-base () + (if var-RandSeed + (progn + (setq math-random-ptr1 (or (cdr math-random-ptr1) + (cdr math-random-table)) + math-random-ptr2 (or (cdr math-random-ptr2) + (cdr math-random-table))) + (logand (lsh (setcar math-random-ptr1 + (logand (- (car math-random-ptr1) + (car math-random-ptr2)) 524287)) + -6) 1023)) + (logand (lsh (random) math-random-shift) 1023)) +) +(setq math-random-table nil) +(setq math-last-RandSeed nil) +(setq math-random-ptr1 nil) +(setq math-random-ptr2 nil) +(setq math-random-shift nil) + + +;;; Produce a random digit in the range 0..999. +;;; Avoid various pitfalls that may lurk in the built-in (random) function! +;;; Shuffling algorithm from Numerical Recipes, section 7.1. +(defun math-random-digit () + (let (i) + (or (and (boundp 'var-RandSeed) (eq var-RandSeed math-last-RandSeed)) + (math-init-random-base)) + (or math-random-cache + (progn + (setq math-random-last (math-random-base) + math-random-cache (make-vector 13 nil) + i -1) + (while (< (setq i (1+ i)) 13) + (aset math-random-cache i (math-random-base))))) + (while (progn + (setq i (/ math-random-last 79) ; 0 <= i < 13 + math-random-last (aref math-random-cache i)) + (aset math-random-cache i (math-random-base)) + (>= math-random-last 1000))) + math-random-last) +) +(setq math-random-cache nil) + +;;; Produce an N-digit random integer. +(defun math-random-digits (n) + (cond ((<= n 6) + (math-scale-right (+ (* (math-random-digit) 1000) (math-random-digit)) + (- 6 n))) + (t (let* ((slop (% (- 900003 n) 3)) + (i (/ (+ n slop) 3)) + (digs nil)) + (while (> i 0) + (setq digs (cons (math-random-digit) digs) + i (1- i))) + (math-normalize (math-scale-right (cons 'bigpos digs) + slop))))) +) + +;;; Produce a uniformly-distributed random float 0 <= N < 1. +(defun math-random-float () + (math-make-float (math-random-digits calc-internal-prec) + (- calc-internal-prec)) +) + +;;; Produce a Gaussian-distributed random float with mean=0, sigma=1. +(defun math-gaussian-float () + (math-with-extra-prec 2 + (if (and math-gaussian-cache + (= (car math-gaussian-cache) calc-internal-prec)) + (prog1 + (cdr math-gaussian-cache) + (setq math-gaussian-cache nil)) + (let* ((v1 (math-add (math-mul (math-random-float) 2) -1)) + (v2 (math-add (math-mul (math-random-float) 2) -1)) + (r (math-add (math-sqr v1) (math-sqr v2)))) + (while (or (not (Math-lessp r 1)) (math-zerop r)) + (setq v1 (math-add (math-mul (math-random-float) 2) -1) + v2 (math-add (math-mul (math-random-float) 2) -1) + r (math-add (math-sqr v1) (math-sqr v2)))) + (let ((fac (math-sqrt (math-mul (math-div (calcFunc-ln r) r) -2)))) + (setq math-gaussian-cache (cons calc-internal-prec + (math-mul v1 fac))) + (math-mul v2 fac))))) +) +(setq math-gaussian-cache nil) + +;;; Produce a random integer or real 0 <= N < MAX. +(defun calcFunc-random (max) + (cond ((Math-zerop max) + (math-gaussian-float)) + ((Math-integerp max) + (let* ((digs (math-numdigs max)) + (r (math-random-digits (+ digs 3)))) + (math-mod r max))) + ((Math-realp max) + (math-mul (math-random-float) max)) + ((and (eq (car max) 'intv) (math-constp max) + (Math-lessp (nth 2 max) (nth 3 max))) + (if (math-floatp max) + (let ((val (math-add (math-mul (math-random-float) + (math-sub (nth 3 max) (nth 2 max))) + (nth 2 max)))) + (if (or (and (memq (nth 1 max) '(0 1)) ; almost not worth + (Math-equal val (nth 2 max))) ; checking! + (and (memq (nth 1 max) '(0 2)) + (Math-equal val (nth 3 max)))) + (calcFunc-random max) + val)) + (let ((lo (if (memq (nth 1 max) '(0 1)) + (math-add (nth 2 max) 1) (nth 2 max))) + (hi (if (memq (nth 1 max) '(1 3)) + (math-add (nth 3 max) 1) (nth 3 max)))) + (if (Math-lessp lo hi) + (math-add (calcFunc-random (math-sub hi lo)) lo) + (math-reject-arg max "*Empty interval"))))) + ((eq (car max) 'vec) + (if (cdr max) + (nth (1+ (calcFunc-random (1- (length max)))) max) + (math-reject-arg max "*Empty list"))) + ((and (eq (car max) 'sdev) (math-constp max) (Math-realp (nth 1 max))) + (math-add (math-mul (math-gaussian-float) (nth 2 max)) (nth 1 max))) + (t (math-reject-arg max 'realp))) +) + +;;; Choose N objects at random from the set MAX without duplicates. +(defun calcFunc-shuffle (n &optional max) + (or max (setq max n n -1)) + (or (and (Math-num-integerp n) + (or (natnump (setq n (math-trunc n))) (eq n -1))) + (math-reject-arg n 'integerp)) + (cond ((or (math-zerop max) + (math-floatp max) + (eq (car-safe max) 'sdev)) + (if (< n 0) + (math-reject-arg n 'natnump) + (math-simple-shuffle n max))) + ((and (<= n 1) (>= n 0)) + (math-simple-shuffle n max)) + ((and (eq (car-safe max) 'intv) (math-constp max)) + (let ((num (math-add (math-sub (nth 3 max) (nth 2 max)) + (cdr (assq (nth 1 max) + '((0 . -1) (1 . 0) + (2 . 0) (3 . 1)))))) + (min (math-add (nth 2 max) (if (memq (nth 1 max) '(0 1)) + 1 0)))) + (if (< n 0) (setq n num)) + (or (math-posp num) (math-reject-arg max 'range)) + (and (Math-lessp num n) (math-reject-arg n 'range)) + (if (Math-lessp n (math-quotient num 3)) + (math-simple-shuffle n max) + (if (> (* n 4) (* num 3)) + (math-add (math-sub min 1) + (math-shuffle-list n num (calcFunc-index num))) + (let ((tot 0) + (m 0) + (vec nil)) + (while (< m n) + (if (< (calcFunc-random (- num tot)) (- n m)) + (setq vec (cons (math-add min tot) vec) + m (1+ m))) + (setq tot (1+ tot))) + (math-shuffle-list n n (cons 'vec vec))))))) + ((eq (car-safe max) 'vec) + (let ((size (1- (length max)))) + (if (< n 0) (setq n size)) + (if (and (> n (/ size 2)) (<= n size)) + (math-shuffle-list n size (copy-sequence max)) + (let* ((vals (calcFunc-shuffle + n (list 'intv 3 1 (1- (length max))))) + (p vals)) + (while (setq p (cdr p)) + (setcar p (nth (car p) max))) + vals)))) + ((math-integerp max) + (if (math-posp max) + (calcFunc-shuffle n (list 'intv 2 0 max)) + (calcFunc-shuffle n (list 'intv 1 max 0)))) + (t (math-reject-arg max 'realp))) +) + +(defun math-simple-shuffle (n max) + (let ((vec nil) + val) + (while (>= (setq n (1- n)) 0) + (while (math-member (setq val (calcFunc-random max)) vec)) + (setq vec (cons val vec))) + (cons 'vec vec)) +) + +(defun math-shuffle-list (n size vec) + (let ((j size) + k temp + (p vec)) + (while (cdr (setq p (cdr p))) + (setq k (calcFunc-random j) + j (1- j) + temp (nth k p)) + (setcar (nthcdr k p) (car p)) + (setcar p temp)) + (cons 'vec (nthcdr (- size n -1) vec))) +) + +(defun math-member (x list) + (while (and list (not (equal x (car list)))) + (setq list (cdr list))) + list +) + + +;;; Check if the integer N is prime. [X I] +;;; Return (nil) if non-prime, +;;; (nil N) if non-prime with known factor N, +;;; (nil unknown) if non-prime with no known factors, +;;; (t) if prime, +;;; (maybe N P) if probably prime (after N iters with probability P%) +(defun math-prime-test (n iters) + (if (and (Math-vectorp n) (cdr n)) + (setq n (nth (1- (length n)) n))) + (if (Math-messy-integerp n) + (setq n (math-trunc n))) + (let ((res)) + (while (> iters 0) + (setq res + (cond ((and (integerp n) (<= n 5003)) + (list (= (math-next-small-prime n) n))) + ((not (Math-integerp n)) + (error "Argument must be an integer")) + ((Math-integer-negp n) + '(nil)) + ((Math-natnum-lessp n '(bigpos 0 0 8)) + (setq n (math-fixnum n)) + (let ((i -1) v) + (while (and (> (% n (setq v (aref math-primes-table + (setq i (1+ i))))) + 0) + (< (* v v) n))) + (if (= (% n v) 0) + (list nil v) + '(t)))) + ((not (equal n (car math-prime-test-cache))) + (cond ((= (% (nth 1 n) 2) 0) '(nil 2)) + ((= (% (nth 1 n) 5) 0) '(nil 5)) + (t (let ((dig (cdr n)) (sum 0)) + (while dig + (if (cdr dig) + (setq sum (% (+ (+ sum (car dig)) + (* (nth 1 dig) 1000)) + 111111) + dig (cdr (cdr dig))) + (setq sum (% (+ sum (car dig)) 111111) + dig nil))) + (cond ((= (% sum 3) 0) '(nil 3)) + ((= (% sum 7) 0) '(nil 7)) + ((= (% sum 11) 0) '(nil 11)) + ((= (% sum 13) 0) '(nil 13)) + ((= (% sum 37) 0) '(nil 37)) + (t + (setq math-prime-test-cache-k 1 + math-prime-test-cache-q + (math-div2 n) + math-prime-test-cache-nm1 + (math-add n -1)) + (while (math-evenp + math-prime-test-cache-q) + (setq math-prime-test-cache-k + (1+ math-prime-test-cache-k) + math-prime-test-cache-q + (math-div2 + math-prime-test-cache-q))) + (setq iters (1+ iters)) + (list 'maybe + 0 + (math-sub + 100 + (math-div + '(float 232 0) + (math-numdigs n)))))))))) + ((not (eq (car (nth 1 math-prime-test-cache)) 'maybe)) + (nth 1 math-prime-test-cache)) + (t ; Fermat step + (let* ((x (math-add (calcFunc-random (math-add n -2)) 2)) + (y (math-pow-mod x math-prime-test-cache-q n)) + (j 0)) + (while (and (not (eq y 1)) + (not (equal y math-prime-test-cache-nm1)) + (< (setq j (1+ j)) math-prime-test-cache-k)) + (setq y (math-mod (math-mul y y) n))) + (if (or (equal y math-prime-test-cache-nm1) + (and (eq y 1) (eq j 0))) + (list 'maybe + (1+ (nth 1 (nth 1 math-prime-test-cache))) + (math-mul (nth 2 (nth 1 math-prime-test-cache)) + '(float 25 -2))) + '(nil unknown)))))) + (setq math-prime-test-cache (list n res) + iters (if (eq (car res) 'maybe) + (1- iters) + 0))) + res) +) +(defvar math-prime-test-cache '(-1)) + +(defun calcFunc-prime (n &optional iters) + (or (math-num-integerp n) (math-reject-arg n 'integerp)) + (or (not iters) (math-num-integerp iters) (math-reject-arg iters 'integerp)) + (if (car (math-prime-test (math-trunc n) (math-trunc (or iters 1)))) + 1 + 0) +) + +;;; Theory: summing base-10^6 digits modulo 111111 is "casting out 999999s". +;;; Initial probability that N is prime is 1/ln(N) = log10(e)/log10(N). +;;; After culling [2,3,5,7,11,13,37], probability of primality is 5.36 x more. +;;; Initial reported probability of non-primality is thus 100% - this. +;;; Each Fermat step multiplies this probability by 25%. +;;; The Fermat step is algorithm P from Knuth section 4.5.4. + + +(defun calcFunc-prfac (n) + (setq math-prime-factors-finished t) + (if (Math-messy-integerp n) + (setq n (math-trunc n))) + (if (Math-natnump n) + (if (Math-natnum-lessp 2 n) + (let (factors res p (i 0)) + (while (and (not (eq n 1)) + (< i (length math-primes-table))) + (setq p (aref math-primes-table i)) + (while (eq (cdr (setq res (cond ((eq n p) (cons 1 0)) + ((eq n 1) (cons 0 1)) + ((consp n) (math-idivmod n p)) + (t (cons (/ n p) (% n p)))))) + 0) + (math-working "factor" p) + (setq factors (nconc factors (list p)) + n (car res))) + (or (eq n 1) + (Math-natnum-lessp p (car res)) + (setq factors (nconc factors (list n)) + n 1)) + (setq i (1+ i))) + (or (setq math-prime-factors-finished (eq n 1)) + (setq factors (nconc factors (list n)))) + (cons 'vec factors)) + (list 'vec n)) + (if (Math-integerp n) + (if (eq n -1) + (list 'vec n) + (cons 'vec (cons -1 (cdr (calcFunc-prfac (math-neg n)))))) + (calc-record-why 'integerp n) + (list 'calcFunc-prfac n))) +) + +(defun calcFunc-totient (n) + (if (Math-messy-integerp n) + (setq n (math-trunc n))) + (if (Math-natnump n) + (if (Math-natnum-lessp n 2) + (if (Math-negp n) + (calcFunc-totient (math-abs n)) + n) + (let ((factors (cdr (calcFunc-prfac n))) + p) + (if math-prime-factors-finished + (progn + (while factors + (setq p (car factors) + n (math-mul (math-div n p) (math-add p -1))) + (while (equal p (car factors)) + (setq factors (cdr factors)))) + n) + (calc-record-why "*Number too big to factor" n) + (list 'calcFunc-totient n)))) + (calc-record-why 'natnump n) + (list 'calcFunc-totient n)) +) + +(defun calcFunc-moebius (n) + (if (Math-messy-integerp n) + (setq n (math-trunc n))) + (if (and (Math-natnump n) (not (eq n 0))) + (if (Math-natnum-lessp n 2) + (if (Math-negp n) + (calcFunc-moebius (math-abs n)) + 1) + (let ((factors (cdr (calcFunc-prfac n))) + (mu 1)) + (if math-prime-factors-finished + (progn + (while factors + (setq mu (if (equal (car factors) (nth 1 factors)) + 0 (math-neg mu)) + factors (cdr factors))) + mu) + (calc-record-why "Number too big to factor" n) + (list 'calcFunc-moebius n)))) + (calc-record-why 'posintp n) + (list 'calcFunc-moebius n)) +) + + +(defun calcFunc-nextprime (n &optional iters) + (if (Math-integerp n) + (if (Math-integer-negp n) + 2 + (if (and (integerp n) (< n 5003)) + (math-next-small-prime (1+ n)) + (if (math-evenp n) + (setq n (math-add n -1))) + (let (res) + (while (not (car (setq res (math-prime-test + (setq n (math-add n 2)) + (or iters 1)))))) + (if (and calc-verbose-nextprime + (eq (car res) 'maybe)) + (calc-report-prime-test res))) + n)) + (if (Math-realp n) + (calcFunc-nextprime (math-trunc n) iters) + (math-reject-arg n 'integerp))) +) +(setq calc-verbose-nextprime nil) + +(defun calcFunc-prevprime (n &optional iters) + (if (Math-integerp n) + (if (Math-lessp n 4) + 2 + (if (math-evenp n) + (setq n (math-add n 1))) + (let (res) + (while (not (car (setq res (math-prime-test + (setq n (math-add n -2)) + (or iters 1)))))) + (if (and calc-verbose-nextprime + (eq (car res) 'maybe)) + (calc-report-prime-test res))) + n) + (if (Math-realp n) + (calcFunc-prevprime (math-ceiling n) iters) + (math-reject-arg n 'integerp))) +) + +(defun math-next-small-prime (n) + (if (and (integerp n) (> n 2)) + (let ((lo -1) + (hi (length math-primes-table)) + mid) + (while (> (- hi lo) 1) + (if (> n (aref math-primes-table + (setq mid (ash (+ lo hi) -1)))) + (setq lo mid) + (setq hi mid))) + (aref math-primes-table hi)) + 2) +) + +(defconst math-primes-table + [2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 + 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 + 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 + 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 + 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 + 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 + 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 + 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 + 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 + 953 967 971 977 983 991 997 1009 1013 1019 1021 1031 1033 1039 1049 + 1051 1061 1063 1069 1087 1091 1093 1097 1103 1109 1117 1123 1129 1151 + 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249 + 1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361 + 1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459 + 1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559 + 1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657 + 1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759 + 1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877 + 1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997 + 1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089 + 2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213 + 2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311 + 2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411 + 2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543 + 2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663 + 2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741 + 2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851 + 2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969 + 2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089 + 3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221 + 3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331 + 3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461 + 3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557 + 3559 3571 3581 3583 3593 3607 3613 3617 3623 3631 3637 3643 3659 3671 + 3673 3677 3691 3697 3701 3709 3719 3727 3733 3739 3761 3767 3769 3779 + 3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907 + 3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013 + 4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129 + 4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243 + 4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363 + 4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493 + 4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621 + 4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729 + 4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871 + 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973 + 4987 4993 4999 5003]) + + + + diff --git a/lisp/calc/calc-cplx.el b/lisp/calc/calc-cplx.el new file mode 100644 index 0000000000..b24e2a1807 --- /dev/null +++ b/lisp/calc/calc-cplx.el @@ -0,0 +1,377 @@ +;; Calculator for GNU Emacs, part II [calc-cplx.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-cplx () nil) + + +(defun calc-argument (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "arg" 'calcFunc-arg arg)) +) + +(defun calc-re (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "re" 'calcFunc-re arg)) +) + +(defun calc-im (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "im" 'calcFunc-im arg)) +) + + +(defun calc-polar () + (interactive) + (calc-slow-wrapper + (let ((arg (calc-top-n 1))) + (if (or (calc-is-inverse) + (eq (car-safe arg) 'polar)) + (calc-enter-result 1 "p-r" (list 'calcFunc-rect arg)) + (calc-enter-result 1 "r-p" (list 'calcFunc-polar arg))))) +) + + + + +(defun calc-complex-notation () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-complex-format nil t) + (message "Displaying complex numbers in (X,Y) format.")) +) + +(defun calc-i-notation () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-complex-format 'i t) + (message "Displaying complex numbers in X+Yi format.")) +) + +(defun calc-j-notation () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-complex-format 'j t) + (message "Displaying complex numbers in X+Yj format.")) +) + + +(defun calc-polar-mode (n) + (interactive "P") + (calc-wrapper + (if (if n + (> (prefix-numeric-value n) 0) + (eq calc-complex-mode 'cplx)) + (progn + (calc-change-mode 'calc-complex-mode 'polar) + (message "Preferred complex form is polar.")) + (calc-change-mode 'calc-complex-mode 'cplx) + (message "Preferred complex form is rectangular."))) +) + + +;;;; Complex numbers. + +(defun math-normalize-polar (a) + (let ((r (math-normalize (nth 1 a))) + (th (math-normalize (nth 2 a)))) + (cond ((math-zerop r) + '(polar 0 0)) + ((or (math-zerop th)) + r) + ((and (not (eq calc-angle-mode 'rad)) + (or (equal th '(float 18 1)) + (equal th 180))) + (math-neg r)) + ((math-negp r) + (math-neg (list 'polar (math-neg r) th))) + (t + (list 'polar r th)))) +) + + +;;; Coerce A to be complex (rectangular form). [c N] +(defun math-complex (a) + (cond ((eq (car-safe a) 'cplx) a) + ((eq (car-safe a) 'polar) + (if (math-zerop (nth 1 a)) + (nth 1 a) + (let ((sc (calcFunc-sincos (nth 2 a)))) + (list 'cplx + (math-mul (nth 1 a) (nth 1 sc)) + (math-mul (nth 1 a) (nth 2 sc)))))) + (t (list 'cplx a 0))) +) + +;;; Coerce A to be complex (polar form). [c N] +(defun math-polar (a) + (cond ((eq (car-safe a) 'polar) a) + ((math-zerop a) '(polar 0 0)) + (t + (list 'polar + (math-abs a) + (calcFunc-arg a)))) +) + +;;; Multiply A by the imaginary constant i. [N N] [Public] +(defun math-imaginary (a) + (if (and (or (Math-objvecp a) (math-infinitep a)) + (not calc-symbolic-mode)) + (math-mul a + (if (or (eq (car-safe a) 'polar) + (and (not (eq (car-safe a) 'cplx)) + (eq calc-complex-mode 'polar))) + (list 'polar 1 (math-quarter-circle nil)) + '(cplx 0 1))) + (math-mul a '(var i var-i))) +) + + + + +(defun math-want-polar (a b) + (cond ((eq (car-safe a) 'polar) + (if (eq (car-safe b) 'cplx) + (eq calc-complex-mode 'polar) + t)) + ((eq (car-safe a) 'cplx) + (if (eq (car-safe b) 'polar) + (eq calc-complex-mode 'polar) + nil)) + ((eq (car-safe b) 'polar) + t) + ((eq (car-safe b) 'cplx) + nil) + (t (eq calc-complex-mode 'polar))) +) + +;;; Force A to be in the (-pi,pi] or (-180,180] range. +(defun math-fix-circular (a &optional dir) ; [R R] + (cond ((eq (car-safe a) 'hms) + (cond ((and (Math-lessp 180 (nth 1 a)) (not (eq dir 1))) + (math-fix-circular (math-add a '(float -36 1)) -1)) + ((or (Math-lessp -180 (nth 1 a)) (eq dir -1)) + a) + (t + (math-fix-circular (math-add a '(float 36 1)) 1)))) + ((eq calc-angle-mode 'rad) + (cond ((and (Math-lessp (math-pi) a) (not (eq dir 1))) + (math-fix-circular (math-sub a (math-two-pi)) -1)) + ((or (Math-lessp (math-neg (math-pi)) a) (eq dir -1)) + a) + (t + (math-fix-circular (math-add a (math-two-pi)) 1)))) + (t + (cond ((and (Math-lessp '(float 18 1) a) (not (eq dir 1))) + (math-fix-circular (math-add a '(float -36 1)) -1)) + ((or (Math-lessp '(float -18 1) a) (eq dir -1)) + a) + (t + (math-fix-circular (math-add a '(float 36 1)) 1))))) +) + + +;;;; Complex numbers. + +(defun calcFunc-polar (a) ; [C N] [Public] + (cond ((Math-vectorp a) + (math-map-vec 'calcFunc-polar a)) + ((Math-realp a) a) + ((Math-numberp a) + (math-normalize (math-polar a))) + (t (list 'calcFunc-polar a))) +) + +(defun calcFunc-rect (a) ; [N N] [Public] + (cond ((Math-vectorp a) + (math-map-vec 'calcFunc-rect a)) + ((Math-realp a) a) + ((Math-numberp a) + (math-normalize (math-complex a))) + (t (list 'calcFunc-rect a))) +) + +;;; Compute the complex conjugate of A. [O O] [Public] +(defun calcFunc-conj (a) + (let (aa bb) + (cond ((Math-realp a) + a) + ((eq (car a) 'cplx) + (list 'cplx (nth 1 a) (math-neg (nth 2 a)))) + ((eq (car a) 'polar) + (list 'polar (nth 1 a) (math-neg (nth 2 a)))) + ((eq (car a) 'vec) + (math-map-vec 'calcFunc-conj a)) + ((eq (car a) 'calcFunc-conj) + (nth 1 a)) + ((math-known-realp a) + a) + ((and (equal a '(var i var-i)) + (math-imaginary-i)) + (math-neg a)) + ((and (memq (car a) '(+ - * /)) + (progn + (setq aa (calcFunc-conj (nth 1 a)) + bb (calcFunc-conj (nth 2 a))) + (or (not (eq (car-safe aa) 'calcFunc-conj)) + (not (eq (car-safe bb) 'calcFunc-conj))))) + (if (eq (car a) '+) + (math-add aa bb) + (if (eq (car a) '-) + (math-sub aa bb) + (if (eq (car a) '*) + (math-mul aa bb) + (math-div aa bb))))) + ((eq (car a) 'neg) + (math-neg (calcFunc-conj (nth 1 a)))) + ((let ((inf (math-infinitep a))) + (and inf + (math-mul (calcFunc-conj (math-infinite-dir a inf)) inf)))) + (t (calc-record-why 'numberp a) + (list 'calcFunc-conj a)))) +) + + +;;; Compute the complex argument of A. [F N] [Public] +(defun calcFunc-arg (a) + (cond ((Math-anglep a) + (if (math-negp a) (math-half-circle nil) 0)) + ((eq (car-safe a) 'cplx) + (calcFunc-arctan2 (nth 2 a) (nth 1 a))) + ((eq (car-safe a) 'polar) + (nth 2 a)) + ((eq (car a) 'vec) + (math-map-vec 'calcFunc-arg a)) + ((and (equal a '(var i var-i)) + (math-imaginary-i)) + (math-quarter-circle t)) + ((and (equal a '(neg (var i var-i))) + (math-imaginary-i)) + (math-neg (math-quarter-circle t))) + ((let ((signs (math-possible-signs a))) + (or (and (memq signs '(2 4 6)) 0) + (and (eq signs 1) (math-half-circle nil))))) + ((math-infinitep a) + (if (or (equal a '(var uinf var-uinf)) + (equal a '(var nan var-nan))) + '(var nan var-nan) + (calcFunc-arg (math-infinite-dir a)))) + (t (calc-record-why 'numvecp a) + (list 'calcFunc-arg a))) +) + +(defun math-imaginary-i () + (let ((val (calc-var-value 'var-i))) + (or (eq (car-safe val) 'special-const) + (equal val '(cplx 0 1)) + (and (eq (car-safe val) 'polar) + (eq (nth 1 val) 0) + (Math-equal (nth 1 val) (math-quarter-circle nil))))) +) + +;;; Extract the real or complex part of a complex number. [R N] [Public] +;;; Also extracts the real part of a modulo form. +(defun calcFunc-re (a) + (let (aa bb) + (cond ((Math-realp a) a) + ((memq (car a) '(mod cplx)) + (nth 1 a)) + ((eq (car a) 'polar) + (math-mul (nth 1 a) (calcFunc-cos (nth 2 a)))) + ((eq (car a) 'vec) + (math-map-vec 'calcFunc-re a)) + ((math-known-realp a) a) + ((eq (car a) 'calcFunc-conj) + (calcFunc-re (nth 1 a))) + ((and (equal a '(var i var-i)) + (math-imaginary-i)) + 0) + ((and (memq (car a) '(+ - *)) + (progn + (setq aa (calcFunc-re (nth 1 a)) + bb (calcFunc-re (nth 2 a))) + (or (not (eq (car-safe aa) 'calcFunc-re)) + (not (eq (car-safe bb) 'calcFunc-re))))) + (if (eq (car a) '+) + (math-add aa bb) + (if (eq (car a) '-) + (math-sub aa bb) + (math-sub (math-mul aa bb) + (math-mul (calcFunc-im (nth 1 a)) + (calcFunc-im (nth 2 a))))))) + ((and (eq (car a) '/) + (math-known-realp (nth 2 a))) + (math-div (calcFunc-re (nth 1 a)) (nth 2 a))) + ((eq (car a) 'neg) + (math-neg (calcFunc-re (nth 1 a)))) + (t (calc-record-why 'numberp a) + (list 'calcFunc-re a)))) +) + +(defun calcFunc-im (a) + (let (aa bb) + (cond ((Math-realp a) + (if (math-floatp a) '(float 0 0) 0)) + ((eq (car a) 'cplx) + (nth 2 a)) + ((eq (car a) 'polar) + (math-mul (nth 1 a) (calcFunc-sin (nth 2 a)))) + ((eq (car a) 'vec) + (math-map-vec 'calcFunc-im a)) + ((math-known-realp a) + 0) + ((eq (car a) 'calcFunc-conj) + (math-neg (calcFunc-im (nth 1 a)))) + ((and (equal a '(var i var-i)) + (math-imaginary-i)) + 1) + ((and (memq (car a) '(+ - *)) + (progn + (setq aa (calcFunc-im (nth 1 a)) + bb (calcFunc-im (nth 2 a))) + (or (not (eq (car-safe aa) 'calcFunc-im)) + (not (eq (car-safe bb) 'calcFunc-im))))) + (if (eq (car a) '+) + (math-add aa bb) + (if (eq (car a) '-) + (math-sub aa bb) + (math-add (math-mul (calcFunc-re (nth 1 a)) bb) + (math-mul aa (calcFunc-re (nth 2 a))))))) + ((and (eq (car a) '/) + (math-known-realp (nth 2 a))) + (math-div (calcFunc-im (nth 1 a)) (nth 2 a))) + ((eq (car a) 'neg) + (math-neg (calcFunc-im (nth 1 a)))) + (t (calc-record-why 'numberp a) + (list 'calcFunc-im a)))) +) + + + diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el new file mode 100644 index 0000000000..5c996ea4cd --- /dev/null +++ b/lisp/calc/calc-embed.el @@ -0,0 +1,1256 @@ +;; Calculator for GNU Emacs, part II [calc-embed.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-embed () nil) + + +(defun calc-show-plain (n) + (interactive "P") + (calc-wrapper + (calc-set-command-flag 'renum-stack) + (message (if (calc-change-mode 'calc-show-plain n nil t) + "Including \"plain\" formulas in Calc Embedded mode." + "Omitting \"plain\" formulas in Calc Embedded mode."))) +) + + + + +;;; Things to do for Embedded Mode: +;;; +;;; Detect and strip off unexpected labels during reading. +;;; +;;; Get calc-grab-region to use math-read-big-expr. +;;; If calc-show-plain, main body should have only righthand side of => expr. +;;; Handle tabs that have crept into embedded formulas. +;;; After "switching to new formula", home cursor to that formula. +;;; Do something like \evalto ... \to for \gets operators. +;;; + + +(defvar calc-embedded-modes nil) +(defvar calc-embedded-globals nil) +(defvar calc-embedded-active nil) + +(make-variable-buffer-local 'calc-embedded-all-active) +(make-variable-buffer-local 'calc-embedded-some-active) + + +(defvar calc-embedded-open-formula "\\`\\|^\n\\|\\$\\$?\\|\\\\\\[\\|^\\\\begin.*\n\\|^@.*\n\\|^\\.EQ.*\n\\|\\\\(\\|^%\n\\|^\\.\\\\\"\n" + "*A regular expression for the opening delimiter of a formula used by +calc-embedded.") + +(defvar calc-embedded-close-formula "\\'\\|\n$\\|\\$\\$?\\|\\\\]\\|^\\\\end.*\n\\|^@.*\n\\|^\\.EN.*\n\\|\\\\)\\|\n%\n\\|^\\.\\\\\"\n" + "*A regular expression for the closing delimiter of a formula used by +calc-embedded.") + +(defvar calc-embedded-open-word "^\\|[^-+0-9.eE]" + "*A regular expression for the opening delimiter of a formula used by +calc-embedded-word.") + +(defvar calc-embedded-close-word "$\\|[^-+0-9.eE]" + "*A regular expression for the closing delimiter of a formula used by +calc-embedded-word.") + +(defvar calc-embedded-open-plain "%%% " + "*A string which is the opening delimiter for a \"plain\" formula. +If calc-show-plain mode is enabled, this is inserted at the front of +each formula.") + +(defvar calc-embedded-close-plain " %%%\n" + "*A string which is the closing delimiter for a \"plain\" formula. +See calc-embedded-open-plain.") + +(defvar calc-embedded-open-new-formula "\n\n" + "*A string which is inserted at front of formula by calc-embedded-new-formula.") + +(defvar calc-embedded-close-new-formula "\n\n" + "*A string which is inserted at end of formula by calc-embedded-new-formula.") + +(defvar calc-embedded-announce-formula "%Embed\n\\(% .*\n\\)*" + "*A regular expression which is sure to be followed by a calc-embedded formula." ) + +(defvar calc-embedded-open-mode "% " + "*A string which should precede calc-embedded mode annotations. +This is not required to be present for user-written mode annotations.") + +(defvar calc-embedded-close-mode "\n" + "*A string which should follow calc-embedded mode annotations. +This is not required to be present for user-written mode annotations.") + + +(defconst calc-embedded-mode-vars '(("precision" . calc-internal-prec) + ("word-size" . calc-word-size) + ("angles" . calc-angle-mode) + ("symbolic" . calc-symbolic-mode) + ("matrix" . calc-matrix-mode) + ("fractions" . calc-prefer-frac) + ("complex" . calc-complex-mode) + ("simplify" . calc-simplify-mode) + ("language" . the-language) + ("plain" . calc-show-plain) + ("break" . calc-line-breaking) + ("justify" . the-display-just) + ("left-label" . calc-left-label) + ("right-label" . calc-right-label) + ("radix" . calc-number-radix) + ("leading-zeros" . calc-leading-zeros) + ("grouping" . calc-group-digits) + ("group-char" . calc-group-char) + ("point-char" . calc-point-char) + ("frac-format" . calc-frac-format) + ("float-format" . calc-float-format) + ("complex-format" . calc-complex-format) + ("hms-format" . calc-hms-format) + ("date-format" . calc-date-format) + ("matrix-justify" . calc-matrix-just) + ("full-vectors" . calc-full-vectors) + ("break-vectors" . calc-break-vectors) + ("vector-commas" . calc-vector-commas) + ("vector-brackets" . calc-vector-brackets) + ("matrix-brackets" . calc-matrix-brackets) + ("strings" . calc-display-strings) +)) + + +;;; Format of calc-embedded-info vector: +;;; 0 Editing buffer. +;;; 1 Calculator buffer. +;;; 2 Top of current formula (marker). +;;; 3 Bottom of current formula (marker). +;;; 4 Top of current formula's delimiters (marker). +;;; 5 Bottom of current formula's delimiters (marker). +;;; 6 String representation of current formula. +;;; 7 Non-nil if formula is embedded within a single line. +;;; 8 Internal representation of current formula. +;;; 9 Variable assigned by this formula, or nil. +;;; 10 List of variables upon which this formula depends. +;;; 11 Evaluated value of the formula, or nil. +;;; 12 Mode settings for current formula. +;;; 13 Local mode settings for current formula. +;;; 14 Permanent mode settings for current formula. +;;; 15 Global mode settings for editing buffer. + + +;;; calc-embedded-active is an a-list keyed on buffers; each cdr is a +;;; sorted list of calc-embedded-infos in that buffer. We do this +;;; rather than using buffer-local variables because the latter are +;;; thrown away when a buffer changes major modes. + + +(defun calc-do-embedded (arg end obeg oend) + (if calc-embedded-info + + ;; Turn embedded mode off or switch to a new buffer. + (cond ((eq (current-buffer) (aref calc-embedded-info 1)) + (let ((calcbuf (current-buffer)) + (buf (aref calc-embedded-info 0))) + (calc-embedded-original-buffer t) + (calc-embedded nil) + (switch-to-buffer calcbuf))) + + ((eq (current-buffer) (aref calc-embedded-info 0)) + (let* ((info calc-embedded-info) + (mode calc-embedded-modes)) + (save-excursion + (set-buffer (aref info 1)) + (if (and (> (calc-stack-size) 0) + (equal (calc-top 1 'full) (aref info 8))) + (let ((calc-no-refresh-evaltos t)) + (if (calc-top 1 'sel) + (calc-unselect 1)) + (calc-embedded-set-modes + (aref info 15) (aref info 12) (aref info 14)) + (let ((calc-embedded-info nil)) + (calc-wrapper (calc-pop-stack)))) + (calc-set-mode-line))) + (setq calc-embedded-info nil + mode-line-buffer-identification (car mode) + truncate-lines (nth 2 mode) + buffer-read-only nil) + (use-local-map (nth 1 mode)) + (set-buffer-modified-p (buffer-modified-p)) + (or calc-embedded-quiet + (message "Back to %s mode." mode-name)))) + + (t + (if (buffer-name (aref calc-embedded-info 0)) + (save-excursion + (set-buffer (aref calc-embedded-info 0)) + (or (y-or-n-p "Cancel Calc Embedded mode in buffer %s? " + (buffer-name)) + (keyboard-quit)) + (calc-embedded nil))) + (calc-embedded arg end obeg oend))) + + ;; Turn embedded mode on. + (calc-plain-buffer-only) + (let ((modes (list mode-line-buffer-identification + (current-local-map) + truncate-lines)) + top bot outer-top outer-bot + info chg ident) + (barf-if-buffer-read-only) + (or calc-embedded-globals + (calc-find-globals)) + (setq info (calc-embedded-make-info (point) nil t arg end obeg oend)) + (if (eq (car-safe (aref info 8)) 'error) + (progn + (goto-char (nth 1 (aref info 8))) + (error (nth 2 (aref info 8))))) + (let ((mode-line-buffer-identification mode-line-buffer-identification) + (calc-embedded-info info) + (calc-embedded-no-reselect t)) + (calc-wrapper + (let* ((okay nil) + (calc-no-refresh-evaltos t)) + (setq chg (calc-embedded-set-modes + (aref info 15) (aref info 12) (aref info 13))) + (if (aref info 8) + (calc-push (calc-normalize (aref info 8))) + (calc-alg-entry))) + (setq calc-undo-list nil + calc-redo-list nil + ident mode-line-buffer-identification))) + (setq calc-embedded-info info + calc-embedded-modes modes + mode-line-buffer-identification ident + truncate-lines t + buffer-read-only t) + (set-buffer-modified-p (buffer-modified-p)) + (use-local-map calc-mode-map) + (setq calc-no-refresh-evaltos nil) + (and chg calc-any-evaltos (calc-wrapper (calc-refresh-evaltos))) + (or (eq calc-embedded-quiet t) + (message "Embedded Calc mode enabled. %s to return to normal." + (if calc-embedded-quiet + "Type `M-# x'" + "Give this command again"))))) + (scroll-down 0) ; fix a bug which occurs when truncate-lines is changed. +) +(setq calc-embedded-quiet nil) + + +(defun calc-embedded-select (arg) + (interactive "P") + (calc-embedded arg) + (and calc-embedded-info + (eq (car-safe (aref calc-embedded-info 8)) 'calcFunc-evalto) + (calc-select-part 1)) + (and calc-embedded-info + (or (eq (car-safe (aref calc-embedded-info 8)) 'calcFunc-assign) + (and (eq (car-safe (aref calc-embedded-info 8)) 'calcFunc-evalto) + (eq (car-safe (nth 1 (aref calc-embedded-info 8))) + 'calcFunc-assign))) + (calc-select-part 2)) +) + + +(defun calc-embedded-update-formula (arg) + (interactive "P") + (if arg + (let ((entry (assq (current-buffer) calc-embedded-active))) + (while (setq entry (cdr entry)) + (and (eq (car-safe (aref (car entry) 8)) 'calcFunc-evalto) + (or (not (consp arg)) + (and (<= (aref (car entry) 2) (region-beginning)) + (>= (aref (car entry) 3) (region-end)))) + (save-excursion + (calc-embedded-update (car entry) 14 t t))))) + (if (and calc-embedded-info + (eq (current-buffer) (aref calc-embedded-info 0)) + (>= (point) (aref calc-embedded-info 4)) + (<= (point) (aref calc-embedded-info 5))) + (calc-evaluate 1) + (let* ((opt (point)) + (info (calc-embedded-make-info (point) nil t)) + (pt (- opt (aref info 4)))) + (or (eq (car-safe (aref info 8)) 'error) + (progn + (save-excursion + (calc-embedded-update info 14 'eval t)) + (goto-char (+ (aref info 4) pt))))))) +) + + +(defun calc-embedded-edit (arg) + (interactive "P") + (let ((info (calc-embedded-make-info (point) nil t arg)) + str) + (if (eq (car-safe (aref info 8)) 'error) + (progn + (goto-char (nth 1 (aref info 8))) + (error (nth 2 (aref info 8))))) + (calc-wrapper + (setq str (math-showing-full-precision + (math-format-nice-expr (aref info 8) (screen-width)))) + (calc-edit-mode (list 'calc-embedded-finish-edit info)) + (insert str "\n"))) + (calc-show-edit-buffer) +) + +(defun calc-embedded-finish-edit (info) + (let ((buf (current-buffer)) + (str (buffer-substring (point) (point-max))) + (start (point)) + pos) + (switch-to-buffer calc-original-buffer) + (let ((val (save-excursion + (set-buffer (aref info 1)) + (let ((calc-language nil) + (math-expr-opers math-standard-opers)) + (math-read-expr str))))) + (if (eq (car-safe val) 'error) + (progn + (switch-to-buffer buf) + (goto-char (+ start (nth 1 val))) + (error (nth 2 val)))) + (calc-embedded-original-buffer t info) + (aset info 8 val) + (calc-embedded-update info 14 t t))) +) + +(defun calc-do-embedded-activate (arg cbuf) + (calc-plain-buffer-only) + (if arg + (calc-embedded-forget)) + (calc-find-globals) + (if (< (prefix-numeric-value arg) 0) + (message "Deactivating %s for Calc Embedded mode." (buffer-name)) + (message "Activating %s for Calc Embedded mode..." (buffer-name)) + (save-excursion + (let* ((active (assq (current-buffer) calc-embedded-active)) + (info active) + (pat " := \\| \\\\gets \\| => \\| \\\\evalto ")) + (if calc-embedded-announce-formula + (setq pat (format "%s\\|\\(%s\\)" + pat calc-embedded-announce-formula))) + (while (setq info (cdr info)) + (or (equal (buffer-substring (aref (car info) 2) (aref (car info) 3)) + (aref (car info) 6)) + (setcdr active (delq (car info) (cdr active))))) + (goto-char (point-min)) + (while (re-search-forward pat nil t) + (if (looking-at calc-embedded-open-formula) + (goto-char (match-end 1))) + (setq info (calc-embedded-make-info (point) cbuf nil)) + (or (eq (car-safe (aref info 8)) 'error) + (goto-char (aref info 5)))))) + (message "Activating %s for Calc Embedded mode...done" (buffer-name))) + (calc-embedded-active-state t) +) + +(defun calc-plain-buffer-only () + (if (memq major-mode '(calc-mode calc-trail-mode calc-edit-mode)) + (error "This command should be used in a normal editing buffer")) +) + +(defun calc-embedded-active-state (state) + (or (assq 'calc-embedded-all-active minor-mode-alist) + (setq minor-mode-alist + (cons '(calc-embedded-all-active " Active") + (cons '(calc-embedded-some-active " ~Active") + minor-mode-alist)))) + (let ((active (assq (current-buffer) calc-embedded-active))) + (or (cdr active) + (setq state nil))) + (and (eq state 'more) calc-embedded-all-active (setq state t)) + (setq calc-embedded-all-active (eq state t) + calc-embedded-some-active (not (memq state '(nil t)))) + (set-buffer-modified-p (buffer-modified-p)) +) + + +(defun calc-embedded-original-buffer (switch &optional info) + (or info (setq info calc-embedded-info)) + (or (buffer-name (aref info 0)) + (progn + (error "Calc embedded mode: Original buffer has been killed"))) + (if switch + (set-buffer (aref info 0))) +) + +(defun calc-embedded-word () + (interactive) + (calc-embedded '(4)) +) + +(defun calc-embedded-mark-formula (&optional body-only) + "Put point at the beginning of this Calc formula, mark at the end. +This normally marks the whole formula, including surrounding delimiters. +With any prefix argument, marks only the formula itself." + (interactive "P") + (and (eq major-mode 'calc-mode) + (error "This command should be used in a normal editing buffer")) + (let (top bot outer-top outer-bot) + (save-excursion + (calc-embedded-find-bounds body-only)) + (push-mark (if body-only bot outer-bot) t) + (goto-char (if body-only top outer-top))) +) + +(defun calc-embedded-find-bounds (&optional plain) + ;; (while (and (bolp) (eq (following-char) ?\n)) + ;; (forward-char 1)) + (and (eolp) (bolp) (not (eq (char-after (- (point) 2)) ?\n)) + (forward-char -1)) + (let ((home (point))) + (or (and (looking-at calc-embedded-open-formula) + (not (looking-at calc-embedded-close-formula))) + (re-search-backward calc-embedded-open-formula nil t) + (error "Can't find start of formula")) + (and (eq (preceding-char) ?\$) ; backward search for \$\$? won't back + (eq (following-char) ?\$) ; up over a second $, so do it by hand. + (forward-char -1)) + (setq outer-top (point)) + (goto-char (match-end 0)) + (if (eq (following-char) ?\n) + (forward-char 1)) + (or (bolp) + (while (eq (following-char) ?\ ) + (forward-char 1))) + (or (eq plain 'plain) + (if (looking-at (regexp-quote calc-embedded-open-plain)) + (progn + (goto-char (match-end 0)) + (search-forward calc-embedded-close-plain)))) + (setq top (point)) + (or (re-search-forward calc-embedded-close-formula nil t) + (error "Can't find end of formula")) + (if (< (point) home) + (error "Not inside a formula")) + (and (eq (following-char) ?\n) (not (bolp)) + (forward-char 1)) + (setq outer-bot (point)) + (goto-char (match-beginning 0)) + (if (eq (preceding-char) ?\n) + (backward-char 1)) + (or (eolp) + (while (eq (preceding-char) ?\ ) + (backward-char 1))) + (setq bot (point))) +) + +(defun calc-embedded-kill-formula () + "Kill the formula surrounding point. +If Calc Embedded mode was active, this deactivates it. +The formula (including its surrounding delimiters) is saved in the kill ring. +The command \\[yank] can retrieve it from there." + (interactive) + (and calc-embedded-info + (calc-embedded nil)) + (calc-embedded-mark-formula) + (kill-region (point) (mark)) + (pop-mark) +) + +(defun calc-embedded-copy-formula-as-kill () + "Save the formula surrounding point as if killed, but don't kill it." + (interactive) + (save-excursion + (calc-embedded-mark-formula) + (copy-region-as-kill (point) (mark)) + (pop-mark)) +) + +(defun calc-embedded-duplicate () + (interactive) + (let ((already calc-embedded-info) + top bot outer-top outer-bot new-top) + (if calc-embedded-info + (progn + (setq top (+ (aref calc-embedded-info 2)) + bot (+ (aref calc-embedded-info 3)) + outer-top (+ (aref calc-embedded-info 4)) + outer-bot (+ (aref calc-embedded-info 5))) + (calc-embedded nil)) + (calc-embedded-find-bounds)) + (goto-char outer-bot) + (insert "\n") + (setq new-top (point)) + (insert-buffer-substring (current-buffer) outer-top outer-bot) + (goto-char (+ new-top (- top outer-top))) + (let ((calc-embedded-quiet (if already t 'x))) + (calc-embedded (+ new-top (- top outer-top)) + (+ new-top (- bot outer-top)) + new-top + (+ new-top (- outer-bot outer-top))))) +) + +(defun calc-embedded-next (arg) + (interactive "P") + (setq arg (prefix-numeric-value arg)) + (let* ((active (cdr (assq (current-buffer) calc-embedded-active))) + (p active) + (num (length active))) + (or active + (error "No active formulas in buffer")) + (cond ((= arg 0)) + ((= arg -1) + (if (<= (point) (aref (car active) 3)) + (goto-char (aref (nth (1- num) active) 2)) + (while (and (cdr p) + (> (point) (aref (nth 1 p) 3))) + (setq p (cdr p))) + (goto-char (aref (car p) 2)))) + ((< arg -1) + (calc-embedded-next -1) + (calc-embedded-next (+ (* num 1000) arg 1))) + (t + (setq arg (1+ (% (1- arg) num))) + (while (and p (>= (point) (aref (car p) 2))) + (setq p (cdr p))) + (while (> (setq arg (1- arg)) 0) + (setq p (if p (cdr p) (cdr active)))) + (goto-char (aref (car (or p active)) 2))))) +) + +(defun calc-embedded-previous (arg) + (interactive "p") + (calc-embedded-next (- (prefix-numeric-value arg))) +) + +(defun calc-embedded-new-formula () + (interactive) + (and (eq major-mode 'calc-mode) + (error "This command should be used in a normal editing buffer")) + (if calc-embedded-info + (calc-embedded nil)) + (let (top bot outer-top outer-bot) + (if (and (eq (preceding-char) ?\n) + (string-match "\\`\n" calc-embedded-open-new-formula)) + (progn + (setq outer-top (1- (point))) + (forward-char -1) + (insert (substring calc-embedded-open-new-formula 1))) + (setq outer-top (point)) + (insert calc-embedded-open-new-formula)) + (setq top (point)) + (insert " ") + (setq bot (point)) + (insert calc-embedded-close-new-formula) + (if (and (eq (following-char) ?\n) + (string-match "\n\\'" calc-embedded-close-new-formula)) + (delete-char 1)) + (setq outer-bot (point)) + (goto-char top) + (let ((calc-embedded-quiet 'x)) + (calc-embedded top bot outer-top outer-bot))) +) + +(defun calc-embedded-forget () + (interactive) + (setq calc-embedded-active (delq (assq (current-buffer) calc-embedded-active) + calc-embedded-active)) + (calc-embedded-active-state nil) +) + + +(defun calc-embedded-set-modes (gmodes modes local-modes &optional temp) + (let ((the-language (calc-embedded-language)) + (the-display-just (calc-embedded-justify)) + (v gmodes) + (changed nil) + found value) + (while v + (or (symbolp (car v)) + (and (setq found (assq (car (car v)) modes)) + (not (eq (cdr found) 'default))) + (and (setq found (assq (car (car v)) local-modes)) + (not (eq (cdr found) 'default))) + (progn + (if (eq (setq value (cdr (car v))) 'default) + (setq value (cdr (assq (car (car v)) calc-mode-var-list)))) + (equal (symbol-value (car (car v))) value)) + (progn + (setq changed t) + (if temp (setq prev-modes (cons (cons (car (car v)) + (symbol-value (car (car v)))) + prev-modes))) + (set (car (car v)) value))) + (setq v (cdr v))) + (setq v modes) + (while v + (or (and (setq found (assq (car (car v)) local-modes)) + (not (eq (cdr found) 'default))) + (eq (setq value (cdr (car v))) 'default) + (equal (symbol-value (car (car v))) value) + (progn + (setq changed t) + (if temp (setq prev-modes (cons (cons (car (car v)) + (symbol-value (car (car v)))) + prev-modes))) + (set (car (car v)) value))) + (setq v (cdr v))) + (setq v local-modes) + (while v + (or (eq (setq value (cdr (car v))) 'default) + (equal (symbol-value (car (car v))) value) + (progn + (setq changed t) + (if temp (setq prev-modes (cons (cons (car (car v)) + (symbol-value (car (car v)))) + prev-modes))) + (set (car (car v)) value))) + (setq v (cdr v))) + (and changed (not (eq temp t)) + (progn + (calc-embedded-set-justify the-display-just) + (calc-embedded-set-language the-language))) + (and changed (not temp) + (progn + (setq calc-full-float-format (list (if (eq (car calc-float-format) + 'fix) + 'float + (car calc-float-format)) + 0)) + (calc-refresh))) + changed) +) + +(defun calc-embedded-language () + (if calc-language-option + (list calc-language calc-language-option) + calc-language) +) + +(defun calc-embedded-set-language (lang) + (let ((option nil)) + (if (consp lang) + (setq option (nth 1 lang) + lang (car lang))) + (or (and (eq lang calc-language) + (equal option calc-language-option)) + (calc-set-language lang option t))) +) + +(defun calc-embedded-justify () + (if calc-display-origin + (list calc-display-just calc-display-origin) + calc-display-just) +) + +(defun calc-embedded-set-justify (just) + (if (consp just) + (setq calc-display-origin (nth 1 just) + calc-display-just (car just)) + (setq calc-display-just just + calc-display-origin nil)) +) + + +(defun calc-find-globals () + (interactive) + (and (eq major-mode 'calc-mode) + (error "This command should be used in a normal editing buffer")) + (make-local-variable 'calc-embedded-globals) + (let ((case-fold-search nil) + (modes nil) + (save-pt (point)) + found value) + (goto-char (point-min)) + (while (re-search-forward "\\[calc-global-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)\\]" nil t) + (and (setq found (assoc (buffer-substring (match-beginning 1) + (match-end 1)) + calc-embedded-mode-vars)) + (or (assq (cdr found) modes) + (setq modes (cons (cons (cdr found) + (car (read-from-string + (buffer-substring + (match-beginning 2) + (match-end 2))))) + modes))))) + (setq calc-embedded-globals (cons t modes)) + (goto-char save-pt)) +) + +(defun calc-embedded-find-modes () + (let ((case-fold-search nil) + (save-pt (point)) + (no-defaults t) + (modes nil) + (emodes nil) + (pmodes nil) + found value) + (while (and no-defaults (search-backward "[calc-" nil t)) + (forward-char 6) + (or (and (looking-at "mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]") + (setq found (assoc (buffer-substring (match-beginning 1) + (match-end 1)) + calc-embedded-mode-vars)) + (or (assq (cdr found) modes) + (setq modes (cons (cons (cdr found) + (car (read-from-string + (buffer-substring + (match-beginning 2) + (match-end 2))))) + modes)))) + (and (looking-at "perm-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]") + (setq found (assoc (buffer-substring (match-beginning 1) + (match-end 1)) + calc-embedded-mode-vars)) + (or (assq (cdr found) pmodes) + (setq pmodes (cons (cons (cdr found) + (car (read-from-string + (buffer-substring + (match-beginning 2) + (match-end 2))))) + pmodes)))) + (and (looking-at "edit-mode: *\\([-a-z]+\\): *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]") + (setq found (assoc (buffer-substring (match-beginning 1) + (match-end 1)) + calc-embedded-mode-vars)) + (or (assq (cdr found) emodes) + (setq emodes (cons (cons (cdr found) + (car (read-from-string + (buffer-substring + (match-beginning 2) + (match-end 2))))) + emodes)))) + (and (looking-at "defaults]") + (setq no-defaults nil))) + (backward-char 6)) + (goto-char save-pt) + (list modes emodes pmodes)) +) + + +(defun calc-embedded-make-info (point cbuf fresh &optional + top bot outer-top outer-bot) + (let* ((bufentry (assq (current-buffer) calc-embedded-active)) + (found bufentry) + (force (and fresh top)) + (fixed top) + (new-info nil) + info str) + (or found + (setq found (list (current-buffer)) + calc-embedded-active (cons found calc-embedded-active))) + (while (and (cdr found) + (> point (aref (car (cdr found)) 3))) + (setq found (cdr found))) + (if (and (cdr found) + (>= point (aref (nth 1 found) 2))) + (setq info (nth 1 found)) + (setq info (make-vector 16 nil) + new-info t + fresh t) + (aset info 0 (current-buffer)) + (aset info 1 (or cbuf (save-excursion + (calc-create-buffer) + (current-buffer))))) + (if (and (integerp top) (not bot)) ; started with a user-supplied argument + (progn + (if (= (setq arg (prefix-numeric-value arg)) 0) + (progn + (aset info 2 (copy-marker (region-beginning))) + (aset info 3 (copy-marker (region-end)))) + (aset info (if (> arg 0) 2 3) (point-marker)) + (forward-line arg) + (aset info (if (> arg 0) 3 2) (point-marker))) + (aset info 4 (copy-marker (aref info 2))) + (aset info 5 (copy-marker (aref info 3)))) + (if (aref info 4) + (setq top (aref info 2) + fixed top) + (if (consp top) + (let ((calc-embedded-open-formula calc-embedded-open-word) + (calc-embedded-close-formula calc-embedded-close-word)) + (calc-embedded-find-bounds 'plain)) + (or top + (calc-embedded-find-bounds 'plain))) + (aset info 2 (copy-marker (min top bot))) + (aset info 3 (copy-marker (max top bot))) + (aset info 4 (copy-marker (or outer-top (aref info 2)))) + (aset info 5 (copy-marker (or outer-bot (aref info 3)))))) + (goto-char (aref info 2)) + (if new-info + (progn + (or (bolp) (aset info 7 t)) + (goto-char (aref info 3)) + (or (bolp) (eolp) (aset info 7 t)))) + (if fresh + (let ((modes (calc-embedded-find-modes))) + (aset info 12 (car modes)) + (aset info 13 (nth 1 modes)) + (aset info 14 (nth 2 modes)))) + (aset info 15 calc-embedded-globals) + (setq str (buffer-substring (aref info 2) (aref info 3))) + (if (or force + (not (equal str (aref info 6)))) + (if (and fixed (aref info 6)) + (progn + (aset info 4 nil) + (calc-embedded-make-info point cbuf nil) + (setq new-info nil)) + (let* ((open-plain calc-embedded-open-plain) + (close-plain calc-embedded-close-plain) + (pref-len (length open-plain)) + (vars-used nil) + suff-pos val temp) + (save-excursion + (set-buffer (aref info 1)) + (calc-embedded-set-modes (aref info 15) + (aref info 12) (aref info 14)) + (if (and (> (length str) pref-len) + (equal (substring str 0 pref-len) open-plain) + (setq suff-pos (string-match (regexp-quote close-plain) + str pref-len))) + (setq val (math-read-plain-expr + (substring str pref-len suff-pos))) + (if (string-match "[^ \t\n]" str) + (setq pref-len 0 + val (math-read-big-expr str)) + (setq val nil)))) + (if (eq (car-safe val) 'error) + (setq val (list 'error + (+ (aref info 2) pref-len (nth 1 val)) + (nth 2 val)))) + (aset info 6 str) + (aset info 8 val) + (setq temp val) + (if (eq (car-safe temp) 'calcFunc-evalto) + (setq temp (nth 1 temp)) + (if (eq (car-safe temp) 'error) + (if new-info + (setq new-info nil) + (setcdr found (delq info (cdr found))) + (calc-embedded-active-state 'less)))) + (aset info 9 (and (eq (car-safe temp) 'calcFunc-assign) + (nth 1 temp))) + (if (memq (car-safe val) '(calcFunc-evalto calcFunc-assign)) + (calc-embedded-find-vars val)) + (aset info 10 vars-used) + (aset info 11 nil)))) + (if new-info + (progn + (setcdr found (cons info (cdr found))) + (calc-embedded-active-state 'more))) + info) +) + +(defun calc-embedded-find-vars (x) + (cond ((Math-primp x) + (and (eq (car-safe x) 'var) + (not (assoc x vars-used)) + (setq vars-used (cons (list x) vars-used)))) + ((eq (car x) 'calcFunc-evalto) + (calc-embedded-find-vars (nth 1 x))) + ((eq (car x) 'calcFunc-assign) + (calc-embedded-find-vars (nth 2 x))) + (t + (and (eq (car x) 'calcFunc-subscr) + (eq (car-safe (nth 1 x)) 'var) + (Math-primp (nth 2 x)) + (not (assoc x vars-used)) + (setq vars-used (cons (list x) vars-used))) + (while (setq x (cdr x)) + (calc-embedded-find-vars (car x))))) +) + + +(defun calc-embedded-evaluate-expr (x) + (let ((vars-used (aref calc-embedded-info 10))) + (or vars-used (calc-embedded-find-vars x)) + (if vars-used + (let ((active (assq (aref calc-embedded-info 0) calc-embedded-active)) + (args nil)) + (save-excursion + (calc-embedded-original-buffer t) + (or active + (progn + (calc-embedded-activate) + (setq active (assq (aref calc-embedded-info 0) + calc-embedded-active)))) + (while vars-used + (calc-embedded-eval-get-var (car (car vars-used)) active) + (setq vars-used (cdr vars-used)))) + (calc-embedded-subst x)) + (calc-normalize (math-evaluate-expr-rec x)))) +) + +(defun calc-embedded-subst (x) + (if (and (eq (car-safe x) 'calcFunc-evalto) (cdr x)) + (let ((rhs (calc-embedded-subst (nth 1 x)))) + (list 'calcFunc-evalto + (nth 1 x) + (if (eq (car-safe rhs) 'calcFunc-assign) (nth 2 rhs) rhs))) + (if (and (eq (car-safe x) 'calcFunc-assign) (= (length x) 3)) + (list 'calcFunc-assign + (nth 1 x) + (calc-embedded-subst (nth 2 x))) + (calc-normalize (math-evaluate-expr-rec (math-multi-subst-rec x))))) +) + +(defun calc-embedded-eval-get-var (var base) + (let ((entry base) + (point (aref calc-embedded-info 2)) + (last nil) + val) + (while (and (setq entry (cdr entry)) + (or (not (equal var (aref (car entry) 9))) + (and (> point (aref (car entry) 3)) + (setq last entry))))) + (if last + (setq entry last)) + (if entry + (progn + (setq entry (car entry)) + (if (equal (buffer-substring (aref entry 2) (aref entry 3)) + (aref entry 6)) + (progn + (or (aref entry 11) + (save-excursion + (calc-embedded-update entry 14 t nil))) + (setq val (aref entry 11)) + (if (eq (car-safe val) 'calcFunc-evalto) + (setq val (nth 2 val))) + (if (eq (car-safe val) 'calcFunc-assign) + (setq val (nth 2 val))) + (setq args (cons (cons var val) args))) + (calc-embedded-activate) + (calc-embedded-eval-get-var var base))))) +) + + +(defun calc-embedded-update (info which need-eval need-display + &optional str entry old-val) + (let* ((prev-modes nil) + (open-plain calc-embedded-open-plain) + (close-plain calc-embedded-close-plain) + (vars-used nil) + (evalled nil) + (val (aref info 8)) + (old-eval (aref info 11))) + (or old-val (setq old-val val)) + (if (eq (car-safe val) 'calcFunc-evalto) + (setq need-display t)) + (unwind-protect + (progn + (set-buffer (aref info 1)) + (and which + (calc-embedded-set-modes (aref info 15) (aref info 12) + (aref info which) + (if need-display 'full t))) + (if (memq (car-safe val) '(calcFunc-evalto calcFunc-assign)) + (calc-embedded-find-vars val)) + (if need-eval + (let ((calc-embedded-info info)) + (setq val (math-evaluate-expr val) + evalled val))) + (if (or (eq need-eval 'eval) (eq (car-safe val) 'calcFunc-evalto)) + (aset info 8 val)) + (aset info 9 nil) + (aset info 10 vars-used) + (aset info 11 nil) + (if (or need-display (eq (car-safe val) 'calcFunc-evalto)) + (let ((extra (if (eq calc-language 'big) 1 0))) + (or entry (setq entry (list val 1 nil))) + (or str (progn + (setq str (let ((calc-line-numbering nil)) + (math-format-stack-value entry))) + (if (eq calc-language 'big) + (setq str (substring str 0 -1))))) + (and calc-show-plain + (setq str (concat open-plain + (math-showing-full-precision + (math-format-flat-expr val 0)) + close-plain + str))) + (save-excursion + (calc-embedded-original-buffer t info) + (or (equal str (aref info 6)) + (let ((delta (- (aref info 5) (aref info 3))) + (buffer-read-only nil)) + (goto-char (aref info 2)) + (delete-region (point) (aref info 3)) + (and (> (nth 1 entry) (1+ extra)) + (aref info 7) + (progn + (aset info 7 nil) + (delete-horizontal-space) + (insert "\n\n") + (delete-horizontal-space) + (backward-char 1))) + (insert str) + (set-marker (aref info 3) (point)) + (set-marker (aref info 5) (+ (point) delta)) + (aset info 6 str)))))) + (if (eq (car-safe val) 'calcFunc-evalto) + (progn + (setq evalled (nth 2 val) + val (nth 1 val)))) + (if (eq (car-safe val) 'calcFunc-assign) + (progn + (aset info 9 (nth 1 val)) + (aset info 11 (or evalled + (let ((calc-embedded-info info)) + (math-evaluate-expr (nth 2 val))))) + (or (equal old-eval (aref info 11)) + (calc-embedded-var-change (nth 1 val) (aref info 0)))) + (if (eq (car-safe old-val) 'calcFunc-evalto) + (setq old-val (nth 1 old-val))) + (if (eq (car-safe old-val) 'calcFunc-assign) + (calc-embedded-var-change (nth 1 old-val) (aref info 0))))) + (set-buffer (aref info 1)) + (while prev-modes + (cond ((eq (car (car prev-modes)) 'the-language) + (if need-display + (calc-embedded-set-language (cdr (car prev-modes))))) + ((eq (car (car prev-modes)) 'the-display-just) + (if need-display + (calc-embedded-set-justify (cdr (car prev-modes))))) + (t + (set (car (car prev-modes)) (cdr (car prev-modes))))) + (setq prev-modes (cdr prev-modes))))) +) + + + + +;;; These are hooks called by the main part of Calc. + +(defun calc-embedded-select-buffer () + (if (eq (current-buffer) (aref calc-embedded-info 0)) + (let ((info calc-embedded-info) + horiz vert) + (if (and (or (< (point) (aref info 4)) + (> (point) (aref info 5))) + (not calc-embedded-no-reselect)) + (let ((calc-embedded-quiet t)) + (message "(Switching Calc Embedded mode to new formula.)") + (calc-embedded nil) + (calc-embedded nil))) + (setq horiz (max (min (current-column) (- (point) (aref info 2))) 0) + vert (if (<= (aref info 2) (point)) + (- (count-lines (aref info 2) (point)) + (if (bolp) 0 1)) + 0)) + (set-buffer (aref info 1)) + (if calc-show-plain + (if (= vert 0) + (setq horiz 0) + (setq vert (1- vert)))) + (calc-cursor-stack-index 1) + (if calc-line-numbering + (setq horiz (+ horiz 4))) + (if (> vert 0) + (forward-line vert)) + (forward-char (min horiz + (- (point-max) (point))))) + (calc-select-buffer)) +) +(setq calc-embedded-no-reselect nil) + +(defun calc-embedded-finish-command () + (let ((buf (current-buffer)) + horiz vert) + (save-excursion + (set-buffer (aref calc-embedded-info 1)) + (if (> (calc-stack-size) 0) + (let ((pt (point)) + (col (current-column)) + (bol (bolp))) + (calc-cursor-stack-index 0) + (if (< pt (point)) + (progn + (calc-cursor-stack-index 1) + (if (>= pt (point)) + (progn + (setq horiz (- col (if calc-line-numbering 4 0)) + vert (- (count-lines (point) pt) + (if bol 0 1))) + (if calc-show-plain + (setq vert (max 1 (1+ vert)))))))) + (goto-char pt)))) + (if horiz + (progn + (set-buffer (aref calc-embedded-info 0)) + (goto-char (aref calc-embedded-info 2)) + (if (> vert 0) + (forward-line vert)) + (forward-char (max horiz 0)) + (set-buffer buf)))) +) + +(defun calc-embedded-stack-change () + (or calc-executing-macro + (save-excursion + (set-buffer (aref calc-embedded-info 1)) + (let* ((info calc-embedded-info) + (extra-line (if (eq calc-language 'big) 1 0)) + (the-point (point)) + (empty (= (calc-stack-size) 0)) + (entry (if empty + (list '(var empty var-empty) 1 nil) + (calc-top 1 'entry))) + (old-val (aref info 8)) + top bot str) + (if empty + (setq str "empty") + (save-excursion + (calc-cursor-stack-index 1) + (setq top (point)) + (calc-cursor-stack-index 0) + (setq bot (- (point) extra-line)) + (setq str (buffer-substring top (- bot 1)))) + (if calc-line-numbering + (let ((pos 0)) + (setq str (substring str 4)) + (while (setq pos (string-match "\n...." str pos)) + (setq str (concat (substring str 0 (1+ pos)) + (substring str (+ pos 5))) + pos (1+ pos)))))) + (calc-embedded-original-buffer t) + (aset info 8 (car entry)) + (calc-embedded-update info 13 nil t str entry old-val)))) +) + +(defun calc-embedded-mode-line-change () + (let ((str mode-line-buffer-identification)) + (save-excursion + (calc-embedded-original-buffer t) + (setq mode-line-buffer-identification str) + (set-buffer-modified-p (buffer-modified-p)))) +) + +(defun calc-embedded-modes-change (vars) + (if (eq (car vars) 'calc-language) (setq vars '(the-language))) + (if (eq (car vars) 'calc-display-just) (setq vars '(the-display-just))) + (while (and vars + (not (rassq (car vars) calc-embedded-mode-vars))) + (setq vars (cdr vars))) + (if (and vars calc-mode-save-mode (not (eq calc-mode-save-mode 'save))) + (save-excursion + (let* ((save-mode calc-mode-save-mode) + (header (if (eq save-mode 'local) + "calc-mode:" + (format "calc-%s-mode:" save-mode))) + (the-language (calc-embedded-language)) + (the-display-just (calc-embedded-justify)) + (values (mapcar 'symbol-value vars)) + (num (cond ((eq save-mode 'local) 12) + ((eq save-mode 'edit) 13) + ((eq save-mode 'perm) 14) + (t nil))) + base limit mname mlist) + (calc-embedded-original-buffer t) + (save-excursion + (if (eq save-mode 'global) + (setq base (point-max) + limit (point-min) + mlist calc-embedded-globals) + (goto-char (aref calc-embedded-info 4)) + (beginning-of-line) + (setq base (point) + limit (max (- (point) 1000) (point-min)) + mlist (and num (aref calc-embedded-info num))) + (and (re-search-backward + (format "\\(%s\\)[^\001]*\\(%s\\)\\|\\[calc-defaults]" + calc-embedded-open-formula + calc-embedded-close-formula) limit t) + (setq limit (point)))) + (while vars + (goto-char base) + (if (setq mname (car (rassq (car vars) + calc-embedded-mode-vars))) + (let ((buffer-read-only nil) + (found (assq (car vars) mlist))) + (if found + (setcdr found (car values)) + (setq mlist (cons (cons (car vars) (car values)) mlist)) + (if num + (aset calc-embedded-info num mlist) + (if (eq save-mode 'global) + (setq calc-embedded-globals mlist)))) + (if (re-search-backward + (format "\\[%s *%s: *\\(\"\\([^\"\n\\]\\|\\\\.\\)*\"\\|[- ()a-zA-Z0-9]+\\)]" + header mname) + limit t) + (progn + (goto-char (match-beginning 1)) + (delete-region (point) (match-end 1)) + (insert (prin1-to-string (car values)))) + (goto-char base) + (insert-before-markers + calc-embedded-open-mode + "[" header " " mname ": " + (prin1-to-string (car values)) "]" + calc-embedded-close-mode)))) + (setq vars (cdr vars) + values (cdr values))))))) +) + +(defun calc-embedded-var-change (var &optional buf) + (if (symbolp var) + (setq var (list 'var + (if (string-match "\\`var-.+\\'" + (symbol-name var)) + (intern (substring (symbol-name var) 4)) + var) + var))) + (save-excursion + (let ((manual (not calc-auto-recompute)) + (bp calc-embedded-active) + (first t)) + (if buf (setq bp (memq (assq buf bp) bp))) + (while bp + (let ((calc-embedded-no-reselect t) + (p (and (buffer-name (car (car bp))) + (cdr (car bp))))) + (while p + (if (assoc var (aref (car p) 10)) + (if manual + (if (aref (car p) 11) + (progn + (aset (car p) 11 nil) + (if (aref (car p) 9) + (calc-embedded-var-change (aref (car p) 9))))) + (set-buffer (aref (car p) 0)) + (if (equal (buffer-substring (aref (car p) 2) + (aref (car p) 3)) + (aref (car p) 6)) + (let ((calc-embedded-info nil)) + (or calc-embedded-quiet + (message "Recomputing...")) + (setq first nil) + (calc-wrapper + (set-buffer (aref (car p) 0)) + (calc-embedded-update (car p) 14 t nil))) + (setcdr (car bp) (delq (car p) (cdr (car bp)))) + (message + "(Tried to recompute but formula was changed or missing.)")))) + (setq p (cdr p)))) + (setq bp (if buf nil (cdr bp)))) + (or first calc-embedded-quiet (message "")))) +) + + + + + diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el new file mode 100644 index 0000000000..f0f6cad5ac --- /dev/null +++ b/lisp/calc/calc-ext.el @@ -0,0 +1,3439 @@ +;; Calculator for GNU Emacs, part II +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +(provide 'calc-ext) + +(setq calc-extensions-loaded t) + +;;; This function is the autoload "hook" to cause this file to be loaded. +;;;###autoload +(defun calc-extensions () + "This function is part of the autoload linkage for parts of Calc." + t +) + +;;; Auto-load calc.el part, in case this part was loaded first. +(if (fboundp 'calc-dispatch) + (and (eq (car-safe (symbol-function 'calc-dispatch)) 'autoload) + (load (nth 1 (symbol-function 'calc-dispatch)))) + (if (fboundp 'calc) + (and (eq (car-safe (symbol-function 'calc)) 'autoload) + (load (nth 1 (symbol-function 'calc)))) + (error "Main part of Calc must be present in order to load this file."))) + +(require 'calc-macs) + +;;; The following was made a function so that it could be byte-compiled. +(defun calc-init-extensions () + + (setq gc-cons-threshold (max gc-cons-threshold 250000)) + + (define-key calc-mode-map ":" 'calc-fdiv) + (define-key calc-mode-map "\\" 'calc-idiv) + (define-key calc-mode-map "|" 'calc-concat) + (define-key calc-mode-map "!" 'calc-factorial) + (define-key calc-mode-map "C" 'calc-cos) + (define-key calc-mode-map "E" 'calc-exp) + (define-key calc-mode-map "H" 'calc-hyperbolic) + (define-key calc-mode-map "I" 'calc-inverse) + (define-key calc-mode-map "J" 'calc-conj) + (define-key calc-mode-map "L" 'calc-ln) + (define-key calc-mode-map "N" 'calc-eval-num) + (define-key calc-mode-map "P" 'calc-pi) + (define-key calc-mode-map "Q" 'calc-sqrt) + (define-key calc-mode-map "R" 'calc-round) + (define-key calc-mode-map "S" 'calc-sin) + (define-key calc-mode-map "T" 'calc-tan) + (define-key calc-mode-map "U" 'calc-undo) + (define-key calc-mode-map "X" 'calc-call-last-kbd-macro) + (define-key calc-mode-map "o" 'calc-realign) + (define-key calc-mode-map "p" 'calc-precision) + (define-key calc-mode-map "w" 'calc-why) + (define-key calc-mode-map "x" 'calc-execute-extended-command) + (define-key calc-mode-map "y" 'calc-copy-to-buffer) + + (define-key calc-mode-map "(" 'calc-begin-complex) + (define-key calc-mode-map ")" 'calc-end-complex) + (define-key calc-mode-map "[" 'calc-begin-vector) + (define-key calc-mode-map "]" 'calc-end-vector) + (define-key calc-mode-map "," 'calc-comma) + (define-key calc-mode-map ";" 'calc-semi) + (define-key calc-mode-map "`" 'calc-edit) + (define-key calc-mode-map "=" 'calc-evaluate) + (define-key calc-mode-map "~" 'calc-num-prefix) + (define-key calc-mode-map "<" 'calc-scroll-left) + (define-key calc-mode-map ">" 'calc-scroll-right) + (define-key calc-mode-map "{" 'calc-scroll-down) + (define-key calc-mode-map "}" 'calc-scroll-up) + (define-key calc-mode-map "\C-k" 'calc-kill) + (define-key calc-mode-map "\M-k" 'calc-copy-as-kill) + (define-key calc-mode-map "\C-w" 'calc-kill-region) + (define-key calc-mode-map "\M-w" 'calc-copy-region-as-kill) + (define-key calc-mode-map "\C-y" 'calc-yank) + (define-key calc-mode-map "\C-_" 'calc-undo) + (define-key calc-mode-map "\C-xu" 'calc-undo) + (define-key calc-mode-map "\M-\C-m" 'calc-last-args) + + (define-key calc-mode-map "a" nil) + (define-key calc-mode-map "a?" 'calc-a-prefix-help) + (define-key calc-mode-map "aa" 'calc-apart) + (define-key calc-mode-map "ab" 'calc-substitute) + (define-key calc-mode-map "ac" 'calc-collect) + (define-key calc-mode-map "ad" 'calc-derivative) + (define-key calc-mode-map "ae" 'calc-simplify-extended) + (define-key calc-mode-map "af" 'calc-factor) + (define-key calc-mode-map "ag" 'calc-poly-gcd) + (define-key calc-mode-map "ai" 'calc-integral) + (define-key calc-mode-map "am" 'calc-match) + (define-key calc-mode-map "an" 'calc-normalize-rat) + (define-key calc-mode-map "ap" 'calc-poly-interp) + (define-key calc-mode-map "ar" 'calc-rewrite) + (define-key calc-mode-map "as" 'calc-simplify) + (define-key calc-mode-map "at" 'calc-taylor) + (define-key calc-mode-map "av" 'calc-alg-evaluate) + (define-key calc-mode-map "ax" 'calc-expand) + (define-key calc-mode-map "aA" 'calc-abs) + (define-key calc-mode-map "aF" 'calc-curve-fit) + (define-key calc-mode-map "aI" 'calc-num-integral) + (define-key calc-mode-map "aM" 'calc-map-equation) + (define-key calc-mode-map "aN" 'calc-find-minimum) + (define-key calc-mode-map "aP" 'calc-poly-roots) + (define-key calc-mode-map "aS" 'calc-solve-for) + (define-key calc-mode-map "aR" 'calc-find-root) + (define-key calc-mode-map "aT" 'calc-tabulate) + (define-key calc-mode-map "aX" 'calc-find-maximum) + (define-key calc-mode-map "a+" 'calc-summation) + (define-key calc-mode-map "a-" 'calc-alt-summation) + (define-key calc-mode-map "a*" 'calc-product) + (define-key calc-mode-map "a\\" 'calc-poly-div) + (define-key calc-mode-map "a%" 'calc-poly-rem) + (define-key calc-mode-map "a/" 'calc-poly-div-rem) + (define-key calc-mode-map "a=" 'calc-equal-to) + (define-key calc-mode-map "a#" 'calc-not-equal-to) + (define-key calc-mode-map "a<" 'calc-less-than) + (define-key calc-mode-map "a>" 'calc-greater-than) + (define-key calc-mode-map "a[" 'calc-less-equal) + (define-key calc-mode-map "a]" 'calc-greater-equal) + (define-key calc-mode-map "a." 'calc-remove-equal) + (define-key calc-mode-map "a{" 'calc-in-set) + (define-key calc-mode-map "a&" 'calc-logical-and) + (define-key calc-mode-map "a|" 'calc-logical-or) + (define-key calc-mode-map "a!" 'calc-logical-not) + (define-key calc-mode-map "a:" 'calc-logical-if) + (define-key calc-mode-map "a_" 'calc-subscript) + (define-key calc-mode-map "a\"" 'calc-expand-formula) + + (define-key calc-mode-map "b" nil) + (define-key calc-mode-map "b?" 'calc-b-prefix-help) + (define-key calc-mode-map "ba" 'calc-and) + (define-key calc-mode-map "bc" 'calc-clip) + (define-key calc-mode-map "bd" 'calc-diff) + (define-key calc-mode-map "bl" 'calc-lshift-binary) + (define-key calc-mode-map "bn" 'calc-not) + (define-key calc-mode-map "bo" 'calc-or) + (define-key calc-mode-map "bp" 'calc-pack-bits) + (define-key calc-mode-map "br" 'calc-rshift-binary) + (define-key calc-mode-map "bt" 'calc-rotate-binary) + (define-key calc-mode-map "bu" 'calc-unpack-bits) + (define-key calc-mode-map "bw" 'calc-word-size) + (define-key calc-mode-map "bx" 'calc-xor) + (define-key calc-mode-map "bB" 'calc-log) + (define-key calc-mode-map "bD" 'calc-fin-ddb) + (define-key calc-mode-map "bF" 'calc-fin-fv) + (define-key calc-mode-map "bI" 'calc-fin-irr) + (define-key calc-mode-map "bL" 'calc-lshift-arith) + (define-key calc-mode-map "bM" 'calc-fin-pmt) + (define-key calc-mode-map "bN" 'calc-fin-npv) + (define-key calc-mode-map "bP" 'calc-fin-pv) + (define-key calc-mode-map "bR" 'calc-rshift-arith) + (define-key calc-mode-map "bS" 'calc-fin-sln) + (define-key calc-mode-map "bT" 'calc-fin-rate) + (define-key calc-mode-map "bY" 'calc-fin-syd) + (define-key calc-mode-map "b#" 'calc-fin-nper) + (define-key calc-mode-map "b%" 'calc-percent-change) + + (define-key calc-mode-map "c" nil) + (define-key calc-mode-map "c?" 'calc-c-prefix-help) + (define-key calc-mode-map "cc" 'calc-clean) + (define-key calc-mode-map "cd" 'calc-to-degrees) + (define-key calc-mode-map "cf" 'calc-float) + (define-key calc-mode-map "ch" 'calc-to-hms) + (define-key calc-mode-map "cp" 'calc-polar) + (define-key calc-mode-map "cr" 'calc-to-radians) + (define-key calc-mode-map "cC" 'calc-cos) + (define-key calc-mode-map "cF" 'calc-fraction) + (define-key calc-mode-map "c%" 'calc-convert-percent) + + (define-key calc-mode-map "d" nil) + (define-key calc-mode-map "d?" 'calc-d-prefix-help) + (define-key calc-mode-map "d0" 'calc-decimal-radix) + (define-key calc-mode-map "d2" 'calc-binary-radix) + (define-key calc-mode-map "d6" 'calc-hex-radix) + (define-key calc-mode-map "d8" 'calc-octal-radix) + (define-key calc-mode-map "db" 'calc-line-breaking) + (define-key calc-mode-map "dc" 'calc-complex-notation) + (define-key calc-mode-map "dd" 'calc-date-notation) + (define-key calc-mode-map "de" 'calc-eng-notation) + (define-key calc-mode-map "df" 'calc-fix-notation) + (define-key calc-mode-map "dg" 'calc-group-digits) + (define-key calc-mode-map "dh" 'calc-hms-notation) + (define-key calc-mode-map "di" 'calc-i-notation) + (define-key calc-mode-map "dj" 'calc-j-notation) + (define-key calc-mode-map "dl" 'calc-line-numbering) + (define-key calc-mode-map "dn" 'calc-normal-notation) + (define-key calc-mode-map "do" 'calc-over-notation) + (define-key calc-mode-map "dp" 'calc-show-plain) + (define-key calc-mode-map "dr" 'calc-radix) + (define-key calc-mode-map "ds" 'calc-sci-notation) + (define-key calc-mode-map "dt" 'calc-truncate-stack) + (define-key calc-mode-map "dw" 'calc-auto-why) + (define-key calc-mode-map "dz" 'calc-leading-zeros) + (define-key calc-mode-map "dB" 'calc-big-language) + (define-key calc-mode-map "dD" 'calc-redo) + (define-key calc-mode-map "dC" 'calc-c-language) + (define-key calc-mode-map "dE" 'calc-eqn-language) + (define-key calc-mode-map "dF" 'calc-fortran-language) + (define-key calc-mode-map "dM" 'calc-mathematica-language) + (define-key calc-mode-map "dN" 'calc-normal-language) + (define-key calc-mode-map "dO" 'calc-flat-language) + (define-key calc-mode-map "dP" 'calc-pascal-language) + (define-key calc-mode-map "dT" 'calc-tex-language) + (define-key calc-mode-map "dU" 'calc-unformatted-language) + (define-key calc-mode-map "dW" 'calc-maple-language) + (define-key calc-mode-map "d[" 'calc-truncate-up) + (define-key calc-mode-map "d]" 'calc-truncate-down) + (define-key calc-mode-map "d." 'calc-point-char) + (define-key calc-mode-map "d," 'calc-group-char) + (define-key calc-mode-map "d\"" 'calc-display-strings) + (define-key calc-mode-map "d<" 'calc-left-justify) + (define-key calc-mode-map "d=" 'calc-center-justify) + (define-key calc-mode-map "d>" 'calc-right-justify) + (define-key calc-mode-map "d{" 'calc-left-label) + (define-key calc-mode-map "d}" 'calc-right-label) + (define-key calc-mode-map "d'" 'calc-display-raw) + (define-key calc-mode-map "d " 'calc-refresh) + (define-key calc-mode-map "d\r" 'calc-refresh-top) + + (define-key calc-mode-map "f" nil) + (define-key calc-mode-map "f?" 'calc-f-prefix-help) + (define-key calc-mode-map "fb" 'calc-beta) + (define-key calc-mode-map "fe" 'calc-erf) + (define-key calc-mode-map "fg" 'calc-gamma) + (define-key calc-mode-map "fh" 'calc-hypot) + (define-key calc-mode-map "fi" 'calc-im) + (define-key calc-mode-map "fj" 'calc-bessel-J) + (define-key calc-mode-map "fn" 'calc-min) + (define-key calc-mode-map "fr" 'calc-re) + (define-key calc-mode-map "fs" 'calc-sign) + (define-key calc-mode-map "fx" 'calc-max) + (define-key calc-mode-map "fy" 'calc-bessel-Y) + (define-key calc-mode-map "fA" 'calc-abssqr) + (define-key calc-mode-map "fB" 'calc-inc-beta) + (define-key calc-mode-map "fE" 'calc-expm1) + (define-key calc-mode-map "fF" 'calc-floor) + (define-key calc-mode-map "fG" 'calc-inc-gamma) + (define-key calc-mode-map "fI" 'calc-ilog) + (define-key calc-mode-map "fL" 'calc-lnp1) + (define-key calc-mode-map "fM" 'calc-mant-part) + (define-key calc-mode-map "fQ" 'calc-isqrt) + (define-key calc-mode-map "fS" 'calc-scale-float) + (define-key calc-mode-map "fT" 'calc-arctan2) + (define-key calc-mode-map "fX" 'calc-xpon-part) + (define-key calc-mode-map "f[" 'calc-decrement) + (define-key calc-mode-map "f]" 'calc-increment) + + (define-key calc-mode-map "g" nil) + (define-key calc-mode-map "g?" 'calc-g-prefix-help) + (define-key calc-mode-map "ga" 'calc-graph-add) + (define-key calc-mode-map "gb" 'calc-graph-border) + (define-key calc-mode-map "gc" 'calc-graph-clear) + (define-key calc-mode-map "gd" 'calc-graph-delete) + (define-key calc-mode-map "gf" 'calc-graph-fast) + (define-key calc-mode-map "gg" 'calc-graph-grid) + (define-key calc-mode-map "gh" 'calc-graph-header) + (define-key calc-mode-map "gk" 'calc-graph-key) + (define-key calc-mode-map "gj" 'calc-graph-juggle) + (define-key calc-mode-map "gl" 'calc-graph-log-x) + (define-key calc-mode-map "gn" 'calc-graph-name) + (define-key calc-mode-map "gp" 'calc-graph-plot) + (define-key calc-mode-map "gq" 'calc-graph-quit) + (define-key calc-mode-map "gr" 'calc-graph-range-x) + (define-key calc-mode-map "gs" 'calc-graph-line-style) + (define-key calc-mode-map "gt" 'calc-graph-title-x) + (define-key calc-mode-map "gv" 'calc-graph-view-commands) + (define-key calc-mode-map "gx" 'calc-graph-display) + (define-key calc-mode-map "gz" 'calc-graph-zero-x) + (define-key calc-mode-map "gA" 'calc-graph-add-3d) + (define-key calc-mode-map "gC" 'calc-graph-command) + (define-key calc-mode-map "gD" 'calc-graph-device) + (define-key calc-mode-map "gF" 'calc-graph-fast-3d) + (define-key calc-mode-map "gG" 'calc-argument) + (define-key calc-mode-map "gH" 'calc-graph-hide) + (define-key calc-mode-map "gK" 'calc-graph-kill) + (define-key calc-mode-map "gL" 'calc-graph-log-y) + (define-key calc-mode-map "gN" 'calc-graph-num-points) + (define-key calc-mode-map "gO" 'calc-graph-output) + (define-key calc-mode-map "gP" 'calc-graph-print) + (define-key calc-mode-map "gR" 'calc-graph-range-y) + (define-key calc-mode-map "gS" 'calc-graph-point-style) + (define-key calc-mode-map "gT" 'calc-graph-title-y) + (define-key calc-mode-map "gV" 'calc-graph-view-trail) + (define-key calc-mode-map "gX" 'calc-graph-geometry) + (define-key calc-mode-map "gZ" 'calc-graph-zero-y) + (define-key calc-mode-map "g\C-l" 'calc-graph-log-z) + (define-key calc-mode-map "g\C-r" 'calc-graph-range-z) + (define-key calc-mode-map "g\C-t" 'calc-graph-title-z) + + (define-key calc-mode-map "h" 'calc-help-prefix) + + (define-key calc-mode-map "j" nil) + (define-key calc-mode-map "j?" 'calc-j-prefix-help) + (define-key calc-mode-map "ja" 'calc-select-additional) + (define-key calc-mode-map "jb" 'calc-break-selections) + (define-key calc-mode-map "jc" 'calc-clear-selections) + (define-key calc-mode-map "jd" 'calc-show-selections) + (define-key calc-mode-map "je" 'calc-enable-selections) + (define-key calc-mode-map "jl" 'calc-select-less) + (define-key calc-mode-map "jm" 'calc-select-more) + (define-key calc-mode-map "jn" 'calc-select-next) + (define-key calc-mode-map "jo" 'calc-select-once) + (define-key calc-mode-map "jp" 'calc-select-previous) + (define-key calc-mode-map "jr" 'calc-rewrite-selection) + (define-key calc-mode-map "js" 'calc-select-here) + (define-key calc-mode-map "jv" 'calc-sel-evaluate) + (define-key calc-mode-map "ju" 'calc-unselect) + (define-key calc-mode-map "jC" 'calc-sel-commute) + (define-key calc-mode-map "jD" 'calc-sel-distribute) + (define-key calc-mode-map "jE" 'calc-sel-jump-equals) + (define-key calc-mode-map "jI" 'calc-sel-isolate) + (define-key calc-mode-map "jJ" 'calc-conj) + (define-key calc-mode-map "jL" 'calc-commute-left) + (define-key calc-mode-map "jM" 'calc-sel-merge) + (define-key calc-mode-map "jN" 'calc-sel-negate) + (define-key calc-mode-map "jO" 'calc-select-once-maybe) + (define-key calc-mode-map "jR" 'calc-commute-right) + (define-key calc-mode-map "jS" 'calc-select-here-maybe) + (define-key calc-mode-map "jU" 'calc-sel-unpack) + (define-key calc-mode-map "j&" 'calc-sel-invert) + (define-key calc-mode-map "j\r" 'calc-copy-selection) + (define-key calc-mode-map "j\n" 'calc-copy-selection) + (define-key calc-mode-map "j\010" 'calc-del-selection) + (define-key calc-mode-map "j\177" 'calc-del-selection) + (define-key calc-mode-map "j'" 'calc-enter-selection) + (define-key calc-mode-map "j`" 'calc-edit-selection) + (define-key calc-mode-map "j+" 'calc-sel-add-both-sides) + (define-key calc-mode-map "j-" 'calc-sel-sub-both-sides) + (define-key calc-mode-map "j*" 'calc-sel-mult-both-sides) + (define-key calc-mode-map "j/" 'calc-sel-div-both-sides) + (define-key calc-mode-map "j\"" 'calc-sel-expand-formula) + + (define-key calc-mode-map "k" nil) + (define-key calc-mode-map "k?" 'calc-k-prefix-help) + (define-key calc-mode-map "ka" 'calc-random-again) + (define-key calc-mode-map "kb" 'calc-bernoulli-number) + (define-key calc-mode-map "kc" 'calc-choose) + (define-key calc-mode-map "kd" 'calc-double-factorial) + (define-key calc-mode-map "ke" 'calc-euler-number) + (define-key calc-mode-map "kf" 'calc-prime-factors) + (define-key calc-mode-map "kg" 'calc-gcd) + (define-key calc-mode-map "kh" 'calc-shuffle) + (define-key calc-mode-map "kl" 'calc-lcm) + (define-key calc-mode-map "km" 'calc-moebius) + (define-key calc-mode-map "kn" 'calc-next-prime) + (define-key calc-mode-map "kp" 'calc-prime-test) + (define-key calc-mode-map "kr" 'calc-random) + (define-key calc-mode-map "ks" 'calc-stirling-number) + (define-key calc-mode-map "kt" 'calc-totient) + (define-key calc-mode-map "kB" 'calc-utpb) + (define-key calc-mode-map "kC" 'calc-utpc) + (define-key calc-mode-map "kE" 'calc-extended-gcd) + (define-key calc-mode-map "kF" 'calc-utpf) + (define-key calc-mode-map "kK" 'calc-keep-args) + (define-key calc-mode-map "kN" 'calc-utpn) + (define-key calc-mode-map "kP" 'calc-utpp) + (define-key calc-mode-map "kT" 'calc-utpt) + + (define-key calc-mode-map "m" nil) + (define-key calc-mode-map "m?" 'calc-m-prefix-help) + (define-key calc-mode-map "ma" 'calc-algebraic-mode) + (define-key calc-mode-map "md" 'calc-degrees-mode) + (define-key calc-mode-map "mf" 'calc-frac-mode) + (define-key calc-mode-map "mg" 'calc-get-modes) + (define-key calc-mode-map "mh" 'calc-hms-mode) + (define-key calc-mode-map "mi" 'calc-infinite-mode) + (define-key calc-mode-map "mm" 'calc-save-modes) + (define-key calc-mode-map "mp" 'calc-polar-mode) + (define-key calc-mode-map "mr" 'calc-radians-mode) + (define-key calc-mode-map "ms" 'calc-symbolic-mode) + (define-key calc-mode-map "mt" 'calc-total-algebraic-mode) + (define-key calc-mode-map "\emt" 'calc-total-algebraic-mode) + (define-key calc-mode-map "\em\et" 'calc-total-algebraic-mode) + (define-key calc-mode-map "mv" 'calc-matrix-mode) + (define-key calc-mode-map "mw" 'calc-working) + (define-key calc-mode-map "mx" 'calc-always-load-extensions) + (define-key calc-mode-map "mA" 'calc-alg-simplify-mode) + (define-key calc-mode-map "mB" 'calc-bin-simplify-mode) + (define-key calc-mode-map "mC" 'calc-auto-recompute) + (define-key calc-mode-map "mD" 'calc-default-simplify-mode) + (define-key calc-mode-map "mE" 'calc-ext-simplify-mode) + (define-key calc-mode-map "mF" 'calc-settings-file-name) + (define-key calc-mode-map "mM" 'calc-more-recursion-depth) + (define-key calc-mode-map "mN" 'calc-num-simplify-mode) + (define-key calc-mode-map "mO" 'calc-no-simplify-mode) + (define-key calc-mode-map "mR" 'calc-mode-record-mode) + (define-key calc-mode-map "mS" 'calc-shift-prefix) + (define-key calc-mode-map "mU" 'calc-units-simplify-mode) + (define-key calc-mode-map "mX" 'calc-load-everything) + + (define-key calc-mode-map "r" nil) + (define-key calc-mode-map "r?" 'calc-r-prefix-help) + + (define-key calc-mode-map "s" nil) + (define-key calc-mode-map "s?" 'calc-s-prefix-help) + (define-key calc-mode-map "sc" 'calc-copy-variable) + (define-key calc-mode-map "sd" 'calc-declare-variable) + (define-key calc-mode-map "se" 'calc-edit-variable) + (define-key calc-mode-map "si" 'calc-insert-variables) + (define-key calc-mode-map "sl" 'calc-let) + (define-key calc-mode-map "sm" 'calc-store-map) + (define-key calc-mode-map "sn" 'calc-store-neg) + (define-key calc-mode-map "sp" 'calc-permanent-variable) + (define-key calc-mode-map "sr" 'calc-recall) + (define-key calc-mode-map "ss" 'calc-store) + (define-key calc-mode-map "st" 'calc-store-into) + (define-key calc-mode-map "su" 'calc-unstore) + (define-key calc-mode-map "sx" 'calc-store-exchange) + (define-key calc-mode-map "sA" 'calc-edit-AlgSimpRules) + (define-key calc-mode-map "sD" 'calc-edit-Decls) + (define-key calc-mode-map "sE" 'calc-edit-EvalRules) + (define-key calc-mode-map "sF" 'calc-edit-FitRules) + (define-key calc-mode-map "sG" 'calc-edit-GenCount) + (define-key calc-mode-map "sH" 'calc-edit-Holidays) + (define-key calc-mode-map "sI" 'calc-edit-IntegLimit) + (define-key calc-mode-map "sL" 'calc-edit-LineStyles) + (define-key calc-mode-map "sP" 'calc-edit-PointStyles) + (define-key calc-mode-map "sR" 'calc-edit-PlotRejects) + (define-key calc-mode-map "sS" 'calc-sin) + (define-key calc-mode-map "sT" 'calc-edit-TimeZone) + (define-key calc-mode-map "sU" 'calc-edit-Units) + (define-key calc-mode-map "sX" 'calc-edit-ExtSimpRules) + (define-key calc-mode-map "s+" 'calc-store-plus) + (define-key calc-mode-map "s-" 'calc-store-minus) + (define-key calc-mode-map "s*" 'calc-store-times) + (define-key calc-mode-map "s/" 'calc-store-div) + (define-key calc-mode-map "s^" 'calc-store-power) + (define-key calc-mode-map "s|" 'calc-store-concat) + (define-key calc-mode-map "s&" 'calc-store-inv) + (define-key calc-mode-map "s[" 'calc-store-decr) + (define-key calc-mode-map "s]" 'calc-store-incr) + (define-key calc-mode-map "s:" 'calc-assign) + (define-key calc-mode-map "s=" 'calc-evalto) + + (define-key calc-mode-map "t" nil) + (define-key calc-mode-map "t?" 'calc-t-prefix-help) + (define-key calc-mode-map "tb" 'calc-trail-backward) + (define-key calc-mode-map "td" 'calc-trail-display) + (define-key calc-mode-map "tf" 'calc-trail-forward) + (define-key calc-mode-map "th" 'calc-trail-here) + (define-key calc-mode-map "ti" 'calc-trail-in) + (define-key calc-mode-map "tk" 'calc-trail-kill) + (define-key calc-mode-map "tm" 'calc-trail-marker) + (define-key calc-mode-map "tn" 'calc-trail-next) + (define-key calc-mode-map "to" 'calc-trail-out) + (define-key calc-mode-map "tp" 'calc-trail-previous) + (define-key calc-mode-map "tr" 'calc-trail-isearch-backward) + (define-key calc-mode-map "ts" 'calc-trail-isearch-forward) + (define-key calc-mode-map "ty" 'calc-trail-yank) + (define-key calc-mode-map "t[" 'calc-trail-first) + (define-key calc-mode-map "t]" 'calc-trail-last) + (define-key calc-mode-map "t<" 'calc-trail-scroll-left) + (define-key calc-mode-map "t>" 'calc-trail-scroll-right) + (define-key calc-mode-map "t{" 'calc-trail-backward) + (define-key calc-mode-map "t}" 'calc-trail-forward) + (define-key calc-mode-map "t." 'calc-full-trail-vectors) + (define-key calc-mode-map "tC" 'calc-convert-time-zones) + (define-key calc-mode-map "tD" 'calc-date) + (define-key calc-mode-map "tI" 'calc-inc-month) + (define-key calc-mode-map "tJ" 'calc-julian) + (define-key calc-mode-map "tM" 'calc-new-month) + (define-key calc-mode-map "tN" 'calc-now) + (define-key calc-mode-map "tP" 'calc-date-part) + (define-key calc-mode-map "tT" 'calc-tan) + (define-key calc-mode-map "tU" 'calc-unix-time) + (define-key calc-mode-map "tW" 'calc-new-week) + (define-key calc-mode-map "tY" 'calc-new-year) + (define-key calc-mode-map "tZ" 'calc-time-zone) + (define-key calc-mode-map "t+" 'calc-business-days-plus) + (define-key calc-mode-map "t-" 'calc-business-days-minus) + + (define-key calc-mode-map "u" 'nil) + (define-key calc-mode-map "u?" 'calc-u-prefix-help) + (define-key calc-mode-map "ua" 'calc-autorange-units) + (define-key calc-mode-map "ub" 'calc-base-units) + (define-key calc-mode-map "uc" 'calc-convert-units) + (define-key calc-mode-map "ud" 'calc-define-unit) + (define-key calc-mode-map "ue" 'calc-explain-units) + (define-key calc-mode-map "ug" 'calc-get-unit-definition) + (define-key calc-mode-map "up" 'calc-permanent-units) + (define-key calc-mode-map "ur" 'calc-remove-units) + (define-key calc-mode-map "us" 'calc-simplify-units) + (define-key calc-mode-map "ut" 'calc-convert-temperature) + (define-key calc-mode-map "uu" 'calc-undefine-unit) + (define-key calc-mode-map "uv" 'calc-enter-units-table) + (define-key calc-mode-map "ux" 'calc-extract-units) + (define-key calc-mode-map "uV" 'calc-view-units-table) + (define-key calc-mode-map "uC" 'calc-vector-covariance) + (define-key calc-mode-map "uG" 'calc-vector-geometric-mean) + (define-key calc-mode-map "uM" 'calc-vector-mean) + (define-key calc-mode-map "uN" 'calc-vector-min) + (define-key calc-mode-map "uS" 'calc-vector-sdev) + (define-key calc-mode-map "uU" 'calc-undo) + (define-key calc-mode-map "uX" 'calc-vector-max) + (define-key calc-mode-map "u#" 'calc-vector-count) + (define-key calc-mode-map "u+" 'calc-vector-sum) + (define-key calc-mode-map "u*" 'calc-vector-product) + + (define-key calc-mode-map "v" 'nil) + (define-key calc-mode-map "v?" 'calc-v-prefix-help) + (define-key calc-mode-map "va" 'calc-arrange-vector) + (define-key calc-mode-map "vb" 'calc-build-vector) + (define-key calc-mode-map "vc" 'calc-mcol) + (define-key calc-mode-map "vd" 'calc-diag) + (define-key calc-mode-map "ve" 'calc-expand-vector) + (define-key calc-mode-map "vf" 'calc-vector-find) + (define-key calc-mode-map "vh" 'calc-head) + (define-key calc-mode-map "vi" 'calc-ident) + (define-key calc-mode-map "vk" 'calc-cons) + (define-key calc-mode-map "vl" 'calc-vlength) + (define-key calc-mode-map "vm" 'calc-mask-vector) + (define-key calc-mode-map "vn" 'calc-rnorm) + (define-key calc-mode-map "vp" 'calc-pack) + (define-key calc-mode-map "vr" 'calc-mrow) + (define-key calc-mode-map "vs" 'calc-subvector) + (define-key calc-mode-map "vt" 'calc-transpose) + (define-key calc-mode-map "vu" 'calc-unpack) + (define-key calc-mode-map "vv" 'calc-reverse-vector) + (define-key calc-mode-map "vx" 'calc-index) + (define-key calc-mode-map "vA" 'calc-apply) + (define-key calc-mode-map "vC" 'calc-cross) + (define-key calc-mode-map "vD" 'calc-mdet) + (define-key calc-mode-map "vE" 'calc-set-enumerate) + (define-key calc-mode-map "vF" 'calc-set-floor) + (define-key calc-mode-map "vG" 'calc-grade) + (define-key calc-mode-map "vH" 'calc-histogram) + (define-key calc-mode-map "vI" 'calc-inner-product) + (define-key calc-mode-map "vJ" 'calc-conj-transpose) + (define-key calc-mode-map "vL" 'calc-mlud) + (define-key calc-mode-map "vM" 'calc-map) + (define-key calc-mode-map "vN" 'calc-cnorm) + (define-key calc-mode-map "vO" 'calc-outer-product) + (define-key calc-mode-map "vR" 'calc-reduce) + (define-key calc-mode-map "vS" 'calc-sort) + (define-key calc-mode-map "vT" 'calc-mtrace) + (define-key calc-mode-map "vU" 'calc-accumulate) + (define-key calc-mode-map "vV" 'calc-set-union) + (define-key calc-mode-map "vX" 'calc-set-xor) + (define-key calc-mode-map "v^" 'calc-set-intersect) + (define-key calc-mode-map "v-" 'calc-set-difference) + (define-key calc-mode-map "v~" 'calc-set-complement) + (define-key calc-mode-map "v:" 'calc-set-span) + (define-key calc-mode-map "v#" 'calc-set-cardinality) + (define-key calc-mode-map "v+" 'calc-remove-duplicates) + (define-key calc-mode-map "v&" 'calc-inv) + (define-key calc-mode-map "v<" 'calc-matrix-left-justify) + (define-key calc-mode-map "v=" 'calc-matrix-center-justify) + (define-key calc-mode-map "v>" 'calc-matrix-right-justify) + (define-key calc-mode-map "v." 'calc-full-vectors) + (define-key calc-mode-map "v/" 'calc-break-vectors) + (define-key calc-mode-map "v," 'calc-vector-commas) + (define-key calc-mode-map "v[" 'calc-vector-brackets) + (define-key calc-mode-map "v]" 'calc-matrix-brackets) + (define-key calc-mode-map "v{" 'calc-vector-braces) + (define-key calc-mode-map "v}" 'calc-matrix-brackets) + (define-key calc-mode-map "v(" 'calc-vector-parens) + (define-key calc-mode-map "v)" 'calc-matrix-brackets) + (define-key calc-mode-map "V" (lookup-key calc-mode-map "v")) + + (define-key calc-mode-map "z" 'nil) + (define-key calc-mode-map "z?" 'calc-z-prefix-help) + + (define-key calc-mode-map "Z" 'nil) + (define-key calc-mode-map "Z?" 'calc-shift-Z-prefix-help) + (define-key calc-mode-map "ZC" 'calc-user-define-composition) + (define-key calc-mode-map "ZD" 'calc-user-define) + (define-key calc-mode-map "ZE" 'calc-user-define-edit) + (define-key calc-mode-map "ZF" 'calc-user-define-formula) + (define-key calc-mode-map "ZG" 'calc-get-user-defn) + (define-key calc-mode-map "ZI" 'calc-user-define-invocation) + (define-key calc-mode-map "ZK" 'calc-user-define-kbd-macro) + (define-key calc-mode-map "ZP" 'calc-user-define-permanent) + (define-key calc-mode-map "ZS" 'calc-edit-user-syntax) + (define-key calc-mode-map "ZT" 'calc-timing) + (define-key calc-mode-map "ZU" 'calc-user-undefine) + (define-key calc-mode-map "Z[" 'calc-kbd-if) + (define-key calc-mode-map "Z:" 'calc-kbd-else) + (define-key calc-mode-map "Z|" 'calc-kbd-else-if) + (define-key calc-mode-map "Z]" 'calc-kbd-end-if) + (define-key calc-mode-map "Z<" 'calc-kbd-repeat) + (define-key calc-mode-map "Z>" 'calc-kbd-end-repeat) + (define-key calc-mode-map "Z(" 'calc-kbd-for) + (define-key calc-mode-map "Z)" 'calc-kbd-end-for) + (define-key calc-mode-map "Z{" 'calc-kbd-loop) + (define-key calc-mode-map "Z}" 'calc-kbd-end-loop) + (define-key calc-mode-map "Z/" 'calc-kbd-break) + (define-key calc-mode-map "Z`" 'calc-kbd-push) + (define-key calc-mode-map "Z'" 'calc-kbd-pop) + (define-key calc-mode-map "Z=" 'calc-kbd-report) + (define-key calc-mode-map "Z#" 'calc-kbd-query) + + (calc-init-prefixes) + + (mapcar (function + (lambda (x) + (define-key calc-mode-map (format "c%c" x) 'calc-clean-num) + (define-key calc-mode-map (format "j%c" x) 'calc-select-part) + (define-key calc-mode-map (format "r%c" x) 'calc-recall-quick) + (define-key calc-mode-map (format "s%c" x) 'calc-store-quick) + (define-key calc-mode-map (format "t%c" x) 'calc-store-into-quick) + (define-key calc-mode-map (format "u%c" x) 'calc-quick-units))) + "0123456789") + + (or calc-emacs-type-19 (progn + (let ((i ?A)) + (while (and (<= i ?z) (vectorp calc-mode-map)) + (if (eq (car-safe (aref calc-mode-map i)) 'keymap) + (aset calc-mode-map i + (cons 'keymap (cons (cons ?\e (aref calc-mode-map i)) + (cdr (aref calc-mode-map i)))))) + (setq i (1+ i)))) + + (setq calc-alg-map (copy-sequence calc-mode-map) + calc-alg-esc-map (copy-sequence esc-map)) + (let ((i 32)) + (while (< i 127) + (or (memq i '(?' ?` ?= ??)) + (aset calc-alg-map i 'calc-auto-algebraic-entry)) + (or (memq i '(?# ?x ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) + (aset calc-alg-esc-map i (aref calc-mode-map i))) + (setq i (1+ i)))) + (define-key calc-alg-map "\e" calc-alg-esc-map) + (define-key calc-alg-map "\e\t" 'calc-roll-up) + (define-key calc-alg-map "\e\C-m" 'calc-last-args-stub) + (define-key calc-alg-map "\e\177" 'calc-pop-above) + )) + + ;; The following is a relic for backward compatability only. + ;; The calc-define property list is now the recommended method. + (if (and (boundp 'calc-ext-defs) + calc-ext-defs) + (progn + (calc-need-macros) + (message "Evaluating calc-ext-defs...") + (eval (cons 'progn calc-ext-defs)) + (setq calc-ext-defs nil))) + +;;;; (Autoloads here) + (mapcar (function (lambda (x) + (mapcar (function (lambda (func) + (autoload func (car x)))) (cdr x)))) + '( + + ("calc-alg" calc-Need-calc-alg calc-has-rules +calc-modify-simplify-mode calcFunc-collect calcFunc-esimplify +calcFunc-islin calcFunc-islinnt calcFunc-lin calcFunc-linnt +calcFunc-simplify calcFunc-subst math-beforep +math-build-polynomial-expr math-expand-formula math-expr-contains +math-expr-contains-count math-expr-depends math-expr-height +math-expr-subst math-expr-weight math-integer-plus math-is-linear +math-is-multiple math-is-polynomial math-linear-in math-multiple-of +math-need-std-simps math-poly-depends math-poly-mix math-poly-mul +math-poly-simplify math-poly-zerop math-polynomial-base +math-polynomial-p math-recompile-eval-rules math-simplify +math-simplify-exp math-simplify-extended math-simplify-sqrt +math-to-simple-fraction) + + ("calc-alg-2" calc-Need-calc-alg-2 calcFunc-asum calcFunc-deriv +calcFunc-ffinv calcFunc-finv calcFunc-fsolve calcFunc-gpoly +calcFunc-integ calcFunc-poly calcFunc-prod calcFunc-roots +calcFunc-solve calcFunc-sum calcFunc-table calcFunc-taylor +calcFunc-tderiv math-expr-calls math-integral-q02 math-integral-q12 +math-integral-rational-funcs math-lcm-denoms math-looks-evenp +math-poly-all-roots math-prod-rec math-reject-solution math-solve-eqn +math-solve-for math-sum-rec math-try-integral) + + ("calc-alg-3" calc-Need-calc-alg-3 calcFunc-efit calcFunc-fit +calcFunc-fitdummy calcFunc-fitparam calcFunc-fitvar +calcFunc-hasfitparams calcFunc-hasfitvars calcFunc-maximize +calcFunc-minimize calcFunc-ninteg calcFunc-polint calcFunc-ratint +calcFunc-root calcFunc-wmaximize calcFunc-wminimize calcFunc-wroot +calcFunc-xfit math-find-minimum math-find-root math-ninteg-evaluate +math-ninteg-midpoint math-ninteg-romberg math-poly-interp) + + ("calc-arith" calc-Need-calc-arith calcFunc-abs calcFunc-abssqr +calcFunc-add calcFunc-ceil calcFunc-decr calcFunc-deven calcFunc-dimag +calcFunc-dint calcFunc-div calcFunc-dnatnum calcFunc-dneg +calcFunc-dnonneg calcFunc-dnonzero calcFunc-dnumint calcFunc-dodd +calcFunc-dpos calcFunc-drange calcFunc-drat calcFunc-dreal +calcFunc-dscalar calcFunc-fceil calcFunc-ffloor calcFunc-float +calcFunc-fround calcFunc-frounde calcFunc-froundu calcFunc-ftrunc +calcFunc-idiv calcFunc-incr calcFunc-mant calcFunc-max calcFunc-min +calcFunc-mod calcFunc-mul calcFunc-neg calcFunc-percent calcFunc-pow +calcFunc-relch calcFunc-round calcFunc-rounde calcFunc-roundu +calcFunc-scf calcFunc-sub calcFunc-xpon math-abs math-abs-approx +math-add-objects-fancy math-add-or-sub math-add-symb-fancy +math-ceiling math-combine-prod math-combine-sum math-div-by-zero +math-div-objects-fancy math-div-symb-fancy math-div-zero +math-float-fancy math-floor-fancy math-floor-special math-guess-if-neg +math-intv-constp math-known-evenp math-known-imagp math-known-integerp +math-known-matrixp math-known-negp math-known-nonnegp +math-known-nonposp math-known-nonzerop math-known-num-integerp +math-known-oddp math-known-posp math-known-realp math-known-scalarp +math-max math-min math-mod-fancy math-mul-float math-mul-objects-fancy +math-mul-or-div math-mul-symb-fancy math-mul-zero math-neg-fancy +math-neg-float math-okay-neg math-possible-signs math-possible-types +math-pow-fancy math-pow-mod math-pow-of-zero math-pow-zero +math-quarter-integer math-round math-setup-declarations math-sqr +math-sqr-float math-trunc-fancy math-trunc-special) + + ("calc-bin" calc-Need-calc-bin calcFunc-and calcFunc-ash +calcFunc-clip calcFunc-diff calcFunc-lsh calcFunc-not calcFunc-or +calcFunc-rash calcFunc-rot calcFunc-rsh calcFunc-xor math-clip +math-compute-max-digits math-convert-radix-digits math-float-parts +math-format-bignum-binary math-format-bignum-hex +math-format-bignum-octal math-format-bignum-radix math-format-binary +math-format-radix math-format-radix-float math-integer-log2 +math-power-of-2 math-radix-float-power) + + ("calc-comb" calc-Need-calc-comb calc-report-prime-test +calcFunc-choose calcFunc-dfact calcFunc-egcd calcFunc-fact +calcFunc-gcd calcFunc-lcm calcFunc-moebius calcFunc-nextprime +calcFunc-perm calcFunc-prevprime calcFunc-prfac calcFunc-prime +calcFunc-random calcFunc-shuffle calcFunc-stir1 calcFunc-stir2 +calcFunc-totient math-init-random-base math-member math-prime-test +math-random-base) + + ("calc-comp" calc-Need-calc-comp calcFunc-cascent calcFunc-cdescent +calcFunc-cheight calcFunc-cwidth math-comp-ascent math-comp-descent +math-comp-height math-comp-width math-compose-expr +math-composition-to-string math-stack-value-offset-fancy +math-vector-is-string math-vector-to-string) + + ("calc-cplx" calc-Need-calc-cplx calcFunc-arg calcFunc-conj +calcFunc-im calcFunc-polar calcFunc-re calcFunc-rect math-complex +math-fix-circular math-imaginary math-imaginary-i math-normalize-polar +math-polar math-want-polar) + + ("calc-embed" calc-Need-calc-embed calc-do-embedded +calc-do-embedded-activate calc-embedded-evaluate-expr +calc-embedded-modes-change calc-embedded-var-change) + + ("calc-fin" calc-Need-calc-fin calc-to-percentage calcFunc-ddb +calcFunc-fv calcFunc-fvb calcFunc-fvl calcFunc-irr calcFunc-irrb +calcFunc-nper calcFunc-nperb calcFunc-nperl calcFunc-npv calcFunc-npvb +calcFunc-pmt calcFunc-pmtb calcFunc-pv calcFunc-pvb calcFunc-pvl +calcFunc-rate calcFunc-rateb calcFunc-ratel calcFunc-sln calcFunc-syd) + + ("calc-forms" calc-Need-calc-forms calcFunc-badd calcFunc-bsub +calcFunc-date calcFunc-day calcFunc-dsadj calcFunc-hms +calcFunc-holiday calcFunc-hour calcFunc-incmonth calcFunc-incyear +calcFunc-intv calcFunc-julian calcFunc-makemod calcFunc-minute +calcFunc-month calcFunc-newmonth calcFunc-newweek calcFunc-newyear +calcFunc-now calcFunc-pwday calcFunc-sdev calcFunc-second +calcFunc-time calcFunc-tzconv calcFunc-tzone calcFunc-unixtime +calcFunc-weekday calcFunc-year calcFunc-yearday math-combine-intervals +math-date-parts math-date-to-dt math-div-mod math-dt-to-date +math-format-date math-from-business-day math-from-hms math-make-intv +math-make-mod math-make-sdev math-mod-intv math-normalize-hms +math-normalize-mod math-parse-date math-read-angle-brackets +math-setup-add-holidays math-setup-holidays math-setup-year-holidays +math-sort-intv math-to-business-day math-to-hms) + + ("calc-frac" calc-Need-calc-frac calc-add-fractions +calc-div-fractions calc-mul-fractions calcFunc-fdiv calcFunc-frac +math-make-frac) + + ("calc-funcs" calc-Need-calc-funcs calc-prob-dist calcFunc-bern +calcFunc-besJ calcFunc-besY calcFunc-beta calcFunc-betaB +calcFunc-betaI calcFunc-erf calcFunc-erfc calcFunc-euler +calcFunc-gamma calcFunc-gammaG calcFunc-gammaP calcFunc-gammaQ +calcFunc-gammag calcFunc-ltpb calcFunc-ltpc calcFunc-ltpf +calcFunc-ltpn calcFunc-ltpp calcFunc-ltpt calcFunc-utpb calcFunc-utpc +calcFunc-utpf calcFunc-utpn calcFunc-utpp calcFunc-utpt +math-bernoulli-number math-gammap1-raw) + + ("calc-graph" calc-Need-calc-graph calc-graph-show-tty) + + ("calc-help" calc-Need-calc-help) + + ("calc-incom" calc-Need-calc-incom calc-digit-dots) + + ("calc-keypd" calc-Need-calc-keypd calc-do-keypad +calc-keypad-x-left-click calc-keypad-x-middle-click +calc-keypad-x-right-click) + + ("calc-lang" calc-Need-calc-lang calc-set-language +math-read-big-balance math-read-big-rec) + + ("calc-map" calc-Need-calc-map calc-get-operator calcFunc-accum +calcFunc-afixp calcFunc-anest calcFunc-apply calcFunc-call +calcFunc-fixp calcFunc-inner calcFunc-map calcFunc-mapa calcFunc-mapc +calcFunc-mapd calcFunc-mapeq calcFunc-mapeqp calcFunc-mapeqr +calcFunc-mapr calcFunc-nest calcFunc-outer calcFunc-raccum +calcFunc-reduce calcFunc-reducea calcFunc-reducec calcFunc-reduced +calcFunc-reducer calcFunc-rreduce calcFunc-rreducea calcFunc-rreducec +calcFunc-rreduced calcFunc-rreducer math-build-call +math-calcFunc-to-var math-multi-subst math-multi-subst-rec +math-var-to-calcFunc) + + ("calc-mat" calc-Need-calc-mat calcFunc-det calcFunc-lud calcFunc-tr +math-col-matrix math-lud-solve math-matrix-inv-raw math-matrix-lud +math-mul-mat-vec math-mul-mats math-row-matrix) + + ("calc-math" calc-Need-calc-math calcFunc-alog calcFunc-arccos +calcFunc-arccosh calcFunc-arcsin calcFunc-arcsincos calcFunc-arcsinh +calcFunc-arctan calcFunc-arctan2 calcFunc-arctanh calcFunc-cos +calcFunc-cosh calcFunc-deg calcFunc-exp calcFunc-exp10 calcFunc-expm1 +calcFunc-hypot calcFunc-ilog calcFunc-isqrt calcFunc-ln calcFunc-lnp1 +calcFunc-log calcFunc-log10 calcFunc-nroot calcFunc-rad calcFunc-sin +calcFunc-sincos calcFunc-sinh calcFunc-sqr calcFunc-sqrt calcFunc-tan +calcFunc-tanh math-arccos-raw math-arcsin-raw math-arctan-raw +math-arctan2-raw math-cos-raw math-exp-minus-1-raw math-exp-raw +math-from-radians math-from-radians-2 math-hypot math-infinite-dir +math-isqrt-small math-ln-raw math-nearly-equal math-nearly-equal-float +math-nearly-zerop math-nearly-zerop-float math-nth-root +math-sin-cos-raw math-sin-raw math-sqrt math-sqrt-float math-sqrt-raw +math-tan-raw math-to-radians math-to-radians-2) + + ("calc-mode" calc-Need-calc-mode math-get-modes-vec) + + ("calc-poly" calc-Need-calc-poly calcFunc-apart calcFunc-expand +calcFunc-expandpow calcFunc-factor calcFunc-factors calcFunc-nrat +calcFunc-pcont calcFunc-pdeg calcFunc-pdiv calcFunc-pdivide +calcFunc-pdivrem calcFunc-pgcd calcFunc-plead calcFunc-pprim +calcFunc-prem math-accum-factors math-atomic-factorp +math-div-poly-const math-div-thru math-expand-power math-expand-term +math-factor-contains math-factor-expr math-factor-expr-part +math-factor-expr-try math-factor-finish math-factor-poly-coefs +math-factor-protect math-mul-thru math-padded-polynomial +math-partial-fractions math-poly-degree math-poly-deriv-coefs +math-poly-gcd-frac-list math-poly-modulus-rec math-ratpoly-p +math-to-ratpoly math-to-ratpoly-rec) + + ("calc-prog" calc-Need-calc-prog calc-default-formula-arglist +calc-execute-kbd-macro calc-finish-user-syntax-edit +calc-fix-token-name calc-fix-user-formula calc-read-parse-table +calc-read-parse-table-part calc-subsetp calc-write-parse-table +calc-write-parse-table-part calcFunc-constant calcFunc-eq calcFunc-geq +calcFunc-gt calcFunc-if calcFunc-in calcFunc-integer calcFunc-istrue +calcFunc-land calcFunc-leq calcFunc-lnot calcFunc-lor calcFunc-lt +calcFunc-negative calcFunc-neq calcFunc-nonvar calcFunc-real +calcFunc-refers calcFunc-rmeq calcFunc-typeof calcFunc-variable +math-body-refers-to math-break math-composite-inequalities +math-do-defmath math-handle-for math-handle-foreach +math-normalize-logical-op math-return) + + ("calc-rewr" calc-Need-calc-rewr calcFunc-match calcFunc-matches +calcFunc-matchnot calcFunc-rewrite calcFunc-vmatches +math-apply-rewrites math-compile-patterns math-compile-rewrites +math-flatten-lands math-match-patterns math-rewrite +math-rewrite-heads) + + ("calc-rules" calc-CommuteRules calc-DistribRules calc-FactorRules +calc-FitRules calc-IntegAfterRules calc-InvertRules calc-JumpRules +calc-MergeRules calc-Need-calc-rules calc-NegateRules +calc-compile-rule-set) + + ("calc-sel" calc-Need-calc-sel calc-auto-selection +calc-delete-selection calc-encase-atoms calc-find-assoc-parent-formula +calc-find-parent-formula calc-find-sub-formula calc-prepare-selection +calc-preserve-point calc-replace-selections calc-replace-sub-formula +calc-roll-down-with-selections calc-roll-up-with-selections +calc-sel-error) + + ("calc-sel-2" calc-Need-calc-sel-2) + + ("calc-stat" calc-Need-calc-stat calc-vector-op calcFunc-agmean +calcFunc-vcorr calcFunc-vcount calcFunc-vcov calcFunc-vflat +calcFunc-vgmean calcFunc-vhmean calcFunc-vmax calcFunc-vmean +calcFunc-vmeane calcFunc-vmedian calcFunc-vmin calcFunc-vpcov +calcFunc-vprod calcFunc-vpsdev calcFunc-vpvar calcFunc-vsdev +calcFunc-vsum calcFunc-vvar math-flatten-many-vecs) + + ("calc-store" calc-Need-calc-store calc-read-var-name +calc-store-value calc-var-name) + + ("calc-stuff" calc-Need-calc-stuff calc-explain-why calcFunc-clean +calcFunc-pclean calcFunc-pfloat calcFunc-pfrac) + + ("calc-trail" calc-Need-calc-trail) + + ("calc-undo" calc-Need-calc-undo) + + ("calc-units" calc-Need-calc-units calcFunc-usimplify +math-build-units-table math-build-units-table-buffer +math-check-unit-name math-convert-temperature math-convert-units +math-extract-units math-remove-units math-simplify-units +math-single-units-in-expr-p math-to-standard-units +math-units-in-expr-p) + + ("calc-vec" calc-Need-calc-vec calcFunc-append calcFunc-appendrev +calcFunc-arrange calcFunc-cnorm calcFunc-cons calcFunc-cross +calcFunc-ctrn calcFunc-cvec calcFunc-diag calcFunc-find +calcFunc-getdiag calcFunc-grade calcFunc-head calcFunc-histogram +calcFunc-idn calcFunc-index calcFunc-mcol calcFunc-mdims +calcFunc-mrcol calcFunc-mrow calcFunc-mrrow calcFunc-pack +calcFunc-rcons calcFunc-rdup calcFunc-rev calcFunc-rgrade +calcFunc-rhead calcFunc-rnorm calcFunc-rsort calcFunc-rsubvec +calcFunc-rtail calcFunc-sort calcFunc-subscr calcFunc-subvec +calcFunc-tail calcFunc-trn calcFunc-unpack calcFunc-unpackt +calcFunc-vcard calcFunc-vcompl calcFunc-vconcat calcFunc-vconcatrev +calcFunc-vdiff calcFunc-vec calcFunc-venum calcFunc-vexp +calcFunc-vfloor calcFunc-vint calcFunc-vlen calcFunc-vmask +calcFunc-vpack calcFunc-vspan calcFunc-vunion calcFunc-vunpack +calcFunc-vxor math-check-for-commas math-clean-set math-copy-matrix +math-dimension-error math-dot-product math-flatten-vector math-map-vec +math-map-vec-2 math-mat-col math-mimic-ident math-prepare-set +math-read-brackets math-reduce-cols math-reduce-vec math-transpose) + + ("calc-yank" calc-Need-calc-yank calc-alg-edit calc-clean-newlines +calc-do-grab-rectangle calc-do-grab-region calc-finish-stack-edit +calc-force-refresh calc-locate-cursor-element calc-show-edit-buffer) + +)) + + (mapcar (function (lambda (x) + (mapcar (function (lambda (cmd) + (autoload cmd (car x) nil t))) (cdr x)))) + '( + + ("calc-alg" calc-alg-evaluate calc-apart calc-collect calc-expand +calc-expand-formula calc-factor calc-normalize-rat calc-poly-div +calc-poly-div-rem calc-poly-gcd calc-poly-rem calc-simplify +calc-simplify-extended calc-substitute) + + ("calc-alg-2" calc-alt-summation calc-derivative +calc-dump-integral-cache calc-integral calc-num-integral +calc-poly-roots calc-product calc-solve-for calc-summation +calc-tabulate calc-taylor) + + ("calc-alg-3" calc-curve-fit calc-find-maximum calc-find-minimum +calc-find-root calc-poly-interp) + + ("calc-arith" calc-abs calc-abssqr calc-ceiling calc-decrement +calc-floor calc-idiv calc-increment calc-mant-part calc-max calc-min +calc-round calc-scale-float calc-sign calc-trunc calc-xpon-part) + + ("calc-bin" calc-and calc-binary-radix calc-clip calc-decimal-radix +calc-diff calc-hex-radix calc-leading-zeros calc-lshift-arith +calc-lshift-binary calc-not calc-octal-radix calc-or calc-radix +calc-rotate-binary calc-rshift-arith calc-rshift-binary calc-word-size +calc-xor) + + ("calc-comb" calc-choose calc-double-factorial calc-extended-gcd +calc-factorial calc-gamma calc-gcd calc-lcm calc-moebius +calc-next-prime calc-perm calc-prev-prime calc-prime-factors +calc-prime-test calc-random calc-random-again calc-rrandom +calc-shuffle calc-totient) + + ("calc-cplx" calc-argument calc-complex-notation calc-i-notation +calc-im calc-j-notation calc-polar calc-polar-mode calc-re) + + ("calc-embed" calc-embedded-copy-formula-as-kill +calc-embedded-duplicate calc-embedded-edit calc-embedded-forget +calc-embedded-kill-formula calc-embedded-mark-formula +calc-embedded-new-formula calc-embedded-next calc-embedded-previous +calc-embedded-select calc-embedded-update-formula calc-embedded-word +calc-find-globals calc-show-plain) + + ("calc-fin" calc-convert-percent calc-fin-ddb calc-fin-fv +calc-fin-irr calc-fin-nper calc-fin-npv calc-fin-pmt calc-fin-pv +calc-fin-rate calc-fin-sln calc-fin-syd calc-percent-change) + + ("calc-forms" calc-business-days-minus calc-business-days-plus +calc-convert-time-zones calc-date calc-date-notation calc-date-part +calc-from-hms calc-hms-mode calc-hms-notation calc-inc-month +calc-julian calc-new-month calc-new-week calc-new-year calc-now +calc-time calc-time-zone calc-to-hms calc-unix-time) + + ("calc-frac" calc-fdiv calc-frac-mode calc-fraction +calc-over-notation calc-slash-notation) + + ("calc-funcs" calc-bernoulli-number calc-bessel-J calc-bessel-Y +calc-beta calc-erf calc-erfc calc-euler-number calc-inc-beta +calc-inc-gamma calc-stirling-number calc-utpb calc-utpc calc-utpf +calc-utpn calc-utpp calc-utpt) + + ("calc-graph" calc-graph-add calc-graph-add-3d calc-graph-border +calc-graph-clear calc-graph-command calc-graph-delete +calc-graph-device calc-graph-display calc-graph-fast +calc-graph-fast-3d calc-graph-geometry calc-graph-grid +calc-graph-header calc-graph-hide calc-graph-juggle calc-graph-key +calc-graph-kill calc-graph-line-style calc-graph-log-x +calc-graph-log-y calc-graph-log-z calc-graph-name +calc-graph-num-points calc-graph-output calc-graph-plot +calc-graph-point-style calc-graph-print calc-graph-quit +calc-graph-range-x calc-graph-range-y calc-graph-range-z +calc-graph-show-dumb calc-graph-title-x calc-graph-title-y +calc-graph-title-z calc-graph-view-commands calc-graph-view-trail +calc-graph-zero-x calc-graph-zero-y) + + ("calc-help" calc-a-prefix-help calc-b-prefix-help calc-c-prefix-help +calc-d-prefix-help calc-describe-function calc-describe-key +calc-describe-key-briefly calc-describe-variable calc-f-prefix-help +calc-full-help calc-g-prefix-help calc-help-prefix +calc-hyperbolic-prefix-help calc-inv-hyp-prefix-help +calc-inverse-prefix-help calc-j-prefix-help calc-k-prefix-help +calc-m-prefix-help calc-r-prefix-help calc-s-prefix-help +calc-t-prefix-help calc-u-prefix-help calc-v-prefix-help) + + ("calc-incom" calc-begin-complex calc-begin-vector calc-comma +calc-dots calc-end-complex calc-end-vector calc-semi) + + ("calc-keypd" calc-keypad-menu calc-keypad-menu-back +calc-keypad-press) + + ("calc-lang" calc-big-language calc-c-language calc-eqn-language +calc-flat-language calc-fortran-language calc-maple-language +calc-mathematica-language calc-normal-language calc-pascal-language +calc-tex-language calc-unformatted-language) + + ("calc-map" calc-accumulate calc-apply calc-inner-product calc-map +calc-map-equation calc-map-stack calc-outer-product calc-reduce) + + ("calc-mat" calc-mdet calc-mlud calc-mtrace) + + ("calc-math" calc-arccos calc-arccosh calc-arcsin calc-arcsinh +calc-arctan calc-arctan2 calc-arctanh calc-conj calc-cos calc-cosh +calc-degrees-mode calc-exp calc-expm1 calc-hypot calc-ilog +calc-imaginary calc-isqrt calc-ln calc-lnp1 calc-log calc-log10 +calc-pi calc-radians-mode calc-sin calc-sincos calc-sinh calc-sqrt +calc-tan calc-tanh calc-to-degrees calc-to-radians) + + ("calc-mode" calc-alg-simplify-mode calc-algebraic-mode +calc-always-load-extensions calc-auto-recompute calc-auto-why +calc-bin-simplify-mode calc-break-vectors calc-center-justify +calc-default-simplify-mode calc-display-raw calc-eng-notation +calc-ext-simplify-mode calc-fix-notation calc-full-trail-vectors +calc-full-vectors calc-get-modes calc-group-char calc-group-digits +calc-infinite-mode calc-left-justify calc-left-label +calc-line-breaking calc-line-numbering calc-matrix-brackets +calc-matrix-center-justify calc-matrix-left-justify calc-matrix-mode +calc-matrix-right-justify calc-mode-record-mode calc-no-simplify-mode +calc-normal-notation calc-num-simplify-mode calc-point-char +calc-right-justify calc-right-label calc-save-modes calc-sci-notation +calc-settings-file-name calc-shift-prefix calc-symbolic-mode +calc-total-algebraic-mode calc-truncate-down calc-truncate-stack +calc-truncate-up calc-units-simplify-mode calc-vector-braces +calc-vector-brackets calc-vector-commas calc-vector-parens +calc-working) + + ("calc-prog" calc-call-last-kbd-macro calc-edit-user-syntax +calc-equal-to calc-get-user-defn calc-greater-equal calc-greater-than +calc-in-set calc-kbd-break calc-kbd-else calc-kbd-else-if +calc-kbd-end-for calc-kbd-end-if calc-kbd-end-loop calc-kbd-end-repeat +calc-kbd-for calc-kbd-if calc-kbd-loop calc-kbd-pop calc-kbd-push +calc-kbd-query calc-kbd-repeat calc-kbd-report calc-less-equal +calc-less-than calc-logical-and calc-logical-if calc-logical-not +calc-logical-or calc-not-equal-to calc-pass-errors calc-remove-equal +calc-timing calc-user-define calc-user-define-composition +calc-user-define-edit calc-user-define-formula +calc-user-define-invocation calc-user-define-kbd-macro +calc-user-define-permanent calc-user-undefine) + + ("calc-rewr" calc-match calc-rewrite calc-rewrite-selection) + + ("calc-sel" calc-break-selections calc-clear-selections +calc-copy-selection calc-del-selection calc-edit-selection +calc-enable-selections calc-enter-selection calc-sel-add-both-sides +calc-sel-div-both-sides calc-sel-evaluate calc-sel-expand-formula +calc-sel-mult-both-sides calc-sel-sub-both-sides +calc-select-additional calc-select-here calc-select-here-maybe +calc-select-less calc-select-more calc-select-next calc-select-once +calc-select-once-maybe calc-select-part calc-select-previous +calc-show-selections calc-unselect) + + ("calc-sel-2" calc-commute-left calc-commute-right calc-sel-commute +calc-sel-distribute calc-sel-invert calc-sel-isolate +calc-sel-jump-equals calc-sel-merge calc-sel-negate calc-sel-unpack) + + ("calc-stat" calc-vector-correlation calc-vector-count +calc-vector-covariance calc-vector-geometric-mean +calc-vector-harmonic-mean calc-vector-max calc-vector-mean +calc-vector-mean-error calc-vector-median calc-vector-min +calc-vector-pop-covariance calc-vector-pop-sdev +calc-vector-pop-variance calc-vector-product calc-vector-sdev +calc-vector-sum calc-vector-variance) + + ("calc-store" calc-assign calc-copy-variable calc-declare-variable +calc-edit-AlgSimpRules calc-edit-Decls calc-edit-EvalRules +calc-edit-ExtSimpRules calc-edit-FitRules calc-edit-GenCount +calc-edit-Holidays calc-edit-IntegLimit calc-edit-LineStyles +calc-edit-PlotRejects calc-edit-PointStyles calc-edit-TimeZone +calc-edit-Units calc-edit-variable calc-evalto calc-insert-variables +calc-let calc-permanent-variable calc-recall calc-recall-quick +calc-store calc-store-concat calc-store-decr calc-store-div +calc-store-exchange calc-store-incr calc-store-into +calc-store-into-quick calc-store-inv calc-store-map calc-store-minus +calc-store-neg calc-store-plus calc-store-power calc-store-quick +calc-store-times calc-subscript calc-unstore) + + ("calc-stuff" calc-clean calc-clean-num calc-flush-caches +calc-less-recursion-depth calc-more-recursion-depth calc-num-prefix +calc-version calc-why) + + ("calc-trail" calc-trail-backward calc-trail-first calc-trail-forward +calc-trail-in calc-trail-isearch-backward calc-trail-isearch-forward +calc-trail-kill calc-trail-last calc-trail-marker calc-trail-next +calc-trail-out calc-trail-previous calc-trail-scroll-left +calc-trail-scroll-right calc-trail-yank) + + ("calc-undo" calc-last-args calc-redo calc-undo) + + ("calc-units" calc-autorange-units calc-base-units +calc-convert-temperature calc-convert-units calc-define-unit +calc-enter-units-table calc-explain-units calc-extract-units +calc-get-unit-definition calc-permanent-units calc-quick-units +calc-remove-units calc-simplify-units calc-undefine-unit +calc-view-units-table) + + ("calc-vec" calc-arrange-vector calc-build-vector calc-cnorm +calc-conj-transpose calc-cons calc-cross calc-diag +calc-display-strings calc-expand-vector calc-grade calc-head +calc-histogram calc-ident calc-index calc-mask-vector calc-mcol +calc-mrow calc-pack calc-pack-bits calc-remove-duplicates +calc-reverse-vector calc-rnorm calc-set-cardinality +calc-set-complement calc-set-difference calc-set-enumerate +calc-set-floor calc-set-intersect calc-set-span calc-set-union +calc-set-xor calc-sort calc-subvector calc-tail calc-transpose +calc-unpack calc-unpack-bits calc-vector-find calc-vlength) + + ("calc-yank" calc-copy-as-kill calc-copy-region-as-kill +calc-copy-to-buffer calc-edit calc-edit-cancel calc-edit-mode +calc-kill calc-kill-region calc-yank) + +)) + +) + +(defun calc-init-prefixes () + (if calc-shift-prefix + (progn + (define-key calc-mode-map "A" (lookup-key calc-mode-map "a")) + (define-key calc-mode-map "B" (lookup-key calc-mode-map "b")) + (define-key calc-mode-map "C" (lookup-key calc-mode-map "c")) + (define-key calc-mode-map "D" (lookup-key calc-mode-map "d")) + (define-key calc-mode-map "F" (lookup-key calc-mode-map "f")) + (define-key calc-mode-map "G" (lookup-key calc-mode-map "g")) + (define-key calc-mode-map "J" (lookup-key calc-mode-map "j")) + (define-key calc-mode-map "K" (lookup-key calc-mode-map "k")) + (define-key calc-mode-map "M" (lookup-key calc-mode-map "m")) + (define-key calc-mode-map "S" (lookup-key calc-mode-map "s")) + (define-key calc-mode-map "T" (lookup-key calc-mode-map "t")) + (define-key calc-mode-map "U" (lookup-key calc-mode-map "u"))) + (define-key calc-mode-map "A" 'calc-abs) + (define-key calc-mode-map "B" 'calc-log) + (define-key calc-mode-map "C" 'calc-cos) + (define-key calc-mode-map "D" 'calc-redo) + (define-key calc-mode-map "F" 'calc-floor) + (define-key calc-mode-map "G" 'calc-argument) + (define-key calc-mode-map "J" 'calc-conj) + (define-key calc-mode-map "K" 'calc-keep-args) + (define-key calc-mode-map "M" 'calc-more-recursion-depth) + (define-key calc-mode-map "S" 'calc-sin) + (define-key calc-mode-map "T" 'calc-tan) + (define-key calc-mode-map "U" 'calc-undo)) +) + +(calc-init-extensions) + + + + +;;;; Miscellaneous. + +(defun calc-clear-command-flag (f) + (setq calc-command-flags (delq f calc-command-flags)) +) + + +(defun calc-record-message (tag &rest args) + (let ((msg (apply 'format args))) + (message "%s" msg) + (calc-record msg tag)) + (calc-clear-command-flag 'clear-message) +) + + +(defun calc-normalize-fancy (val) + (let ((simp (if (consp calc-simplify-mode) + (car calc-simplify-mode) + calc-simplify-mode))) + (cond ((eq simp 'binary) + (let ((s (math-normalize val))) + (if (math-realp s) + (math-clip (math-round s)) + s))) + ((eq simp 'alg) + (math-simplify val)) + ((eq simp 'ext) + (math-simplify-extended val)) + ((eq simp 'units) + (math-simplify-units val)) + (t ; nil, none, num + (math-normalize val)))) +) + + + +(if (boundp 'calc-help-map) + nil + (setq calc-help-map (make-keymap)) + (define-key calc-help-map "b" 'calc-describe-bindings) + (define-key calc-help-map "c" 'calc-describe-key-briefly) + (define-key calc-help-map "f" 'calc-describe-function) + (define-key calc-help-map "h" 'calc-full-help) + (define-key calc-help-map "i" 'calc-info) + (define-key calc-help-map "k" 'calc-describe-key) + (define-key calc-help-map "n" 'calc-view-news) + (define-key calc-help-map "s" 'calc-info-summary) + (define-key calc-help-map "t" 'calc-tutorial) + (define-key calc-help-map "v" 'calc-describe-variable) + (define-key calc-help-map "\C-c" 'calc-describe-copying) + (define-key calc-help-map "\C-d" 'calc-describe-distribution) + (define-key calc-help-map "\C-n" 'calc-view-news) + (define-key calc-help-map "\C-w" 'calc-describe-no-warranty) + (define-key calc-help-map "?" 'calc-help-for-help) + (define-key calc-help-map "\C-h" 'calc-help-for-help) +) + + +(defun calc-do-prefix-help (msgs group key) + (if calc-full-help-flag + (list msgs group key) + (if (cdr msgs) + (progn + (setq calc-prefix-help-phase + (if (eq this-command last-command) + (% (1+ calc-prefix-help-phase) (1+ (length msgs))) + 0)) + (let ((msg (nth calc-prefix-help-phase msgs))) + (message "%s" (if msg + (concat group ": " msg ":" + (make-string + (- (apply 'max (mapcar 'length msgs)) + (length msg)) 32) + " [MORE]" + (if key + (concat " " (char-to-string key) + "-") + "")) + (if key (format "%c-" key) ""))))) + (setq calc-prefix-help-phase 0) + (if key + (if msgs + (message "%s: %s: %c-" group (car msgs) key) + (message "%s: (none) %c-" group (car msgs) key)) + (message "%s: %s" group (car msgs)))) + (and key (calc-unread-command key))) +) +(defvar calc-prefix-help-phase 0) + + + + +;;;; Commands. + + +;;; General. + +(defun calc-reset (arg) + (interactive "P") + (save-excursion + (or (eq major-mode 'calc-mode) + (calc-create-buffer)) + (if calc-embedded-info + (calc-embedded nil)) + (or arg + (setq calc-stack nil)) + (setq calc-undo-list nil + calc-redo-list nil) + (let (calc-stack calc-user-parse-tables calc-standard-date-formats + calc-invocation-macro) + (mapcar (function (lambda (v) (set v nil))) calc-local-var-list) + (mapcar (function (lambda (v) (set (car v) (nth 1 v)))) + calc-mode-var-list)) + (calc-set-language nil nil t) + (calc-mode) + (let ((executing-kbd-macro "")) ; inhibit message + (calc-flush-caches)) + (run-hooks 'calc-reset-hook)) + (calc-wrapper + (let ((win (get-buffer-window (current-buffer)))) + (calc-realign 0) + (if win + (let ((height (- (window-height win) 2))) + (set-window-point win (point)) + (or (= height calc-window-height) + (let ((swin (selected-window))) + (select-window win) + (enlarge-window (- calc-window-height height)) + (select-window swin))))))) + (message "(Calculator reset)") +) + + +(defun calc-scroll-left (n) + (interactive "P") + (scroll-left (or n (/ (window-width) 2))) +) + +(defun calc-scroll-right (n) + (interactive "P") + (scroll-right (or n (/ (window-width) 2))) +) + +(defun calc-scroll-up (n) + (interactive "P") + (condition-case err + (scroll-up (or n (/ (window-height) 2))) + (error nil)) + (if (pos-visible-in-window-p (max 1 (- (point-max) 2))) + (if (eq major-mode 'calc-mode) + (calc-realign) + (goto-char (point-max)) + (set-window-start (selected-window) + (save-excursion + (forward-line (- (1- (window-height)))) + (point))) + (forward-line -1))) +) + +(defun calc-scroll-down (n) + (interactive "P") + (or (pos-visible-in-window-p 1) + (scroll-down (or n (/ (window-height) 2)))) +) + + +(defun calc-precision (n) + (interactive "NPrecision: ") + (calc-wrapper + (if (< (prefix-numeric-value n) 3) + (error "Precision must be at least 3 digits.") + (calc-change-mode 'calc-internal-prec (prefix-numeric-value n) + (and (memq (car calc-float-format) '(float sci eng)) + (< (nth 1 calc-float-format) + (if (= calc-number-radix 10) 0 1)))) + (calc-record calc-internal-prec "prec")) + (message "Floating-point precision is %d digits." calc-internal-prec)) +) + + +(defun calc-inverse (&optional n) + (interactive "P") + (calc-fancy-prefix 'calc-inverse-flag "Inverse..." n) +) + +(defun calc-fancy-prefix (flag msg n) + (let (prefix) + (calc-wrapper + (calc-set-command-flag 'keep-flags) + (calc-set-command-flag 'no-align) + (setq prefix (set flag (not (symbol-value flag))) + prefix-arg n) + (message (if prefix msg ""))) + (and prefix + nil ; Excise broken code we can live without. -- daveg 12/12/96 + (not calc-is-keypad-press) + (let ((event (calc-read-key t))) + (if (eq (setq last-command-char (car event)) ?\C-u) + (universal-argument) + (if (or (not (integerp last-command-char)) + (and (>= last-command-char 0) (< last-command-char ? ) + (not (memq last-command-char '(?\e))))) + (calc-wrapper)) ; clear flags if not a Calc command. + (if calc-emacs-type-19 + (setq last-command-event (cdr event))) + (if (or (not (integerp last-command-char)) + (eq last-command-char ?-)) + (calc-unread-command) + (digit-argument n)))))) +) +(setq calc-is-keypad-press nil) + +(defun calc-invert-func () + (save-excursion + (calc-select-buffer) + (setq calc-inverse-flag (not (calc-is-inverse)) + calc-hyperbolic-flag (calc-is-hyperbolic) + current-prefix-arg nil)) +) + +(defun calc-is-inverse () + calc-inverse-flag +) + +(defun calc-hyperbolic (&optional n) + (interactive "P") + (calc-fancy-prefix 'calc-hyperbolic-flag "Hyperbolic..." n) +) + +(defun calc-hyperbolic-func () + (save-excursion + (calc-select-buffer) + (setq calc-inverse-flag (calc-is-inverse) + calc-hyperbolic-flag (not (calc-is-hyperbolic)) + current-prefix-arg nil)) +) + +(defun calc-is-hyperbolic () + calc-hyperbolic-flag +) + +(defun calc-keep-args (&optional n) + (interactive "P") + (calc-fancy-prefix 'calc-keep-args-flag "Keep args..." n) +) + + +(defun calc-change-mode (var value &optional refresh option) + (if option + (setq value (if value + (> (prefix-numeric-value value) 0) + (not (symbol-value var))))) + (or (consp var) (setq var (list var) value (list value))) + (if calc-inverse-flag + (let ((old nil)) + (or refresh (error "Not a display-mode command")) + (calc-check-stack 1) + (unwind-protect + (let ((v var)) + (while v + (setq old (cons (symbol-value (car v)) old)) + (set (car v) (car value)) + (setq v (cdr v) + value (cdr value))) + (calc-refresh-top 1) + (calc-refresh-evaltos) + (symbol-value (car var))) + (let ((v var)) + (setq old (nreverse old)) + (while v + (set (car v) (car old)) + (setq v (cdr v) + old (cdr old))) + (if (eq (car var) 'calc-language) + (calc-set-language calc-language calc-language-option t))))) + (let ((chg nil) + (v var)) + (while v + (or (equal (symbol-value (car v)) (car value)) + (progn + (set (car v) (car value)) + (if (eq (car v) 'calc-float-format) + (setq calc-full-float-format + (list (if (eq (car (car value)) 'fix) + 'float + (car (car value))) + 0))) + (setq chg t))) + (setq v (cdr v) + value (cdr value))) + (if chg + (progn + (or (and refresh (calc-do-refresh)) + (calc-refresh-evaltos)) + (and (eq calc-mode-save-mode 'save) + (not (equal var '(calc-mode-save-mode))) + (calc-save-modes t)))) + (if calc-embedded-info (calc-embedded-modes-change var)) + (symbol-value (car var)))) +) + +(defun calc-refresh-top (n) + (interactive "p") + (calc-wrapper + (cond ((< n 0) + (setq n (- n)) + (let ((entry (calc-top n 'entry)) + (calc-undo-list nil) (calc-redo-list nil)) + (calc-pop-stack 1 n t) + (calc-push-list (list (car entry)) n (list (nth 2 entry))))) + ((= n 0) + (calc-refresh)) + (t + (let ((entries (calc-top-list n 1 'entry)) + (calc-undo-list nil) (calc-redo-list nil)) + (calc-pop-stack n 1 t) + (calc-push-list (mapcar 'car entries) + 1 + (mapcar (function (lambda (x) (nth 2 x))) + entries)))))) +) + +(defun calc-refresh-evaltos (&optional which-var) + (and calc-any-evaltos calc-auto-recompute (not calc-no-refresh-evaltos) + (let ((calc-refreshing-evaltos t) + (num (calc-stack-size)) + (calc-undo-list nil) (calc-redo-list nil) + value new-val) + (while (> num 0) + (setq value (calc-top num 'entry)) + (if (and (not (nth 2 value)) + (setq value (car value)) + (or (eq (car-safe value) 'calcFunc-evalto) + (and (eq (car-safe value) 'vec) + (eq (car-safe (nth 1 value)) 'calcFunc-evalto)))) + (progn + (setq new-val (math-normalize value)) + (or (equal new-val value) + (progn + (calc-push-list (list new-val) num) + (calc-pop-stack 1 (1+ num) t))))) + (setq num (1- num))))) + (and calc-embedded-active which-var + (calc-embedded-var-change which-var)) +) +(setq calc-refreshing-evaltos nil) +(setq calc-no-refresh-evaltos nil) + + +(defun calc-push (&rest vals) + (calc-push-list vals) +) + +(defun calc-pop-push (n &rest vals) + (calc-pop-push-list n vals) +) + +(defun calc-pop-push-record (n prefix &rest vals) + (calc-pop-push-record-list n prefix vals) +) + + +(defun calc-evaluate (n) + (interactive "p") + (calc-slow-wrapper + (if (= n 0) + (setq n (calc-stack-size))) + (calc-with-default-simplification + (if (< n 0) + (calc-pop-push-record-list 1 "eval" + (math-evaluate-expr (calc-top (- n))) + (- n)) + (calc-pop-push-record-list n "eval" (mapcar 'math-evaluate-expr + (calc-top-list n))))) + (calc-handle-whys)) +) + + +(defun calc-eval-num (n) + (interactive "P") + (calc-slow-wrapper + (let* ((nn (prefix-numeric-value n)) + (calc-internal-prec (cond ((>= nn 3) nn) + ((< nn 0) (max (+ calc-internal-prec nn) + 3)) + (t calc-internal-prec))) + (calc-symbolic-mode nil)) + (calc-with-default-simplification + (calc-pop-push-record 1 "num" (math-evaluate-expr (calc-top 1))))) + (calc-handle-whys)) +) + + +(defun calc-execute-extended-command (n) + (interactive "P") + (let* ((prompt (concat (calc-num-prefix-name n) "M-x ")) + (cmd (intern (completing-read prompt obarray 'commandp t "calc-")))) + (setq prefix-arg n) + (command-execute cmd)) +) + + +(defun calc-realign (&optional num) + (interactive "P") + (if (and num (eq major-mode 'calc-mode)) + (progn + (calc-check-stack num) + (calc-cursor-stack-index num) + (and calc-line-numbering + (forward-char 4))) + (if (and calc-embedded-info + (eq (current-buffer) (aref calc-embedded-info 0))) + (progn + (goto-char (aref calc-embedded-info 2)) + (if (save-excursion (set-buffer (aref calc-embedded-info 1)) + calc-show-plain) + (forward-line 1))) + (calc-wrapper + (if (get-buffer-window (current-buffer)) + (set-window-hscroll (get-buffer-window (current-buffer)) 0))))) +) + + + +(setq math-cache-list nil) + + + + +(defun calc-var-value (v) + (and (symbolp v) + (boundp v) + (symbol-value v) + (if (symbolp (symbol-value v)) + (set v (funcall (symbol-value v))) + (if (stringp (symbol-value v)) + (let ((val (math-read-expr (symbol-value v)))) + (if (eq (car-safe val) 'error) + (error "Bad format in variable contents: %s" (nth 2 val)) + (set v val))) + (symbol-value v)))) +) + + + + + +;;; In the following table, ( OP LOPS ROPS ) means that if an OP +;;; term appears as the first argument to any LOPS term, or as the +;;; second argument to any ROPS term, then they should be treated +;;; as one large term for purposes of associative selection. +(defconst calc-assoc-ops '( ( + ( + - ) ( + ) ) + ( - ( + - ) ( + ) ) + ( * ( * ) ( * ) ) + ( / ( / ) ( ) ) + ( | ( | ) ( | ) ) + ( calcFunc-land ( calcFunc-land ) + ( calcFunc-land ) ) + ( calcFunc-lor ( calcFunc-lor ) + ( calcFunc-lor ) ) )) + + +(defvar var-CommuteRules 'calc-CommuteRules) +(defvar var-JumpRules 'calc-JumpRules) +(defvar var-DistribRules 'calc-DistribRules) +(defvar var-MergeRules 'calc-MergeRules) +(defvar var-NegateRules 'calc-NegateRules) +(defvar var-InvertRules 'calc-InvertRules) + + +(defconst calc-tweak-eqn-table '( ( calcFunc-eq calcFunc-eq calcFunc-neq ) + ( calcFunc-neq calcFunc-neq calcFunc-eq ) + ( calcFunc-lt calcFunc-gt calcFunc-geq ) + ( calcFunc-gt calcFunc-lt calcFunc-leq ) + ( calcFunc-leq calcFunc-geq calcFunc-gt ) + ( calcFunc-geq calcFunc-leq calcFunc-lt ) )) + + + + +(defun calc-float (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "flt" + (if (calc-is-hyperbolic) 'calcFunc-float 'calcFunc-pfloat) + arg)) +) + + +(defvar calc-gnuplot-process nil) + + +(defun calc-gnuplot-alive () + (and calc-gnuplot-process + calc-gnuplot-buffer + (buffer-name calc-gnuplot-buffer) + calc-gnuplot-input + (buffer-name calc-gnuplot-input) + (memq (process-status calc-gnuplot-process) '(run stop))) +) + + + + + +(defun calc-load-everything () + (interactive) + (calc-need-macros) ; calc-macs.el + (calc-record-list nil) ; calc-misc.el + (math-read-exprs "0") ; calc-aent.el + +;;;; (Loads here) + (calc-Need-calc-alg-2) + (calc-Need-calc-alg-3) + (calc-Need-calc-alg) + (calc-Need-calc-arith) + (calc-Need-calc-bin) + (calc-Need-calc-comb) + (calc-Need-calc-comp) + (calc-Need-calc-cplx) + (calc-Need-calc-embed) + (calc-Need-calc-fin) + (calc-Need-calc-forms) + (calc-Need-calc-frac) + (calc-Need-calc-funcs) + (calc-Need-calc-graph) + (calc-Need-calc-help) + (calc-Need-calc-incom) + (calc-Need-calc-keypd) + (calc-Need-calc-lang) + (calc-Need-calc-map) + (calc-Need-calc-mat) + (calc-Need-calc-math) + (calc-Need-calc-mode) + (calc-Need-calc-poly) + (calc-Need-calc-prog) + (calc-Need-calc-rewr) + (calc-Need-calc-rules) + (calc-Need-calc-sel-2) + (calc-Need-calc-sel) + (calc-Need-calc-stat) + (calc-Need-calc-store) + (calc-Need-calc-stuff) + (calc-Need-calc-trail) + (calc-Need-calc-undo) + (calc-Need-calc-units) + (calc-Need-calc-vec) + (calc-Need-calc-yank) + + (message "All parts of Calc are now loaded.") +) + + +;;; Vector commands. + +(defun calc-concat (arg) + (interactive "P") + (calc-wrapper + (if (calc-is-inverse) + (if (calc-is-hyperbolic) + (calc-enter-result 2 "apnd" (list 'calcFunc-append + (calc-top 1) (calc-top 2))) + (calc-enter-result 2 "|" (list 'calcFunc-vconcat + (calc-top 1) (calc-top 2)))) + (if (calc-is-hyperbolic) + (calc-binary-op "apnd" 'calcFunc-append arg '(vec)) + (calc-binary-op "|" 'calcFunc-vconcat arg '(vec) nil '|)))) +) + +(defun calc-append (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-concat arg) +) + + +(defconst calc-arg-values '( ( var ArgA var-ArgA ) ( var ArgB var-ArgB ) + ( var ArgC var-ArgC ) ( var ArgD var-ArgD ) + ( var ArgE var-ArgE ) ( var ArgF var-ArgF ) + ( var ArgG var-ArgG ) ( var ArgH var-ArgH ) + ( var ArgI var-ArgI ) ( var ArgJ var-ArgJ ) +)) + +(defun calc-invent-args (n) + (nreverse (nthcdr (- (length calc-arg-values) n) (reverse calc-arg-values))) +) + + + + +;;; User menu. + +(defun calc-user-key-map () + (if calc-emacs-type-lucid + (error "User-defined keys are not supported in Lucid Emacs")) + (let ((res (cdr (lookup-key calc-mode-map "z")))) + (if (eq (car (car res)) 27) + (cdr res) + res)) +) + +(defun calc-z-prefix-help () + (interactive) + (let* ((msgs nil) + (buf "") + (kmap (sort (copy-sequence (calc-user-key-map)) + (function (lambda (x y) (< (car x) (car y)))))) + (flags (apply 'logior + (mapcar (function + (lambda (k) + (calc-user-function-classify (car k)))) + kmap)))) + (if (= (logand flags 8) 0) + (calc-user-function-list kmap 7) + (calc-user-function-list kmap 1) + (setq msgs (cons buf msgs) + buf "") + (calc-user-function-list kmap 6)) + (if (/= flags 0) + (setq msgs (cons buf msgs))) + (calc-do-prefix-help (nreverse msgs) "user" ?z)) +) + +(defun calc-user-function-classify (key) + (cond ((/= key (downcase key)) ; upper-case + (if (assq (downcase key) (calc-user-key-map)) 9 1)) + ((/= key (upcase key)) 2) ; lower-case + ((= key ??) 0) + (t 4)) ; other +) + +(defun calc-user-function-list (map flags) + (and map + (let* ((key (car (car map))) + (kind (calc-user-function-classify key)) + (func (cdr (car map)))) + (if (or (= (logand kind flags) 0) + (not (symbolp func))) + () + (let* ((name (symbol-name func)) + (name (if (string-match "\\`calc-" name) + (substring name 5) name)) + (pos (string-match (char-to-string key) name)) + (desc + (if (symbolp func) + (if (= (logand kind 3) 0) + (format "`%c' = %s" key name) + (if pos + (format "%s%c%s" + (downcase (substring name 0 pos)) + (upcase key) + (downcase (substring name (1+ pos)))) + (format "%c = %s" + (upcase key) + (downcase name)))) + (char-to-string (upcase key))))) + (if (= (length buf) 0) + (setq buf (concat (if (= flags 1) "SHIFT + " "") + desc)) + (if (> (+ (length buf) (length desc)) 58) + (setq msgs (cons buf msgs) + buf (concat (if (= flags 1) "SHIFT + " "") + desc)) + (setq buf (concat buf ", " desc)))))) + (calc-user-function-list (cdr map) flags))) +) + + + +(defun calc-shift-Z-prefix-help () + (interactive) + (calc-do-prefix-help + '("Define, Undefine, Formula, Kbd-macro, Edit, Get-defn" + "Composition, Syntax; Invocation; Permanent; Timing" + "kbd-macros: [ (if), : (else), | (else-if), ] (end-if)" + "kbd-macros: < > (repeat), ( ) (for), { } (loop)" + "kbd-macros: / (break)" + "kbd-macros: ` (save), ' (restore)") + "user" ?Z) +) + + +;;;; Caches. + +(defmacro math-defcache (name init form) + (let ((cache-prec (intern (concat (symbol-name name) "-cache-prec"))) + (cache-val (intern (concat (symbol-name name) "-cache"))) + (last-prec (intern (concat (symbol-name name) "-last-prec"))) + (last-val (intern (concat (symbol-name name) "-last")))) + (list 'progn + (list 'setq cache-prec (if init (math-numdigs (nth 1 init)) -100)) + (list 'setq cache-val (list 'quote init)) + (list 'setq last-prec -100) + (list 'setq last-val nil) + (list 'setq 'math-cache-list + (list 'cons + (list 'quote cache-prec) + (list 'cons + (list 'quote last-prec) + 'math-cache-list))) + (list 'defun + name () + (list 'or + (list '= last-prec 'calc-internal-prec) + (list 'setq + last-val + (list 'math-normalize + (list 'progn + (list 'or + (list '>= cache-prec + 'calc-internal-prec) + (list 'setq + cache-val + (list 'let + '((calc-internal-prec + (+ calc-internal-prec + 4))) + form) + cache-prec + '(+ calc-internal-prec 2))) + cache-val)) + last-prec 'calc-internal-prec)) + last-val))) +) +(put 'math-defcache 'lisp-indent-hook 2) + +;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public] +(math-defcache math-pi (float (bigpos 463 238 793 589 653 592 141 3) -21) + (math-add-float (math-mul-float '(float 16 0) + (math-arctan-raw '(float 2 -1))) + (math-mul-float '(float -4 0) + (math-arctan-raw + (math-float '(frac 1 239)))))) + +(math-defcache math-two-pi nil + (math-mul-float (math-pi) '(float 2 0))) + +(math-defcache math-pi-over-2 nil + (math-mul-float (math-pi) '(float 5 -1))) + +(math-defcache math-pi-over-4 nil + (math-mul-float (math-pi) '(float 25 -2))) + +(math-defcache math-pi-over-180 nil + (math-div-float (math-pi) '(float 18 1))) + +(math-defcache math-sqrt-pi nil + (math-sqrt-float (math-pi))) + +(math-defcache math-sqrt-2 nil + (math-sqrt-float '(float 2 0))) + +(math-defcache math-sqrt-12 nil + (math-sqrt-float '(float 12 0))) + +(math-defcache math-sqrt-two-pi nil + (math-sqrt-float (math-two-pi))) + +(math-defcache math-sqrt-e (float (bigpos 849 146 128 700 270 721 648 1) -21) + (math-add-float '(float 1 0) (math-exp-minus-1-raw '(float 5 -1)))) + +(math-defcache math-e nil + (math-pow (math-sqrt-e) 2)) + +(math-defcache math-phi nil + (math-mul-float (math-add-float (math-sqrt-raw '(float 5 0)) '(float 1 0)) + '(float 5 -1))) + +(math-defcache math-gamma-const nil + '(float (bigpos 495 467 917 632 470 369 709 646 776 267 677 848 348 672 + 057 988 235 399 359 593 421 310 024 824 900 120 065 606 + 328 015 649 156 772 5) -100)) + +(defun math-half-circle (symb) + (if (eq calc-angle-mode 'rad) + (if symb + '(var pi var-pi) + (math-pi)) + 180) +) + +(defun math-full-circle (symb) + (math-mul 2 (math-half-circle symb)) +) + +(defun math-quarter-circle (symb) + (math-div (math-half-circle symb) 2) +) + + + + +;;;; Miscellaneous math routines. + +;;; True if A is an odd integer. [P R R] [Public] +(defun math-oddp (a) + (if (consp a) + (and (memq (car a) '(bigpos bigneg)) + (= (% (nth 1 a) 2) 1)) + (/= (% a 2) 0)) +) + +;;; True if A is a small or big integer. [P x] [Public] +(defun math-integerp (a) + (or (integerp a) + (memq (car-safe a) '(bigpos bigneg))) +) + +;;; True if A is (numerically) a non-negative integer. [P N] [Public] +(defun math-natnump (a) + (or (natnump a) + (eq (car-safe a) 'bigpos)) +) + +;;; True if A is a rational (or integer). [P x] [Public] +(defun math-ratp (a) + (or (integerp a) + (memq (car-safe a) '(bigpos bigneg frac))) +) + +;;; True if A is a real (or rational). [P x] [Public] +(defun math-realp (a) + (or (integerp a) + (memq (car-safe a) '(bigpos bigneg frac float))) +) + +;;; True if A is a real or HMS form. [P x] [Public] +(defun math-anglep (a) + (or (integerp a) + (memq (car-safe a) '(bigpos bigneg frac float hms))) +) + +;;; True if A is a number of any kind. [P x] [Public] +(defun math-numberp (a) + (or (integerp a) + (memq (car-safe a) '(bigpos bigneg frac float cplx polar))) +) + +;;; True if A is a complex number or angle. [P x] [Public] +(defun math-scalarp (a) + (or (integerp a) + (memq (car-safe a) '(bigpos bigneg frac float cplx polar hms))) +) + +;;; True if A is a vector. [P x] [Public] +(defun math-vectorp (a) + (eq (car-safe a) 'vec) +) + +;;; True if A is any vector or scalar data object. [P x] +(defun math-objvecp (a) ; [Public] + (or (integerp a) + (memq (car-safe a) '(bigpos bigneg frac float cplx polar + hms date sdev intv mod vec incomplete))) +) + +;;; True if A is an object not composed of sub-formulas . [P x] [Public] +(defun math-primp (a) + (or (integerp a) + (memq (car-safe a) '(bigpos bigneg frac float cplx polar + hms date mod var))) +) + +;;; True if A is numerically (but not literally) an integer. [P x] [Public] +(defun math-messy-integerp (a) + (cond + ((eq (car-safe a) 'float) (>= (nth 2 a) 0)) + ((eq (car-safe a) 'frac) (Math-integerp (math-normalize a)))) +) + +;;; True if A is numerically an integer. [P x] [Public] +(defun math-num-integerp (a) + (or (Math-integerp a) + (Math-messy-integerp a)) +) + +;;; True if A is (numerically) a non-negative integer. [P N] [Public] +(defun math-num-natnump (a) + (or (natnump a) + (eq (car-safe a) 'bigpos) + (and (eq (car-safe a) 'float) + (Math-natnump (nth 1 a)) + (>= (nth 2 a) 0))) +) + +;;; True if A is an integer or will evaluate to an integer. [P x] [Public] +(defun math-provably-integerp (a) + (or (Math-integerp a) + (and (memq (car-safe a) '(calcFunc-trunc + calcFunc-round + calcFunc-rounde + calcFunc-roundu + calcFunc-floor + calcFunc-ceil)) + (= (length a) 2))) +) + +;;; True if A is a real or will evaluate to a real. [P x] [Public] +(defun math-provably-realp (a) + (or (Math-realp a) + (math-provably-integer a) + (memq (car-safe a) '(abs arg))) +) + +;;; True if A is a non-real, complex number. [P x] [Public] +(defun math-complexp (a) + (memq (car-safe a) '(cplx polar)) +) + +;;; True if A is a non-real, rectangular complex number. [P x] [Public] +(defun math-rect-complexp (a) + (eq (car-safe a) 'cplx) +) + +;;; True if A is a non-real, polar complex number. [P x] [Public] +(defun math-polar-complexp (a) + (eq (car-safe a) 'polar) +) + +;;; True if A is a matrix. [P x] [Public] +(defun math-matrixp (a) + (and (Math-vectorp a) + (Math-vectorp (nth 1 a)) + (cdr (nth 1 a)) + (let ((len (length (nth 1 a)))) + (setq a (cdr a)) + (while (and (setq a (cdr a)) + (Math-vectorp (car a)) + (= (length (car a)) len))) + (null a))) +) + +(defun math-matrixp-step (a len) ; [P L] + (or (null a) + (and (Math-vectorp (car a)) + (= (length (car a)) len) + (math-matrixp-step (cdr a) len))) +) + +;;; True if A is a square matrix. [P V] [Public] +(defun math-square-matrixp (a) + (let ((dims (math-mat-dimens a))) + (and (cdr dims) + (= (car dims) (nth 1 dims)))) +) + +;;; True if A is any scalar data object. [P x] +(defun math-objectp (a) ; [Public] + (or (integerp a) + (memq (car-safe a) '(bigpos bigneg frac float cplx + polar hms date sdev intv mod))) +) + +;;; Verify that A is an integer and return A in integer form. [I N; - x] +(defun math-check-integer (a) ; [Public] + (cond ((integerp a) a) ; for speed + ((math-integerp a) a) + ((math-messy-integerp a) + (math-trunc a)) + (t (math-reject-arg a 'integerp))) +) + +;;; Verify that A is a small integer and return A in integer form. [S N; - x] +(defun math-check-fixnum (a &optional allow-inf) ; [Public] + (cond ((integerp a) a) ; for speed + ((Math-num-integerp a) + (let ((a (math-trunc a))) + (if (integerp a) + a + (if (or (Math-lessp (lsh -1 -1) a) + (Math-lessp a (- (lsh -1 -1)))) + (math-reject-arg a 'fixnump) + (math-fixnum a))))) + ((and allow-inf (equal a '(var inf var-inf))) + (lsh -1 -1)) + ((and allow-inf (equal a '(neg (var inf var-inf)))) + (- (lsh -1 -1))) + (t (math-reject-arg a 'fixnump))) +) + +;;; Verify that A is an integer >= 0 and return A in integer form. [I N; - x] +(defun math-check-natnum (a) ; [Public] + (cond ((natnump a) a) + ((and (not (math-negp a)) + (Math-num-integerp a)) + (math-trunc a)) + (t (math-reject-arg a 'natnump))) +) + +;;; Verify that A is in floating-point form, or force it to be a float. [F N] +(defun math-check-float (a) ; [Public] + (cond ((eq (car-safe a) 'float) a) + ((Math-vectorp a) (math-map-vec 'math-check-float a)) + ((Math-objectp a) (math-float a)) + (t a)) +) + +;;; Verify that A is a constant. +(defun math-check-const (a &optional exp-ok) + (if (or (math-constp a) + (and exp-ok math-expand-formulas)) + a + (math-reject-arg a 'constp)) +) + + +;;; Coerce integer A to be a small integer. [S I] +(defun math-fixnum (a) + (if (consp a) + (if (cdr a) + (if (eq (car a) 'bigneg) + (- (math-fixnum-big (cdr a))) + (math-fixnum-big (cdr a))) + 0) + a) +) + +(defun math-fixnum-big (a) + (if (cdr a) + (+ (car a) (* (math-fixnum-big (cdr a)) 1000)) + (car a)) +) + + +(defun math-normalize-fancy (a) + (cond ((eq (car a) 'frac) + (math-make-frac (math-normalize (nth 1 a)) + (math-normalize (nth 2 a)))) + ((eq (car a) 'cplx) + (let ((real (math-normalize (nth 1 a))) + (imag (math-normalize (nth 2 a)))) + (if (and (math-zerop imag) + (not math-simplify-only)) ; oh, what a kludge! + real + (list 'cplx real imag)))) + ((eq (car a) 'polar) + (math-normalize-polar a)) + ((eq (car a) 'hms) + (math-normalize-hms a)) + ((eq (car a) 'date) + (list 'date (math-normalize (nth 1 a)))) + ((eq (car a) 'mod) + (math-normalize-mod a)) + ((eq (car a) 'sdev) + (let ((x (math-normalize (nth 1 a))) + (s (math-normalize (nth 2 a)))) + (if (or (and (Math-objectp x) (not (Math-scalarp x))) + (and (Math-objectp s) (not (Math-scalarp s)))) + (list 'calcFunc-sdev x s) + (math-make-sdev x s)))) + ((eq (car a) 'intv) + (let ((mask (math-normalize (nth 1 a))) + (lo (math-normalize (nth 2 a))) + (hi (math-normalize (nth 3 a)))) + (if (if (eq (car-safe lo) 'date) + (not (eq (car-safe hi) 'date)) + (or (and (Math-objectp lo) (not (Math-anglep lo))) + (and (Math-objectp hi) (not (Math-anglep hi))))) + (list 'calcFunc-intv mask lo hi) + (math-make-intv mask lo hi)))) + ((eq (car a) 'vec) + (cons 'vec (mapcar 'math-normalize (cdr a)))) + ((eq (car a) 'quote) + (math-normalize (nth 1 a))) + ((eq (car a) 'special-const) + (calc-with-default-simplification + (math-normalize (nth 1 a)))) + ((eq (car a) 'var) + (cons 'var (cdr a))) ; need to re-cons for selection routines + ((eq (car a) 'calcFunc-if) + (math-normalize-logical-op a)) + ((memq (car a) '(calcFunc-lambda calcFunc-quote calcFunc-condition)) + (let ((calc-simplify-mode 'none)) + (cons (car a) (mapcar 'math-normalize (cdr a))))) + ((eq (car a) 'calcFunc-evalto) + (setq a (or (nth 1 a) 0)) + (or calc-refreshing-evaltos + (setq a (let ((calc-simplify-mode 'none)) (math-normalize a)))) + (let ((b (if (and (eq (car-safe a) 'calcFunc-assign) + (= (length a) 3)) + (nth 2 a) + a))) + (list 'calcFunc-evalto + a + (if (eq calc-simplify-mode 'none) + (math-normalize b) + (calc-with-default-simplification + (math-evaluate-expr b)))))) + ((or (integerp (car a)) (consp (car a))) + (if (null (cdr a)) + (math-normalize (car a)) + (error "Can't use multi-valued function in an expression")))) +) + +(defun math-normalize-nonstandard () ; uses "a" + (if (consp calc-simplify-mode) + (progn + (setq calc-simplify-mode 'none + math-simplify-only (car-safe (cdr-safe a))) + nil) + (and (symbolp (car a)) + (or (eq calc-simplify-mode 'none) + (and (eq calc-simplify-mode 'num) + (let ((aptr (setq a (cons + (car a) + (mapcar 'math-normalize (cdr a)))))) + (while (and aptr (math-constp (car aptr))) + (setq aptr (cdr aptr))) + aptr))) + (cons (car a) (mapcar 'math-normalize (cdr a))))) +) + + + +(setq math-expand-formulas nil) + + +;;; Normalize a bignum digit list by trimming high-end zeros. [L l] +(defun math-norm-bignum (a) + (let ((digs a) (last nil)) + (while digs + (or (eq (car digs) 0) (setq last digs)) + (setq digs (cdr digs))) + (and last + (progn + (setcdr last nil) + a))) +) + +(defun math-bignum-test (a) ; [B N; B s; b b] + (if (consp a) + a + (math-bignum a)) +) + + +;;; Return 0 for zero, -1 for negative, 1 for positive. [S n] [Public] +(defun calcFunc-sign (a &optional x) + (let ((signs (math-possible-signs a))) + (cond ((eq signs 4) (or x 1)) + ((eq signs 2) 0) + ((eq signs 1) (if x (math-neg x) -1)) + ((math-looks-negp a) (math-neg (calcFunc-sign (math-neg a)))) + (t (calc-record-why 'realp a) + (if x + (list 'calcFunc-sign a x) + (list 'calcFunc-sign a))))) +) + +;;; Return 0 if A is numerically equal to B, <0 if less, >0 if more. +;;; Arguments must be normalized! [S N N] +(defun math-compare (a b) + (cond ((equal a b) + (if (and (consp a) + (memq (car a) '(var neg * /)) + (math-infinitep a)) + 2 + 0)) + ((and (integerp a) (Math-integerp b)) + (if (consp b) + (if (eq (car b) 'bigpos) -1 1) + (if (< a b) -1 1))) + ((and (eq (car-safe a) 'bigpos) (Math-integerp b)) + (if (eq (car-safe b) 'bigpos) + (math-compare-bignum (cdr a) (cdr b)) + 1)) + ((and (eq (car-safe a) 'bigneg) (Math-integerp b)) + (if (eq (car-safe b) 'bigneg) + (math-compare-bignum (cdr b) (cdr a)) + -1)) + ((eq (car-safe a) 'frac) + (if (eq (car-safe b) 'frac) + (math-compare (math-mul (nth 1 a) (nth 2 b)) + (math-mul (nth 1 b) (nth 2 a))) + (math-compare (nth 1 a) (math-mul b (nth 2 a))))) + ((eq (car-safe b) 'frac) + (math-compare (math-mul a (nth 2 b)) (nth 1 b))) + ((and (eq (car-safe a) 'float) (eq (car-safe b) 'float)) + (if (math-lessp-float a b) -1 1)) + ((and (eq (car-safe a) 'date) (eq (car-safe b) 'date)) + (math-compare (nth 1 a) (nth 1 b))) + ((and (or (Math-anglep a) + (and (eq (car a) 'cplx) (eq (nth 2 a) 0))) + (or (Math-anglep b) + (and (eq (car b) 'cplx) (eq (nth 2 b) 0)))) + (calcFunc-sign (math-add a (math-neg b)))) + ((and (eq (car-safe a) 'intv) + (or (Math-anglep b) (eq (car-safe b) 'date))) + (let ((res (math-compare (nth 2 a) b))) + (cond ((eq res 1) 1) + ((and (eq res 0) (memq (nth 1 a) '(0 1))) 1) + ((eq (setq res (math-compare (nth 3 a) b)) -1) -1) + ((and (eq res 0) (memq (nth 1 a) '(0 2))) -1) + (t 2)))) + ((and (eq (car-safe b) 'intv) + (or (Math-anglep a) (eq (car-safe a) 'date))) + (let ((res (math-compare a (nth 2 b)))) + (cond ((eq res -1) -1) + ((and (eq res 0) (memq (nth 1 b) '(0 1))) -1) + ((eq (setq res (math-compare a (nth 3 b))) 1) 1) + ((and (eq res 0) (memq (nth 1 b) '(0 2))) 1) + (t 2)))) + ((and (eq (car-safe a) 'intv) (eq (car-safe b) 'intv)) + (let ((res (math-compare (nth 3 a) (nth 2 b)))) + (cond ((eq res -1) -1) + ((and (eq res 0) (or (memq (nth 1 a) '(0 2)) + (memq (nth 1 b) '(0 1)))) -1) + ((eq (setq res (math-compare (nth 2 a) (nth 3 b))) 1) 1) + ((and (eq res 0) (or (memq (nth 1 a) '(0 1)) + (memq (nth 1 b) '(0 2)))) 1) + (t 2)))) + ((math-infinitep a) + (if (or (equal a '(var uinf var-uinf)) + (equal a '(var nan var-nan))) + 2 + (let ((dira (math-infinite-dir a))) + (if (math-infinitep b) + (if (or (equal b '(var uinf var-uinf)) + (equal b '(var nan var-nan))) + 2 + (let ((dirb (math-infinite-dir b))) + (cond ((and (eq dira 1) (eq dirb -1)) 1) + ((and (eq dira -1) (eq dirb 1)) -1) + (t 2)))) + (cond ((eq dira 1) 1) + ((eq dira -1) -1) + (t 2)))))) + ((math-infinitep b) + (if (or (equal b '(var uinf var-uinf)) + (equal b '(var nan var-nan))) + 2 + (let ((dirb (math-infinite-dir b))) + (cond ((eq dirb 1) -1) + ((eq dirb -1) 1) + (t 2))))) + ((and (eq (car-safe a) 'calcFunc-exp) + (eq (car-safe b) '^) + (equal (nth 1 b) '(var e var-e))) + (math-compare (nth 1 a) (nth 2 b))) + ((and (eq (car-safe b) 'calcFunc-exp) + (eq (car-safe a) '^) + (equal (nth 1 a) '(var e var-e))) + (math-compare (nth 2 a) (nth 1 b))) + ((or (and (eq (car-safe a) 'calcFunc-sqrt) + (eq (car-safe b) '^) + (or (equal (nth 2 b) '(frac 1 2)) + (equal (nth 2 b) '(float 5 -1)))) + (and (eq (car-safe b) 'calcFunc-sqrt) + (eq (car-safe a) '^) + (or (equal (nth 2 a) '(frac 1 2)) + (equal (nth 2 a) '(float 5 -1))))) + (math-compare (nth 1 a) (nth 1 b))) + ((eq (car-safe a) 'var) + 2) + (t + (if (and (consp a) (consp b) + (eq (car a) (car b)) + (math-compare-lists (cdr a) (cdr b))) + 0 + 2))) +) + +;;; Compare two bignum digit lists, return -1 for A<B, 0 for A=B, 1 for A>B. +(defun math-compare-bignum (a b) ; [S l l] + (let ((res 0)) + (while (and a b) + (if (< (car a) (car b)) + (setq res -1) + (if (> (car a) (car b)) + (setq res 1))) + (setq a (cdr a) + b (cdr b))) + (if a + (progn + (while (eq (car a) 0) (setq a (cdr a))) + (if a 1 res)) + (while (eq (car b) 0) (setq b (cdr b))) + (if b -1 res))) +) + +(defun math-compare-lists (a b) + (cond ((null a) (null b)) + ((null b) nil) + (t (and (Math-equal (car a) (car b)) + (math-compare-lists (cdr a) (cdr b))))) +) + +(defun math-lessp-float (a b) ; [P F F] + (let ((ediff (- (nth 2 a) (nth 2 b)))) + (if (>= ediff 0) + (if (>= ediff (+ calc-internal-prec calc-internal-prec)) + (if (eq (nth 1 a) 0) + (Math-integer-posp (nth 1 b)) + (Math-integer-negp (nth 1 a))) + (Math-lessp (math-scale-int (nth 1 a) ediff) + (nth 1 b))) + (if (>= (setq ediff (- ediff)) + (+ calc-internal-prec calc-internal-prec)) + (if (eq (nth 1 b) 0) + (Math-integer-negp (nth 1 a)) + (Math-integer-posp (nth 1 b))) + (Math-lessp (nth 1 a) + (math-scale-int (nth 1 b) ediff))))) +) + +;;; True if A is numerically equal to B. [P N N] [Public] +(defun math-equal (a b) + (= (math-compare a b) 0) +) + +;;; True if A is numerically less than B. [P R R] [Public] +(defun math-lessp (a b) + (= (math-compare a b) -1) +) + +;;; True if A is numerically equal to the integer B. [P N S] [Public] +;;; B must not be a multiple of 10. +(defun math-equal-int (a b) + (or (eq a b) + (and (eq (car-safe a) 'float) + (eq (nth 1 a) b) + (= (nth 2 a) 0))) +) + + + + +;;; Return the dimensions of a matrix as a list. [l x] [Public] +(defun math-mat-dimens (m) + (if (math-vectorp m) + (if (math-matrixp m) + (cons (1- (length m)) + (math-mat-dimens (nth 1 m))) + (list (1- (length m)))) + nil) +) + + + +(defun calc-binary-op-fancy (name func arg ident unary) + (let ((n (prefix-numeric-value arg))) + (cond ((> n 1) + (calc-enter-result n + name + (list 'calcFunc-reduce + (math-calcFunc-to-var func) + (cons 'vec (calc-top-list-n n))))) + ((= n 1) + (if unary + (calc-enter-result 1 name (list unary (calc-top-n 1))))) + ((= n 0) + (if ident + (calc-enter-result 0 name ident) + (error "Argument must be nonzero"))) + (t + (let ((rhs (calc-top-n 1))) + (calc-enter-result (- 1 n) + name + (mapcar (function + (lambda (x) + (list func x rhs))) + (calc-top-list-n (- n) 2))))))) +) + +(defun calc-unary-op-fancy (name func arg) + (let ((n (prefix-numeric-value arg))) + (if (= n 0) (setq n (calc-stack-size))) + (cond ((> n 0) + (calc-enter-result n + name + (mapcar (function + (lambda (x) + (list func x))) + (calc-top-list-n n)))) + ((< n 0) + (calc-enter-result 1 + name + (list func (calc-top-n (- n))) + (- n))))) +) + + + +(defvar var-Holidays '(vec (var sat var-sat) (var sun var-sun))) + + + +(defvar var-Decls (list 'vec)) + + + +(setq math-simplify-only nil) + +(defun math-inexact-result () + (and calc-symbolic-mode + (signal 'inexact-result nil)) +) + +(defun math-overflow (&optional exp) + (if (and exp (math-negp exp)) + (math-underflow) + (signal 'math-overflow nil)) +) + +(defun math-underflow () + (signal 'math-underflow nil) +) + + + +;;; Compute the greatest common divisor of A and B. [I I I] [Public] +(defun math-gcd (a b) + (cond ((not (or (consp a) (consp b))) + (if (< a 0) (setq a (- a))) + (if (< b 0) (setq b (- b))) + (let (c) + (if (< a b) + (setq c b b a a c)) + (while (> b 0) + (setq c b + b (% a b) + a c)) + a)) + ((eq a 0) b) + ((eq b 0) a) + (t + (if (Math-integer-negp a) (setq a (math-neg a))) + (if (Math-integer-negp b) (setq b (math-neg b))) + (let (c) + (if (Math-natnum-lessp a b) + (setq c b b a a c)) + (while (and (consp a) (not (eq b 0))) + (setq c b + b (math-imod a b) + a c)) + (while (> b 0) + (setq c b + b (% a b) + a c)) + a))) +) + + +;;;; Algebra. + +;;; Evaluate variables in an expression. +(defun math-evaluate-expr (x) ; [Public] + (if calc-embedded-info + (calc-embedded-evaluate-expr x) + (calc-normalize (math-evaluate-expr-rec x))) +) +(fset 'calcFunc-evalv (symbol-function 'math-evaluate-expr)) + +(defun calcFunc-evalvn (x &optional prec) + (if prec + (progn + (or (math-num-integerp prec) + (if (and (math-vectorp prec) + (= (length prec) 2) + (math-num-integerp (nth 1 prec))) + (setq prec (math-add (nth 1 prec) calc-internal-prec)) + (math-reject-arg prec 'integerp))) + (setq prec (math-trunc prec)) + (if (< prec 3) (setq prec 3)) + (if (> prec calc-internal-prec) + (math-normalize + (let ((calc-internal-prec prec)) + (calcFunc-evalvn x))) + (let ((calc-internal-prec prec)) + (calcFunc-evalvn x)))) + (let ((calc-symbolic-mode nil)) + (math-evaluate-expr x))) +) + +(defun math-evaluate-expr-rec (x) + (if (consp x) + (if (memq (car x) '(calcFunc-quote calcFunc-condition + calcFunc-evalto calcFunc-assign)) + (if (and (eq (car x) 'calcFunc-assign) + (= (length x) 3)) + (list (car x) (nth 1 x) (math-evaluate-expr-rec (nth 2 x))) + x) + (if (eq (car x) 'var) + (if (and (calc-var-value (nth 2 x)) + (not (eq (car-safe (symbol-value (nth 2 x))) + 'incomplete))) + (let ((val (symbol-value (nth 2 x)))) + (if (eq (car-safe val) 'special-const) + (if calc-symbolic-mode + x + val) + val)) + x) + (if (Math-primp x) + x + (cons (car x) (mapcar 'math-evaluate-expr-rec (cdr x)))))) + x) +) + + + +(setq math-simplifying nil) +(setq math-living-dangerously nil) ; true if unsafe simplifications are okay. +(setq math-integrating nil) + + + + +(defmacro math-defsimplify (funcs &rest code) + (append '(progn (math-need-std-simps)) + (mapcar (function + (lambda (func) + (list 'put (list 'quote func) ''math-simplify + (list 'nconc + (list 'get (list 'quote func) ''math-simplify) + (list 'list + (list 'function + (append '(lambda (expr)) + code))))))) + (if (symbolp funcs) (list funcs) funcs))) +) +(put 'math-defsimplify 'lisp-indent-hook 1) + + +(defun math-any-floats (expr) + (if (Math-primp expr) + (math-floatp expr) + (while (and (setq expr (cdr expr)) (not (math-any-floats (car expr))))) + expr) +) + +(defvar var-FactorRules 'calc-FactorRules) + + + +(defun math-map-tree (mmt-func mmt-expr &optional mmt-many) + (or mmt-many (setq mmt-many 1000000)) + (math-map-tree-rec mmt-expr) +) + +(defun math-map-tree-rec (mmt-expr) + (or (= mmt-many 0) + (let ((mmt-done nil) + mmt-nextval) + (while (not mmt-done) + (while (and (/= mmt-many 0) + (setq mmt-nextval (funcall mmt-func mmt-expr)) + (not (equal mmt-expr mmt-nextval))) + (setq mmt-expr mmt-nextval + mmt-many (if (> mmt-many 0) (1- mmt-many) (1+ mmt-many)))) + (if (or (Math-primp mmt-expr) + (<= mmt-many 0)) + (setq mmt-done t) + (setq mmt-nextval (cons (car mmt-expr) + (mapcar 'math-map-tree-rec + (cdr mmt-expr)))) + (if (equal mmt-nextval mmt-expr) + (setq mmt-done t) + (setq mmt-expr mmt-nextval)))))) + mmt-expr +) + + + + +(setq math-rewrite-selections nil) + +(defun math-is-true (expr) + (if (Math-numberp expr) + (not (Math-zerop expr)) + (math-known-nonzerop expr)) +) + +(defun math-const-var (expr) + (and (consp expr) + (eq (car expr) 'var) + (or (and (symbolp (nth 2 expr)) + (boundp (nth 2 expr)) + (eq (car-safe (symbol-value (nth 2 expr))) 'special-const)) + (memq (nth 2 expr) '(var-inf var-uinf var-nan)))) +) + + + + +(defmacro math-defintegral (funcs &rest code) + (setq math-integral-cache nil) + (append '(progn) + (mapcar (function + (lambda (func) + (list 'put (list 'quote func) ''math-integral + (list 'nconc + (list 'get (list 'quote func) ''math-integral) + (list 'list + (list 'function + (append '(lambda (u)) + code))))))) + (if (symbolp funcs) (list funcs) funcs))) +) +(put 'math-defintegral 'lisp-indent-hook 1) + +(defmacro math-defintegral-2 (funcs &rest code) + (setq math-integral-cache nil) + (append '(progn) + (mapcar (function + (lambda (func) + (list 'put (list 'quote func) ''math-integral-2 + (list 'nconc + (list 'get (list 'quote func) + ''math-integral-2) + (list 'list + (list 'function + (append '(lambda (u v)) + code))))))) + (if (symbolp funcs) (list funcs) funcs))) +) +(put 'math-defintegral-2 'lisp-indent-hook 1) + + +(defvar var-IntegAfterRules 'calc-IntegAfterRules) + + +(defvar var-FitRules 'calc-FitRules) + + +(setq math-poly-base-variable nil) +(setq math-poly-neg-powers nil) +(setq math-poly-mult-powers 1) +(setq math-poly-frac-powers nil) +(setq math-poly-exp-base nil) + + + + +(defun math-build-var-name (name) + (if (stringp name) + (setq name (intern name))) + (if (string-match "\\`var-." (symbol-name name)) + (list 'var (intern (substring (symbol-name name) 4)) name) + (list 'var name (intern (concat "var-" (symbol-name name))))) +) + +(setq math-simplifying-units nil) +(setq math-combining-units t) + + +(put 'math-while 'lisp-indent-hook 1) +(put 'math-for 'lisp-indent-hook 1) +(put 'math-foreach 'lisp-indent-hook 1) + + +;;; Nontrivial number parsing. + +(defun math-read-number-fancy (s) + (cond + + ;; Integer+fractions + ((string-match "^\\([0-9]*\\)[:/]\\([0-9]*\\)[:/]\\([0-9]*\\)$" s) + (let ((int (math-match-substring s 1)) + (num (math-match-substring s 2)) + (den (math-match-substring s 3))) + (let ((int (if (> (length int) 0) (math-read-number int) 0)) + (num (if (> (length num) 0) (math-read-number num) 1)) + (den (if (> (length num) 0) (math-read-number den) 1))) + (and int num den + (math-integerp int) (math-integerp num) (math-integerp den) + (not (math-zerop den)) + (list 'frac (math-add num (math-mul int den)) den))))) + + ;; Fractions + ((string-match "^\\([0-9]*\\)[:/]\\([0-9]*\\)$" s) + (let ((num (math-match-substring s 1)) + (den (math-match-substring s 2))) + (let ((num (if (> (length num) 0) (math-read-number num) 1)) + (den (if (> (length num) 0) (math-read-number den) 1))) + (and num den (math-integerp num) (math-integerp den) + (not (math-zerop den)) + (list 'frac num den))))) + + ;; Modulo forms + ((string-match "^\\(.*\\) *mod *\\(.*\\)$" s) + (let* ((n (math-match-substring s 1)) + (m (math-match-substring s 2)) + (n (math-read-number n)) + (m (math-read-number m))) + (and n m (math-anglep n) (math-anglep m) + (list 'mod n m)))) + + ;; Error forms + ((string-match "^\\(.*\\) *\\+/- *\\(.*\\)$" s) + (let* ((x (math-match-substring s 1)) + (sigma (math-match-substring s 2)) + (x (math-read-number x)) + (sigma (math-read-number sigma))) + (and x sigma (math-scalarp x) (math-anglep sigma) + (list 'sdev x sigma)))) + + ;; Hours (or degrees) + ((or (string-match "^\\([^#^]+\\)[@oOhH]\\(.*\\)$" s) + (string-match "^\\([^#^]+\\)[dD][eE]?[gG]?\\(.*\\)$" s)) + (let* ((hours (math-match-substring s 1)) + (minsec (math-match-substring s 2)) + (hours (math-read-number hours)) + (minsec (if (> (length minsec) 0) (math-read-number minsec) 0))) + (and hours minsec + (math-num-integerp hours) + (not (math-negp hours)) (not (math-negp minsec)) + (cond ((math-num-integerp minsec) + (and (Math-lessp minsec 60) + (list 'hms hours minsec 0))) + ((and (eq (car-safe minsec) 'hms) + (math-zerop (nth 1 minsec))) + (math-add (list 'hms hours 0 0) minsec)) + (t nil))))) + + ;; Minutes + ((string-match "^\\([^'#^]+\\)[mM']\\(.*\\)$" s) + (let* ((minutes (math-match-substring s 1)) + (seconds (math-match-substring s 2)) + (minutes (math-read-number minutes)) + (seconds (if (> (length seconds) 0) (math-read-number seconds) 0))) + (and minutes seconds + (math-num-integerp minutes) + (not (math-negp minutes)) (not (math-negp seconds)) + (cond ((math-realp seconds) + (and (Math-lessp minutes 60) + (list 'hms 0 minutes seconds))) + ((and (eq (car-safe seconds) 'hms) + (math-zerop (nth 1 seconds)) + (math-zerop (nth 2 seconds))) + (math-add (list 'hms 0 minutes 0) seconds)) + (t nil))))) + + ;; Seconds + ((string-match "^\\([^\"#^]+\\)[sS\"]$" s) + (let ((seconds (math-read-number (math-match-substring s 1)))) + (and seconds (math-realp seconds) + (not (math-negp seconds)) + (Math-lessp seconds 60) + (list 'hms 0 0 seconds)))) + + ;; Integer+fraction with explicit radix + ((string-match "^\\([0-9]+\\)\\(#\\|\\^\\^\\)\\([0-9a-zA-Z]*\\)[:/]\\([0-9a-zA-Z]*\\)[:/]\\([0-9a-zA-Z]\\)$" s) + (let ((radix (string-to-int (math-match-substring s 1))) + (int (math-match-substring s 3)) + (num (math-match-substring s 4)) + (den (math-match-substring s 5))) + (let ((int (if (> (length int) 0) (math-read-radix int radix) 0)) + (num (if (> (length num) 0) (math-read-radix num radix) 1)) + (den (if (> (length den) 0) (math-read-radix den radix) 1))) + (and int num den (not (math-zerop den)) + (list 'frac + (math-add num (math-mul int den)) + den))))) + + ;; Fraction with explicit radix + ((string-match "^\\([0-9]+\\)\\(#\\|\\^\\^\\)\\([0-9a-zA-Z]*\\)[:/]\\([0-9a-zA-Z]*\\)$" s) + (let ((radix (string-to-int (math-match-substring s 1))) + (num (math-match-substring s 3)) + (den (math-match-substring s 4))) + (let ((num (if (> (length num) 0) (math-read-radix num radix) 1)) + (den (if (> (length den) 0) (math-read-radix den radix) 1))) + (and num den (not (math-zerop den)) (list 'frac num den))))) + + ;; Float with explicit radix and exponent + ((or (string-match "^0*\\(\\([2-9]\\|1[0-4]\\)\\(#\\|\\^\\^\\)[0-9a-dA-D.]+\\)[eE]\\([-+]?[0-9]+\\)$" s) + (string-match "^\\(\\([0-9]+\\)\\(#\\|\\^\\^\\)[0-9a-zA-Z.]+\\) *\\* *\\2\\.? *\\^ *\\([-+]?[0-9]+\\)$" s)) + (let ((radix (string-to-int (math-match-substring s 2))) + (mant (math-match-substring s 1)) + (exp (math-match-substring s 4))) + (let ((mant (math-read-number mant)) + (exp (math-read-number exp))) + (and mant exp + (math-mul mant (math-pow (math-float radix) exp)))))) + + ;; Float with explicit radix, no exponent + ((string-match "^\\([0-9]+\\)\\(#\\|\\^\\^\\)\\([0-9a-zA-Z]*\\)\\.\\([0-9a-zA-Z]*\\)$" s) + (let ((radix (string-to-int (math-match-substring s 1))) + (int (math-match-substring s 3)) + (fracs (math-match-substring s 4))) + (let ((int (if (> (length int) 0) (math-read-radix int radix) 0)) + (frac (if (> (length fracs) 0) (math-read-radix fracs radix) 0)) + (calc-prefer-frac nil)) + (and int frac + (math-add int (math-div frac (math-pow radix (length fracs)))))))) + + ;; Integer with explicit radix + ((string-match "^\\([0-9]+\\)\\(#\\|\\^\\^\\)\\([0-9a-zA-Z]+\\)$" s) + (math-read-radix (math-match-substring s 3) + (string-to-int (math-match-substring s 1)))) + + ;; C language hexadecimal notation + ((and (eq calc-language 'c) + (string-match "^0[xX]\\([0-9a-fA-F]+\\)$" s)) + (let ((digs (math-match-substring s 1))) + (math-read-radix digs 16))) + + ;; Pascal language hexadecimal notation + ((and (eq calc-language 'pascal) + (string-match "^\\$\\([0-9a-fA-F]+\\)$" s)) + (let ((digs (math-match-substring s 1))) + (math-read-radix digs 16))) + + ;; Fraction using "/" instead of ":" + ((string-match "^\\([0-9]+\\)/\\([0-9/]+\\)$" s) + (math-read-number (concat (math-match-substring s 1) ":" + (math-match-substring s 2)))) + + ;; Syntax error! + (t nil)) +) + +(defun math-read-radix (s r) ; [I X D] + (setq s (upcase s)) + (let ((i 0) + (res 0) + dig) + (while (and (< i (length s)) + (setq dig (math-read-radix-digit (elt s i))) + (< dig r)) + (setq res (math-add (math-mul res r) dig) + i (1+ i))) + (and (= i (length s)) + res)) +) + + + +;;; Expression parsing. + +(defun math-read-expr (exp-str) + (let ((exp-pos 0) + (exp-old-pos 0) + (exp-keep-spaces nil) + exp-token exp-data) + (while (setq exp-token (string-match "\\.\\.\\([^.]\\|.[^.]\\)" exp-str)) + (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots" + (substring exp-str (+ exp-token 2))))) + (math-build-parse-table) + (math-read-token) + (let ((val (catch 'syntax (math-read-expr-level 0)))) + (if (stringp val) + (list 'error exp-old-pos val) + (if (equal exp-token 'end) + val + (list 'error exp-old-pos "Syntax error"))))) +) + +(defun math-read-plain-expr (exp-str &optional error-check) + (let* ((calc-language nil) + (math-expr-opers math-standard-opers) + (val (math-read-expr exp-str))) + (and error-check + (eq (car-safe val) 'error) + (error "%s: %s" (nth 2 val) exp-str)) + val) +) + + +(defun math-read-string () + (let ((str (read-from-string (concat exp-data "\"")))) + (or (and (= (cdr str) (1+ (length exp-data))) + (stringp (car str))) + (throw 'syntax "Error in string constant")) + (math-read-token) + (append '(vec) (car str) nil)) +) + + + +;;; They said it couldn't be done... + +(defun math-read-big-expr (str) + (and (> (length calc-left-label) 0) + (string-match (concat "^" (regexp-quote calc-left-label)) str) + (setq str (concat (substring str 0 (match-beginning 0)) + (substring str (match-end 0))))) + (and (> (length calc-right-label) 0) + (string-match (concat (regexp-quote calc-right-label) " *$") str) + (setq str (concat (substring str 0 (match-beginning 0)) + (substring str (match-end 0))))) + (if (string-match "\\\\[^ \n|]" str) + (if (eq calc-language 'tex) + (math-read-expr str) + (let ((calc-language 'tex) + (calc-language-option nil) + (math-expr-opers (get 'tex 'math-oper-table)) + (math-expr-function-mapping (get 'tex 'math-function-table)) + (math-expr-variable-mapping (get 'tex 'math-variable-table))) + (math-read-expr str))) + (let ((lines nil) + (pos 0) + (width 0) + (err-msg nil) + the-baseline the-h2 + new-pos p) + (while (setq new-pos (string-match "\n" str pos)) + (setq lines (cons (substring str pos new-pos) lines) + pos (1+ new-pos))) + (setq lines (nreverse (cons (substring str pos) lines)) + p lines) + (while p + (setq width (max width (length (car p))) + p (cdr p))) + (if (math-read-big-bigp lines) + (or (catch 'syntax + (math-read-big-rec 0 0 width (length lines))) + err-msg + '(error 0 "Syntax error")) + (math-read-expr str)))) +) + +(defun math-read-big-bigp (lines) + (and (cdr lines) + (let ((matrix nil) + (v 0) + (height (if (> (length (car lines)) 0) 1 0))) + (while (and (cdr lines) + (let* ((i 0) + j + (l1 (car lines)) + (l2 (nth 1 lines)) + (len (min (length l1) (length l2)))) + (if (> (length l2) 0) + (setq height (1+ height))) + (while (and (< i len) + (or (memq (aref l1 i) '(?\ ?\- ?\_)) + (memq (aref l2 i) '(?\ ?\-)) + (and (memq (aref l1 i) '(?\| ?\,)) + (= (aref l2 i) (aref l1 i))) + (and (eq (aref l1 i) ?\[) + (eq (aref l2 i) ?\[) + (let ((h2 (length l1))) + (setq j (math-read-big-balance + (1+ i) v "["))) + (setq i (1- j))))) + (setq i (1+ i))) + (or (= i len) + (and (eq (aref l1 i) ?\[) + (eq (aref l2 i) ?\[) + (setq matrix t) + nil)))) + (setq lines (cdr lines) + v (1+ v))) + (or (and (> height 1) + (not (cdr lines))) + matrix))) +) + + + +;;; Nontrivial "flat" formatting. + +(defun math-format-flat-expr-fancy (a prec) + (cond + ((eq (car a) 'incomplete) + (format "<incomplete %s>" (nth 1 a))) + ((eq (car a) 'vec) + (if (or calc-full-trail-vectors (not calc-can-abbrev-vectors) + (< (length a) 7)) + (concat "[" (math-format-flat-vector (cdr a) ", " + (if (cdr (cdr a)) 0 1000)) "]") + (concat "[" + (math-format-flat-expr (nth 1 a) 0) ", " + (math-format-flat-expr (nth 2 a) 0) ", " + (math-format-flat-expr (nth 3 a) 0) ", ..., " + (math-format-flat-expr (nth (1- (length a)) a) 0) "]"))) + ((eq (car a) 'intv) + (concat (if (memq (nth 1 a) '(0 1)) "(" "[") + (math-format-flat-expr (nth 2 a) 1000) + " .. " + (math-format-flat-expr (nth 3 a) 1000) + (if (memq (nth 1 a) '(0 2)) ")" "]"))) + ((eq (car a) 'date) + (concat "<" (math-format-date a) ">")) + ((and (eq (car a) 'calcFunc-lambda) (> (length a) 2)) + (let ((p (cdr a)) + (ap calc-arg-values) + (math-format-hash-args (if (= (length a) 3) 1 t))) + (while (and (cdr p) (equal (car p) (car ap))) + (setq p (cdr p) ap (cdr ap))) + (concat "<" + (if (cdr p) + (concat (math-format-flat-vector + (nreverse (cdr (reverse (cdr a)))) ", " 0) + " : ") + "") + (math-format-flat-expr (nth (1- (length a)) a) 0) + ">"))) + ((eq (car a) 'var) + (or (and math-format-hash-args + (let ((p calc-arg-values) (v 1)) + (while (and p (not (equal (car p) a))) + (setq p (and (eq math-format-hash-args t) (cdr p)) + v (1+ v))) + (and p + (if (eq math-format-hash-args 1) + "#" + (format "#%d" v))))) + (symbol-name (nth 1 a)))) + ((and (memq (car a) '(calcFunc-string calcFunc-bstring)) + (= (length a) 2) + (math-vectorp (nth 1 a)) + (math-vector-is-string (nth 1 a))) + (concat (substring (symbol-name (car a)) 9) + "(" (math-vector-to-string (nth 1 a) t) ")")) + (t + (let ((op (math-assq2 (car a) math-standard-opers))) + (cond ((and op (= (length a) 3)) + (if (> prec (min (nth 2 op) (nth 3 op))) + (concat "(" (math-format-flat-expr a 0) ")") + (let ((lhs (math-format-flat-expr (nth 1 a) (nth 2 op))) + (rhs (math-format-flat-expr (nth 2 a) (nth 3 op)))) + (setq op (car op)) + (if (or (equal op "^") (equal op "_")) + (if (= (aref lhs 0) ?-) + (setq lhs (concat "(" lhs ")"))) + (setq op (concat " " op " "))) + (concat lhs op rhs)))) + ((eq (car a) 'neg) + (concat "-" (math-format-flat-expr (nth 1 a) 1000))) + (t + (concat (math-remove-dashes + (if (string-match "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'" + (symbol-name (car a))) + (math-match-substring (symbol-name (car a)) 1) + (symbol-name (car a)))) + "(" + (math-format-flat-vector (cdr a) ", " 0) + ")")))))) +) +(setq math-format-hash-args nil) + +(defun math-format-flat-vector (vec sep prec) + (if vec + (let ((buf (math-format-flat-expr (car vec) prec))) + (while (setq vec (cdr vec)) + (setq buf (concat buf sep (math-format-flat-expr (car vec) prec)))) + buf) + "") +) +(setq calc-can-abbrev-vectors nil) + +(defun math-format-nice-expr (x w) + (cond ((and (eq (car-safe x) 'vec) + (cdr (cdr x)) + (let ((ops '(vec calcFunc-assign calcFunc-condition + calcFunc-schedule calcFunc-iterations + calcFunc-phase))) + (or (memq (car-safe (nth 1 x)) ops) + (memq (car-safe (nth 2 x)) ops) + (memq (car-safe (nth 3 x)) ops) + calc-break-vectors))) + (concat "[ " (math-format-flat-vector (cdr x) ",\n " 0) " ]")) + (t + (let ((str (math-format-flat-expr x 0)) + (pos 0) p) + (or (string-match "\"" str) + (while (<= (setq p (+ pos w)) (length str)) + (while (and (> (setq p (1- p)) pos) + (not (= (aref str p) ? )))) + (if (> p (+ pos 5)) + (setq str (concat (substring str 0 p) + "\n " + (substring str p)) + pos (1+ p)) + (setq pos (+ pos w))))) + str))) +) + +(defun math-assq2 (v a) + (while (and a (not (eq v (nth 1 (car a))))) + (setq a (cdr a))) + (car a) +) + + +(defun math-format-number-fancy (a prec) + (cond + ((eq (car a) 'float) ; non-decimal radix + (if (Math-integer-negp (nth 1 a)) + (concat "-" (math-format-number (math-neg a))) + (let ((str (if (and calc-radix-formatter + (not (memq calc-language '(c pascal)))) + (funcall calc-radix-formatter + calc-number-radix + (math-format-radix-float a prec)) + (format "%d#%s" calc-number-radix + (math-format-radix-float a prec))))) + (if (and prec (> prec 191) (string-match "\\*" str)) + (concat "(" str ")") + str)))) + ((eq (car a) 'frac) + (setq a (math-adjust-fraction a)) + (if (> (length (car calc-frac-format)) 1) + (if (Math-integer-negp (nth 1 a)) + (concat "-" (math-format-number (math-neg a))) + (let ((q (math-idivmod (nth 1 a) (nth 2 a)))) + (concat (let ((calc-frac-format nil)) + (math-format-number (car q))) + (substring (car calc-frac-format) 0 1) + (let ((math-radix-explicit-format nil) + (calc-frac-format nil)) + (math-format-number (cdr q))) + (substring (car calc-frac-format) 1 2) + (let ((math-radix-explicit-format nil) + (calc-frac-format nil)) + (math-format-number (nth 2 a)))))) + (concat (let ((calc-frac-format nil)) + (math-format-number (nth 1 a))) + (car calc-frac-format) + (let ((math-radix-explicit-format nil) + (calc-frac-format nil)) + (math-format-number (nth 2 a)))))) + ((eq (car a) 'cplx) + (if (math-zerop (nth 2 a)) + (math-format-number (nth 1 a)) + (if (null calc-complex-format) + (concat "(" (math-format-number (nth 1 a)) + ", " (math-format-number (nth 2 a)) ")") + (if (math-zerop (nth 1 a)) + (if (math-equal-int (nth 2 a) 1) + (symbol-name calc-complex-format) + (if (math-equal-int (nth 2 a) -1) + (concat "-" (symbol-name calc-complex-format)) + (if prec + (math-compose-expr (list '* (nth 2 a) '(cplx 0 1)) prec) + (concat (math-format-number (nth 2 a)) " " + (symbol-name calc-complex-format))))) + (if prec + (math-compose-expr (list (if (math-negp (nth 2 a)) '- '+) + (nth 1 a) + (list 'cplx 0 (math-abs (nth 2 a)))) + prec) + (concat (math-format-number (nth 1 a)) + (if (math-negp (nth 2 a)) " - " " + ") + (math-format-number + (list 'cplx 0 (math-abs (nth 2 a)))))))))) + ((eq (car a) 'polar) + (concat "(" (math-format-number (nth 1 a)) + "; " (math-format-number (nth 2 a)) ")")) + ((eq (car a) 'hms) + (if (math-negp a) + (concat "-" (math-format-number (math-neg a))) + (let ((calc-number-radix 10) + (calc-leading-zeros nil) + (calc-group-digits nil)) + (format calc-hms-format + (let ((calc-frac-format '(":" nil))) + (math-format-number (nth 1 a))) + (let ((calc-frac-format '(":" nil))) + (math-format-number (nth 2 a))) + (math-format-number (nth 3 a)))))) + ((eq (car a) 'intv) + (concat (if (memq (nth 1 a) '(0 1)) "(" "[") + (math-format-number (nth 2 a)) + " .. " + (math-format-number (nth 3 a)) + (if (memq (nth 1 a) '(0 2)) ")" "]"))) + ((eq (car a) 'sdev) + (concat (math-format-number (nth 1 a)) + " +/- " + (math-format-number (nth 2 a)))) + ((eq (car a) 'vec) + (math-format-flat-expr a 0)) + (t (format "%s" a))) +) + +(defun math-adjust-fraction (a) + (if (nth 1 calc-frac-format) + (progn + (if (Math-integerp a) (setq a (list 'frac a 1))) + (let ((g (math-quotient (nth 1 calc-frac-format) + (math-gcd (nth 2 a) + (nth 1 calc-frac-format))))) + (list 'frac (math-mul (nth 1 a) g) (math-mul (nth 2 a) g)))) + a) +) + +(defun math-format-bignum-fancy (a) ; [X L] + (let ((str (cond ((= calc-number-radix 10) + (math-format-bignum-decimal a)) + ((= calc-number-radix 2) + (math-format-bignum-binary a)) + ((= calc-number-radix 8) + (math-format-bignum-octal a)) + ((= calc-number-radix 16) + (math-format-bignum-hex a)) + (t (math-format-bignum-radix a))))) + (if calc-leading-zeros + (let* ((calc-internal-prec 6) + (digs (math-compute-max-digits (math-abs calc-word-size) + calc-number-radix)) + (len (length str))) + (if (< len digs) + (setq str (concat (make-string (- digs len) ?0) str))))) + (if calc-group-digits + (let ((i (length str)) + (g (if (integerp calc-group-digits) + (math-abs calc-group-digits) + (if (memq calc-number-radix '(2 16)) 4 3)))) + (while (> i g) + (setq i (- i g) + str (concat (substring str 0 i) + calc-group-char + (substring str i)))) + str)) + (if (and (/= calc-number-radix 10) + math-radix-explicit-format) + (if calc-radix-formatter + (funcall calc-radix-formatter calc-number-radix str) + (format "%d#%s" calc-number-radix str)) + str)) +) + + +(defun math-group-float (str) ; [X X] + (let* ((pt (or (string-match "[^0-9a-zA-Z]" str) (length str))) + (g (if (integerp calc-group-digits) (math-abs calc-group-digits) 3)) + (i pt)) + (if (and (integerp calc-group-digits) (< calc-group-digits 0)) + (while (< (setq i (+ (1+ i) g)) (length str)) + (setq str (concat (substring str 0 i) + calc-group-char + (substring str i)) + i (+ i (1- (length calc-group-char)))))) + (setq i pt) + (while (> i g) + (setq i (- i g) + str (concat (substring str 0 i) + calc-group-char + (substring str i)))) + str) +) + + + + + + + + +(setq math-compose-level 0) +(setq math-comp-selected nil) +(setq math-comp-tagged nil) +(setq math-comp-sel-hpos nil) +(setq math-comp-sel-vpos nil) +(setq math-comp-sel-cpos nil) +(setq math-compose-hash-args nil) + + +;;; Users can redefine this in their .emacs files. +(defvar calc-keypad-user-menu nil + "If not NIL, this describes an additional menu for calc-keypad. +It should contain a list of three rows. +Each row should be a list of six keys. +Each key should be a list of a label string, plus a Calc command name spec. +A command spec is a command name symbol, a keyboard macro string, a +list containing a numeric entry string, or nil. +A key may contain additional specs for Inverse, Hyperbolic, and Inv+Hyp.") + + + + + +(run-hooks 'calc-ext-load-hook) + + diff --git a/lisp/calc/calc-fin.el b/lisp/calc/calc-fin.el new file mode 100644 index 0000000000..70d8dcd84f --- /dev/null +++ b/lisp/calc/calc-fin.el @@ -0,0 +1,452 @@ +;; Calculator for GNU Emacs, part II [calc-fin.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-fin () nil) + + +;;; Financial functions. + +(defun calc-fin-pv () + (interactive) + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-enter-result 3 "pvl" (cons 'calcFunc-pvl (calc-top-list-n 3))) + (if (calc-is-inverse) + (calc-enter-result 3 "pvb" (cons 'calcFunc-pvb (calc-top-list-n 3))) + (calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3)))))) +) + +(defun calc-fin-npv (arg) + (interactive "p") + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-vector-op "npvb" 'calcFunc-npvb (1+ arg)) + (calc-vector-op "npv" 'calcFunc-npv (1+ arg)))) +) + +(defun calc-fin-fv () + (interactive) + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3))) + (if (calc-is-inverse) + (calc-enter-result 3 "fvb" (cons 'calcFunc-fvb (calc-top-list-n 3))) + (calc-enter-result 3 "fv" (cons 'calcFunc-fv (calc-top-list-n 3)))))) +) + +(defun calc-fin-pmt () + (interactive) + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3))) + (if (calc-is-inverse) + (calc-enter-result 3 "pmtb" (cons 'calcFunc-pmtb (calc-top-list-n 3))) + (calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3)))))) +) + +(defun calc-fin-nper () + (interactive) + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-enter-result 3 "nprl" (cons 'calcFunc-nperl (calc-top-list-n 3))) + (if (calc-is-inverse) + (calc-enter-result 3 "nprb" (cons 'calcFunc-nperb + (calc-top-list-n 3))) + (calc-enter-result 3 "nper" (cons 'calcFunc-nper + (calc-top-list-n 3)))))) +) + +(defun calc-fin-rate () + (interactive) + (calc-slow-wrapper + (calc-pop-push-record 3 + (if (calc-is-hyperbolic) "ratl" + (if (calc-is-inverse) "ratb" "rate")) + (calc-to-percentage + (calc-normalize + (cons (if (calc-is-hyperbolic) 'calcFunc-ratel + (if (calc-is-hyperbolic) 'calcFunc-rateb + 'calcFunc-rate)) + (calc-top-list-n 3)))))) +) + +(defun calc-fin-irr (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-vector-op "irrb" 'calcFunc-irrb arg) + (calc-vector-op "irr" 'calcFunc-irr arg))) +) + +(defun calc-fin-sln () + (interactive) + (calc-slow-wrapper + (calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3)))) +) + +(defun calc-fin-syd () + (interactive) + (calc-slow-wrapper + (calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4)))) +) + +(defun calc-fin-ddb () + (interactive) + (calc-slow-wrapper + (calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4)))) +) + + +(defun calc-to-percentage (x) + (cond ((Math-objectp x) + (setq x (math-mul x 100)) + (if (Math-num-integerp x) + (setq x (math-trunc x))) + (list 'calcFunc-percent x)) + ((Math-vectorp x) + (cons 'vec (mapcar 'calc-to-percentage (cdr x)))) + (t x)) +) + +(defun calc-convert-percent () + (interactive) + (calc-slow-wrapper + (calc-pop-push-record 1 "c%" (calc-to-percentage (calc-top-n 1)))) +) + +(defun calc-percent-change () + (interactive) + (calc-slow-wrapper + (let ((res (calc-normalize (cons 'calcFunc-relch (calc-top-list 2))))) + (calc-pop-push-record 2 "%ch" (calc-to-percentage res)))) +) + + + + + +;;; Financial functions. + +(defun calcFunc-pv (rate num amount &optional lump) + (math-check-financial rate num) + (math-with-extra-prec 2 + (let ((p (math-pow (math-add 1 rate) num))) + (math-add (math-mul amount + (math-div (math-sub 1 (math-div 1 p)) + rate)) + (math-div (or lump 0) p)))) +) +(put 'calcFunc-pv 'math-expandable t) + +(defun calcFunc-pvl (rate num amount) + (calcFunc-pv rate num 0 amount) +) +(put 'calcFunc-pvl 'math-expandable t) + +(defun calcFunc-pvb (rate num amount &optional lump) + (math-check-financial rate num) + (math-with-extra-prec 2 + (let* ((p (math-pow (math-add 1 rate) num))) + (math-add (math-mul amount + (math-div (math-mul (math-sub 1 (math-div 1 p)) + (math-add 1 rate)) + rate)) + (math-div (or lump 0) p)))) +) +(put 'calcFunc-pvb 'math-expandable t) + +(defun calcFunc-npv (rate &rest flows) + (math-check-financial rate 1) + (math-with-extra-prec 2 + (let* ((flat (math-flatten-many-vecs flows)) + (pp (math-add 1 rate)) + (p pp) + (accum 0)) + (while (setq flat (cdr flat)) + (setq accum (math-add accum (math-div (car flat) p)) + p (math-mul p pp))) + accum)) +) +(put 'calcFunc-npv 'math-expandable t) + +(defun calcFunc-npvb (rate &rest flows) + (math-check-financial rate 1) + (math-with-extra-prec 2 + (let* ((flat (math-flatten-many-vecs flows)) + (pp (math-add 1 rate)) + (p 1) + (accum 0)) + (while (setq flat (cdr flat)) + (setq accum (math-add accum (math-div (car flat) p)) + p (math-mul p pp))) + accum)) +) +(put 'calcFunc-npvb 'math-expandable t) + +(defun calcFunc-fv (rate num amount &optional initial) + (math-check-financial rate num) + (math-with-extra-prec 2 + (let ((p (math-pow (math-add 1 rate) num))) + (math-add (math-mul amount + (math-div (math-sub p 1) + rate)) + (math-mul (or initial 0) p)))) +) +(put 'calcFunc-fv 'math-expandable t) + +(defun calcFunc-fvl (rate num amount) + (calcFunc-fv rate num 0 amount) +) +(put 'calcFunc-fvl 'math-expandable t) + +(defun calcFunc-fvb (rate num amount &optional initial) + (math-check-financial rate num) + (math-with-extra-prec 2 + (let ((p (math-pow (math-add 1 rate) num))) + (math-add (math-mul amount + (math-div (math-mul (math-sub p 1) + (math-add 1 rate)) + rate)) + (math-mul (or initial 0) p)))) +) +(put 'calcFunc-fvb 'math-expandable t) + +(defun calcFunc-pmt (rate num amount &optional lump) + (math-check-financial rate num) + (math-with-extra-prec 2 + (let ((p (math-pow (math-add 1 rate) num))) + (math-div (math-mul (math-sub amount + (math-div (or lump 0) p)) + rate) + (math-sub 1 (math-div 1 p))))) +) +(put 'calcFunc-pmt 'math-expandable t) + +(defun calcFunc-pmtb (rate num amount &optional lump) + (math-check-financial rate num) + (math-with-extra-prec 2 + (let ((p (math-pow (math-add 1 rate) num))) + (math-div (math-mul (math-sub amount (math-div (or lump 0) p)) rate) + (math-mul (math-sub 1 (math-div 1 p)) + (math-add 1 rate))))) +) +(put 'calcFunc-pmtb 'math-expandable t) + +(defun calcFunc-nper (rate pmt amount &optional lump) + (math-compute-nper rate pmt amount lump nil) +) +(put 'calcFunc-nper 'math-expandable t) + +(defun calcFunc-nperb (rate pmt amount &optional lump) + (math-compute-nper rate pmt amount lump 'b) +) +(put 'calcFunc-nperb 'math-expandable t) + +(defun calcFunc-nperl (rate pmt amount) + (math-compute-nper rate pmt amount nil 'l) +) +(put 'calcFunc-nperl 'math-expandable t) + +(defun math-compute-nper (rate pmt amount lump bflag) + (and lump (math-zerop lump) + (setq lump nil)) + (and lump (math-zerop pmt) + (setq amount lump + lump nil + bflag 'l)) + (or (math-objectp rate) (and math-expand-formulas (null lump)) + (math-reject-arg rate 'numberp)) + (and (math-zerop rate) + (math-reject-arg rate 'nonzerop)) + (or (math-objectp pmt) (and math-expand-formulas (null lump)) + (math-reject-arg pmt 'numberp)) + (or (math-objectp amount) (and math-expand-formulas (null lump)) + (math-reject-arg amount 'numberp)) + (if lump + (progn + (or (math-objectp lump) + (math-reject-arg lump 'numberp)) + (let ((root (math-find-root (list 'calcFunc-eq + (list (if bflag + 'calcFunc-pvb + 'calcFunc-pv) + rate + '(var DUMMY var-DUMMY) + pmt + lump) + amount) + '(var DUMMY var-DUMMY) + '(intv 3 0 100) + t))) + (if (math-vectorp root) + (nth 1 root) + root))) + (math-with-extra-prec 2 + (let ((temp (if (eq bflag 'l) + (math-div amount pmt) + (math-sub 1 (math-div (math-mul amount rate) + (if bflag + (math-mul pmt (math-add 1 rate)) + pmt)))))) + (if (or (math-posp temp) math-expand-formulas) + (math-neg (calcFunc-log temp (math-add 1 rate))) + (math-reject-arg pmt "*Payment too small to cover interest rate"))))) +) + +(defun calcFunc-rate (num pmt amount &optional lump) + (math-compute-rate num pmt amount lump 'calcFunc-pv) +) + +(defun calcFunc-rateb (num pmt amount &optional lump) + (math-compute-rate num pmt amount lump 'calcFunc-pvb) +) + +(defun math-compute-rate (num pmt amount lump func) + (or (math-objectp num) + (math-reject-arg num 'numberp)) + (or (math-objectp pmt) + (math-reject-arg pmt 'numberp)) + (or (math-objectp amount) + (math-reject-arg amount 'numberp)) + (or (null lump) + (math-objectp lump) + (math-reject-arg lump 'numberp)) + (let ((root (math-find-root (list 'calcFunc-eq + (list func + '(var DUMMY var-DUMMY) + num + pmt + (or lump 0)) + amount) + '(var DUMMY var-DUMMY) + '(intv 3 (float 1 -4) 1) + t))) + (if (math-vectorp root) + (nth 1 root) + root)) +) + +(defun calcFunc-ratel (num pmt amount) + (or (math-objectp num) math-expand-formulas + (math-reject-arg num 'numberp)) + (or (math-objectp pmt) math-expand-formulas + (math-reject-arg pmt 'numberp)) + (or (math-objectp amount) math-expand-formulas + (math-reject-arg amount 'numberp)) + (math-with-extra-prec 2 + (math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1)) +) + +(defun calcFunc-irr (&rest vecs) + (math-compute-irr vecs 'calcFunc-npv) +) + +(defun calcFunc-irrb (&rest vecs) + (math-compute-irr vecs 'calcFunc-npvb) +) + +(defun math-compute-irr (vecs func) + (let* ((flat (math-flatten-many-vecs vecs)) + (root (math-find-root (list func + '(var DUMMY var-DUMMY) + flat) + '(var DUMMY var-DUMMY) + '(intv 3 (float 1 -4) 1) + t))) + (if (math-vectorp root) + (nth 1 root) + root)) +) + +(defun math-check-financial (rate num) + (or (math-objectp rate) math-expand-formulas + (math-reject-arg rate 'numberp)) + (and (math-zerop rate) + (math-reject-arg rate 'nonzerop)) + (or (math-objectp num) math-expand-formulas + (math-reject-arg num 'numberp)) +) + + +(defun calcFunc-sln (cost salvage life &optional period) + (or (math-realp cost) math-expand-formulas + (math-reject-arg cost 'realp)) + (or (math-realp salvage) math-expand-formulas + (math-reject-arg salvage 'realp)) + (or (math-realp life) math-expand-formulas + (math-reject-arg life 'realp)) + (if (math-zerop life) (math-reject-arg life 'nonzerop)) + (if (and period + (if (math-num-integerp period) + (or (Math-lessp life period) (not (math-posp period))) + (math-reject-arg period 'integerp))) + 0 + (math-div (math-sub cost salvage) life)) +) +(put 'calcFunc-sln 'math-expandable t) + +(defun calcFunc-syd (cost salvage life period) + (or (math-realp cost) math-expand-formulas + (math-reject-arg cost 'realp)) + (or (math-realp salvage) math-expand-formulas + (math-reject-arg salvage 'realp)) + (or (math-realp life) math-expand-formulas + (math-reject-arg life 'realp)) + (if (math-zerop life) (math-reject-arg life 'nonzerop)) + (or (math-realp period) math-expand-formulas + (math-reject-arg period 'realp)) + (if (or (Math-lessp life period) (not (math-posp period))) + 0 + (math-div (math-mul (math-sub cost salvage) + (math-add (math-sub life period) 1)) + (math-div (math-mul life (math-add life 1)) 2))) +) +(put 'calcFunc-syd 'math-expandable t) + +(defun calcFunc-ddb (cost salvage life period) + (if (math-messy-integerp period) (setq period (math-trunc period))) + (or (integerp period) (math-reject-arg period 'fixnump)) + (or (math-realp cost) (math-reject-arg cost 'realp)) + (or (math-realp salvage) (math-reject-arg salvage 'realp)) + (or (math-realp life) (math-reject-arg life 'realp)) + (if (math-zerop life) (math-reject-arg life 'nonzerop)) + (if (or (Math-lessp life period) (<= period 0)) + 0 + (let ((book cost) + (res 0)) + (while (>= (setq period (1- period)) 0) + (setq res (math-div (math-mul book 2) life) + book (math-sub book res)) + (if (Math-lessp book salvage) + (setq res (math-add res (math-sub book salvage)) + book salvage))) + res)) +) + + + diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el new file mode 100644 index 0000000000..d0b86ec462 --- /dev/null +++ b/lisp/calc/calc-forms.el @@ -0,0 +1,1914 @@ +;; Calculator for GNU Emacs, part II [calc-forms.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-forms () nil) + + +(defun calc-time () + (interactive) + (calc-wrapper + (let ((time (current-time-string))) + (calc-enter-result 0 "time" + (list 'mod + (list 'hms + (string-to-int (substring time 11 13)) + (string-to-int (substring time 14 16)) + (string-to-int (substring time 17 19))) + (list 'hms 24 0 0))))) +) + + + + +(defun calc-to-hms (arg) + (interactive "P") + (calc-wrapper + (if (calc-is-inverse) + (if (eq calc-angle-mode 'rad) + (calc-unary-op ">rad" 'calcFunc-rad arg) + (calc-unary-op ">deg" 'calcFunc-deg arg)) + (calc-unary-op ">hms" 'calcFunc-hms arg))) +) + +(defun calc-from-hms (arg) + (interactive "P") + (calc-invert-func) + (calc-to-hms arg) +) + + +(defun calc-hms-notation (fmt) + (interactive "sHours-minutes-seconds format (hms, @ ' \", etc.): ") + (calc-wrapper + (if (string-match "\\`\\([^,; ]+\\)\\([,; ]*\\)\\([^,; ]\\)\\([,; ]*\\)\\([^,; ]\\)\\'" fmt) + (progn + (calc-change-mode 'calc-hms-format + (concat "%s" (math-match-substring fmt 1) + (math-match-substring fmt 2) + "%s" (math-match-substring fmt 3) + (math-match-substring fmt 4) + "%s" (math-match-substring fmt 5)) + t) + (setq-default calc-hms-format calc-hms-format)) ; for minibuffer + (error "Bad hours-minutes-seconds format."))) +) + +(defun calc-date-notation (fmt arg) + (interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP") + (calc-wrapper + (if (equal fmt "") + (setq fmt "1")) + (if (string-match "\\` *[0-9] *\\'" fmt) + (setq fmt (nth (string-to-int fmt) calc-standard-date-formats))) + (or (string-match "[a-zA-Z]" fmt) + (error "Bad date format specifier")) + (and arg + (>= (setq arg (prefix-numeric-value arg)) 0) + (<= arg 9) + (setq calc-standard-date-formats + (copy-sequence calc-standard-date-formats)) + (setcar (nthcdr arg calc-standard-date-formats) fmt)) + (let ((case-fold-search nil)) + (and (not (string-match "<.*>" fmt)) + (string-match "\\`[^hHspP]*\\([^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*[bBhHmpPsS]+[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*\\)[^hHspP]*\\'" fmt) + (string-match (concat "[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*" + (regexp-quote (math-match-substring fmt 1)) + "[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*") fmt) + (setq fmt (concat (substring fmt 0 (match-beginning 0)) + "<" + (substring fmt (match-beginning 0) (match-end 0)) + ">" + (substring fmt (match-end 0)))))) + (let ((lfmt nil) + (fullfmt nil) + (time nil) + pos pos2 sym temp) + (let ((case-fold-search nil)) + (and (setq temp (string-match ":[BS]S" fmt)) + (aset fmt temp ?C))) + (while (setq pos (string-match "[<>a-zA-Z]" fmt)) + (if (> pos 0) + (setq lfmt (cons (substring fmt 0 pos) lfmt))) + (setq pos2 (1+ pos)) + (cond ((= (aref fmt pos) ?\<) + (and time (error "Nested <'s not allowed")) + (and lfmt (setq fullfmt (nconc lfmt fullfmt) + lfmt nil)) + (setq time t)) + ((= (aref fmt pos) ?\>) + (or time (error "Misplaced > in format")) + (and lfmt (setq fullfmt (cons (nreverse lfmt) fullfmt) + lfmt nil)) + (setq time nil)) + (t + (if (string-match "\\`[^a-zA-Z]*[bB][a-zA-Z]" fmt) + (setq pos2 (1+ pos2))) + (while (and (< pos2 (length fmt)) + (= (upcase (aref fmt pos2)) + (upcase (aref fmt (1- pos2))))) + (setq pos2 (1+ pos2))) + (setq sym (intern (substring fmt pos pos2))) + (or (memq sym '(Y YY BY YYY YYYY + aa AA aaa AAA aaaa AAAA + bb BB bbb BBB bbbb BBBB + M MM BM mmm Mmm Mmmm MMM MMMM + D DD BD d ddd bdd + W www Www Wwww WWW WWWW + h hh bh H HH BH + p P pp PP pppp PPPP + m mm bm s ss bss SS BS C + N n J j U b)) + (and (eq sym 'X) (not lfmt) (not fullfmt)) + (error "Bad format code: %s" sym)) + (and (memq sym '(bb BB bbb BBB bbbb BBBB)) + (setq lfmt (cons 'b lfmt))) + (setq lfmt (cons sym lfmt)))) + (setq fmt (substring fmt pos2))) + (or (equal fmt "") + (setq lfmt (cons fmt lfmt))) + (and lfmt (if time + (setq fullfmt (cons (nreverse lfmt) fullfmt)) + (setq fullfmt (nconc lfmt fullfmt)))) + (calc-change-mode 'calc-date-format (nreverse fullfmt) t))) +) + + +(defun calc-hms-mode () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-angle-mode 'hms) + (message "Angles measured in degrees-minutes-seconds.")) +) + + +(defun calc-now (arg) + (interactive "P") + (calc-date-zero-args "now" 'calcFunc-now arg) +) + +(defun calc-date-part (arg) + (interactive "NPart code (1-9 = Y,M,D,H,M,S,Wd,Yd,Hms): ") + (if (or (< arg 1) (> arg 9)) + (error "Part code out of range")) + (calc-wrapper + (calc-enter-result 1 + (nth arg '(nil "year" "mnth" "day" "hour" "minu" + "sec" "wday" "yday" "hmst")) + (list (nth arg '(nil calcFunc-year calcFunc-month + calcFunc-day calcFunc-hour + calcFunc-minute calcFunc-second + calcFunc-weekday calcFunc-yearday + calcFunc-time)) + (calc-top-n 1)))) +) + +(defun calc-date (arg) + (interactive "p") + (if (or (< arg 1) (> arg 6)) + (error "Between one and six arguments are allowed")) + (calc-wrapper + (calc-enter-result arg "date" (cons 'calcFunc-date (calc-top-list-n arg)))) +) + +(defun calc-julian (arg) + (interactive "P") + (calc-date-one-arg "juln" 'calcFunc-julian arg) +) + +(defun calc-unix-time (arg) + (interactive "P") + (calc-date-one-arg "unix" 'calcFunc-unixtime arg) +) + +(defun calc-time-zone (arg) + (interactive "P") + (calc-date-zero-args "zone" 'calcFunc-tzone arg) +) + +(defun calc-convert-time-zones (old &optional new) + (interactive "sFrom time zone: ") + (calc-wrapper + (if (equal old "$") + (calc-enter-result 3 "tzcv" (cons 'calcFunc-tzconv (calc-top-list-n 3))) + (if (equal old "") (setq old "local")) + (or new + (setq new (read-string (concat "From time zone: " old + ", to zone: ")))) + (if (stringp old) (setq old (math-read-expr old))) + (if (eq (car-safe old) 'error) + (error "Error in expression: " (nth 1 old))) + (if (equal new "") (setq new "local")) + (if (stringp new) (setq new (math-read-expr new))) + (if (eq (car-safe new) 'error) + (error "Error in expression: " (nth 1 new))) + (calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv + (calc-top-n 1) old new)))) +) + +(defun calc-new-week (arg) + (interactive "P") + (calc-date-one-arg "nwwk" 'calcFunc-newweek arg) +) + +(defun calc-new-month (arg) + (interactive "P") + (calc-date-one-arg "nwmn" 'calcFunc-newmonth arg) +) + +(defun calc-new-year (arg) + (interactive "P") + (calc-date-one-arg "nwyr" 'calcFunc-newyear arg) +) + +(defun calc-inc-month (arg) + (interactive "p") + (calc-date-one-arg "incm" 'calcFunc-incmonth arg) +) + +(defun calc-business-days-plus (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "bus+" 'calcFunc-badd arg)) +) + +(defun calc-business-days-minus (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "bus-" 'calcFunc-bsub arg)) +) + +(defun calc-date-zero-args (prefix func arg) + (calc-wrapper + (if (consp arg) + (calc-enter-result 1 prefix (list func (calc-top-n 1))) + (calc-enter-result 0 prefix (if arg + (list func (prefix-numeric-value arg)) + (list func))))) +) + +(defun calc-date-one-arg (prefix func arg) + (calc-wrapper + (if (consp arg) + (calc-enter-result 2 prefix (cons func (calc-top-list-n 2))) + (calc-enter-result 1 prefix (if arg + (list func (calc-top-n 1) + (prefix-numeric-value arg)) + (list func (calc-top-n 1)))))) +) + + + + + + + + +;;;; Hours-minutes-seconds forms. + +(defun math-normalize-hms (a) + (let ((h (math-normalize (nth 1 a))) + (m (math-normalize (nth 2 a))) + (s (let ((calc-internal-prec (max (- calc-internal-prec 4) 3))) + (math-normalize (nth 3 a))))) + (if (math-negp h) + (progn + (if (math-posp s) + (setq s (math-add s -60) + m (math-add m 1))) + (if (math-posp m) + (setq m (math-add m -60) + h (math-add h 1))) + (if (not (Math-lessp -60 s)) + (setq s (math-add s 60) + m (math-add m -1))) + (if (not (Math-lessp -60 m)) + (setq m (math-add m 60) + h (math-add h -1)))) + (if (math-negp s) + (setq s (math-add s 60) + m (math-add m -1))) + (if (math-negp m) + (setq m (math-add m 60) + h (math-add h -1))) + (if (not (Math-lessp s 60)) + (setq s (math-add s -60) + m (math-add m 1))) + (if (not (Math-lessp m 60)) + (setq m (math-add m -60) + h (math-add h 1)))) + (if (and (eq (car-safe s) 'float) + (<= (+ (math-numdigs (nth 1 s)) (nth 2 s)) + (- 2 calc-internal-prec))) + (setq s 0)) + (list 'hms h m s)) +) + +;;; Convert A from ANG or current angular mode to HMS format. +(defun math-to-hms (a &optional ang) ; [X R] [Public] + (cond ((eq (car-safe a) 'hms) a) + ((eq (car-safe a) 'sdev) + (math-make-sdev (math-to-hms (nth 1 a)) + (math-to-hms (nth 2 a)))) + ((not (Math-numberp a)) + (list 'calcFunc-hms a)) + ((math-negp a) + (math-neg (math-to-hms (math-neg a) ang))) + ((eq (or ang calc-angle-mode) 'rad) + (math-to-hms (math-div a (math-pi-over-180)) 'deg)) + ((memq (car-safe a) '(cplx polar)) a) + (t + ;(setq a (let ((calc-internal-prec (max (1- calc-internal-prec) 3))) + ; (math-normalize a))) + (math-normalize + (let* ((b (math-mul a 3600)) + (hm (math-trunc (math-div b 60))) + (hmd (math-idivmod hm 60))) + (list 'hms + (car hmd) + (cdr hmd) + (math-sub b (math-mul hm 60))))))) +) +(defun calcFunc-hms (h &optional m s) + (or (Math-realp h) (math-reject-arg h 'realp)) + (or m (setq m 0)) + (or (Math-realp m) (math-reject-arg m 'realp)) + (or s (setq s 0)) + (or (Math-realp s) (math-reject-arg s 'realp)) + (if (and (not (Math-lessp m 0)) (Math-lessp m 60) + (not (Math-lessp s 0)) (Math-lessp s 60)) + (math-add (math-to-hms h) + (list 'hms 0 m s)) + (math-to-hms (math-add h + (math-add (math-div (or m 0) 60) + (math-div (or s 0) 3600))) + 'deg)) +) + +;;; Convert A from HMS format to ANG or current angular mode. +(defun math-from-hms (a &optional ang) ; [R X] [Public] + (cond ((not (eq (car-safe a) 'hms)) + (if (Math-numberp a) + a + (if (eq (car-safe a) 'sdev) + (math-make-sdev (math-from-hms (nth 1 a) ang) + (math-from-hms (nth 2 a) ang)) + (if (eq (or ang calc-angle-mode) 'rad) + (list 'calcFunc-rad a) + (list 'calcFunc-deg a))))) + ((math-negp a) + (math-neg (math-from-hms (math-neg a) ang))) + ((eq (or ang calc-angle-mode) 'rad) + (math-mul (math-from-hms a 'deg) (math-pi-over-180))) + (t + (math-add (math-div (math-add (math-div (nth 3 a) + '(float 6 1)) + (nth 2 a)) + 60) + (nth 1 a)))) +) + + + +;;;; Date forms. + + +;;; Some of these functions are adapted from Edward Reingold's "calendar.el". +;;; These versions are rewritten to use arbitrary-size integers. +;;; The Julian calendar is used up to 9/2/1752, after which the Gregorian +;;; calendar is used; the first day after 9/2/1752 is 9/14/1752. + +;;; A numerical date is the number of days since midnight on +;;; the morning of January 1, 1 A.D. If the date is a non-integer, +;;; it represents a specific date and time. +;;; A "dt" is a list of the form, (year month day), corresponding to +;;; an integer code, or (year month day hour minute second), corresponding +;;; to a non-integer code. + +(defun math-date-to-dt (value) + (if (eq (car-safe value) 'date) + (setq value (nth 1 value))) + (or (math-realp value) + (math-reject-arg value 'datep)) + (let* ((parts (math-date-parts value)) + (date (car parts)) + (time (nth 1 parts)) + (month 1) + day + (year (math-quotient (math-add date (if (Math-lessp date 711859) + 365 ; for speed, we take + -108)) ; >1950 as a special case + (if (math-negp value) 366 365))) + ; this result may be an overestimate + temp) + (while (Math-lessp date (setq temp (math-absolute-from-date year 1 1))) + (setq year (math-add year -1))) + (if (eq year 0) (setq year -1)) + (setq date (1+ (math-sub date temp))) + (and (eq year 1752) (>= date 247) + (setq date (+ date 11))) + (setq temp (if (math-leap-year-p year) + [1 32 61 92 122 153 183 214 245 275 306 336 999] + [1 32 60 91 121 152 182 213 244 274 305 335 999])) + (while (>= date (aref temp month)) + (setq month (1+ month))) + (setq day (1+ (- date (aref temp (1- month))))) + (if (math-integerp value) + (list year month day) + (list year month day + (/ time 3600) + (% (/ time 60) 60) + (math-add (% time 60) (nth 2 parts))))) +) + +(defun math-dt-to-date (dt) + (or (integerp (nth 1 dt)) + (math-reject-arg (nth 1 dt) 'fixnump)) + (if (or (< (nth 1 dt) 1) (> (nth 1 dt) 12)) + (math-reject-arg (nth 1 dt) "Month value is out of range")) + (or (integerp (nth 2 dt)) + (math-reject-arg (nth 2 dt) 'fixnump)) + (if (or (< (nth 2 dt) 1) (> (nth 2 dt) 31)) + (math-reject-arg (nth 2 dt) "Day value is out of range")) + (let ((date (math-absolute-from-date (car dt) (nth 1 dt) (nth 2 dt)))) + (if (nth 3 dt) + (math-add (math-float date) + (math-div (math-add (+ (* (nth 3 dt) 3600) + (* (nth 4 dt) 60)) + (nth 5 dt)) + '(float 864 2))) + date)) +) + +(defun math-date-parts (value &optional offset) + (let* ((date (math-floor value)) + (time (math-round (math-mul (math-sub value (or offset date)) 86400) + (and (> calc-internal-prec 12) + (- calc-internal-prec 12)))) + (ftime (math-floor time))) + (list date + ftime + (math-sub time ftime))) +) + + +(defun math-this-year () + (string-to-int (substring (current-time-string) -4)) +) + +(defun math-leap-year-p (year) + (if (Math-lessp year 1752) + (if (math-negp year) + (= (math-imod (math-neg year) 4) 1) + (= (math-imod year 4) 0)) + (setq year (math-imod year 400)) + (or (and (= (% year 4) 0) (/= (% year 100) 0)) + (= year 0))) +) + +(defun math-days-in-month (year month) + (if (and (= month 2) (math-leap-year-p year)) + 29 + (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))) +) + +(defun math-day-number (year month day) + (let ((day-of-year (+ day (* 31 (1- month))))) + (if (> month 2) + (progn + (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) + (if (math-leap-year-p year) + (setq day-of-year (1+ day-of-year))))) + (and (eq year 1752) + (or (> month 9) + (and (= month 9) (>= day 14))) + (setq day-of-year (- day-of-year 11))) + day-of-year) +) + +(defun math-absolute-from-date (year month day) + (if (eq year 0) (setq year -1)) + (let ((yearm1 (math-sub year 1))) + (math-sub (math-add (math-day-number year month day) + (math-add (math-mul 365 yearm1) + (if (math-posp year) + (math-quotient yearm1 4) + (math-sub 365 + (math-quotient (math-sub 3 year) + 4))))) + (if (or (Math-lessp year 1753) + (and (eq year 1752) (<= month 9))) + 1 + (let ((correction (math-mul (math-quotient yearm1 100) 3))) + (let ((res (math-idivmod correction 4))) + (math-add (if (= (cdr res) 0) + -1 + 0) + (car res))))))) +) + + +;;; It is safe to redefine these in your .emacs file to use a different +;;; language. + +(defvar math-long-weekday-names '( "Sunday" "Monday" "Tuesday" "Wednesday" + "Thursday" "Friday" "Saturday" )) +(defvar math-short-weekday-names '( "Sun" "Mon" "Tue" "Wed" + "Thu" "Fri" "Sat" )) + +(defvar math-long-month-names '( "January" "February" "March" "April" + "May" "June" "July" "August" + "September" "October" "November" "December" )) +(defvar math-short-month-names '( "Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" )) + + +(defun math-format-date (date) + (if (eq (car-safe date) 'date) + (setq date (nth 1 date))) + (let ((entry (list date calc-internal-prec calc-date-format))) + (or (cdr (assoc entry math-format-date-cache)) + (let* ((dt nil) + (calc-group-digits nil) + (calc-leading-zeros nil) + (calc-number-radix 10) + year month day weekday hour minute second + (bc-flag nil) + (fmt (apply 'concat (mapcar 'math-format-date-part + calc-date-format)))) + (setq math-format-date-cache (cons (cons entry fmt) + math-format-date-cache)) + (and (setq dt (nthcdr 10 math-format-date-cache)) + (setcdr dt nil)) + fmt))) +) +(setq math-format-date-cache nil) + +(defun math-format-date-part (x) + (cond ((stringp x) + x) + ((listp x) + (if (math-integerp date) + "" + (apply 'concat (mapcar 'math-format-date-part x)))) + ((eq x 'X) + "") + ((eq x 'N) + (math-format-number date)) + ((eq x 'n) + (math-format-number (math-floor date))) + ((eq x 'J) + (math-format-number (math-add date '(float (bigpos 235 214 17) -1)))) + ((eq x 'j) + (math-format-number (math-add (math-floor date) '(bigpos 424 721 1)))) + ((eq x 'U) + (math-format-number (nth 1 (math-date-parts date 719164)))) + ((progn + (or dt + (progn + (setq dt (math-date-to-dt date) + year (car dt) + month (nth 1 dt) + day (nth 2 dt) + weekday (math-mod (math-add (math-floor date) 6) 7) + hour (nth 3 dt) + minute (nth 4 dt) + second (nth 5 dt)) + (and (memq 'b calc-date-format) + (math-negp year) + (setq year (math-neg year) + bc-flag t)))) + (memq x '(Y YY BY))) + (if (and (integerp year) (> year 1940) (< year 2040)) + (format (cond ((eq x 'YY) "%02d") + ((eq x 'BYY) "%2d") + (t "%d")) + (% year 100)) + (if (and (natnump year) (< year 100)) + (format "+%d" year) + (math-format-number year)))) + ((eq x 'YYY) + (math-format-number year)) + ((eq x 'YYYY) + (if (and (natnump year) (< year 100)) + (format "+%d" year) + (math-format-number year))) + ((eq x 'b) "") + ((eq x 'aa) + (and (not bc-flag) "ad")) + ((eq x 'AA) + (and (not bc-flag) "AD")) + ((eq x 'aaa) + (and (not bc-flag) "ad ")) + ((eq x 'AAA) + (and (not bc-flag) "AD ")) + ((eq x 'aaaa) + (and (not bc-flag) "a.d.")) + ((eq x 'AAAA) + (and (not bc-flag) "A.D.")) + ((eq x 'bb) + (and bc-flag "bc")) + ((eq x 'BB) + (and bc-flag "BC")) + ((eq x 'bbb) + (and bc-flag " bc")) + ((eq x 'BBB) + (and bc-flag " BC")) + ((eq x 'bbbb) + (and bc-flag "b.c.")) + ((eq x 'BBBB) + (and bc-flag "B.C.")) + ((eq x 'M) + (format "%d" month)) + ((eq x 'MM) + (format "%02d" month)) + ((eq x 'BM) + (format "%2d" month)) + ((eq x 'mmm) + (downcase (nth (1- month) math-short-month-names))) + ((eq x 'Mmm) + (nth (1- month) math-short-month-names)) + ((eq x 'MMM) + (upcase (nth (1- month) math-short-month-names))) + ((eq x 'Mmmm) + (nth (1- month) math-long-month-names)) + ((eq x 'MMMM) + (upcase (nth (1- month) math-long-month-names))) + ((eq x 'D) + (format "%d" day)) + ((eq x 'DD) + (format "%02d" day)) + ((eq x 'BD) + (format "%2d" day)) + ((eq x 'W) + (format "%d" weekday)) + ((eq x 'www) + (downcase (nth weekday math-short-weekday-names))) + ((eq x 'Www) + (nth weekday math-short-weekday-names)) + ((eq x 'WWW) + (upcase (nth weekday math-short-weekday-names))) + ((eq x 'Wwww) + (nth weekday math-long-weekday-names)) + ((eq x 'WWWW) + (upcase (nth weekday math-long-weekday-names))) + ((eq x 'd) + (format "%d" (math-day-number year month day))) + ((eq x 'ddd) + (format "%03d" (math-day-number year month day))) + ((eq x 'bdd) + (format "%3d" (math-day-number year month day))) + ((eq x 'h) + (and hour (format "%d" hour))) + ((eq x 'hh) + (and hour (format "%02d" hour))) + ((eq x 'bh) + (and hour (format "%2d" hour))) + ((eq x 'H) + (and hour (format "%d" (1+ (% (+ hour 11) 12))))) + ((eq x 'HH) + (and hour (format "%02d" (1+ (% (+ hour 11) 12))))) + ((eq x 'BH) + (and hour (format "%2d" (1+ (% (+ hour 11) 12))))) + ((eq x 'p) + (and hour (if (< hour 12) "a" "p"))) + ((eq x 'P) + (and hour (if (< hour 12) "A" "P"))) + ((eq x 'pp) + (and hour (if (< hour 12) "am" "pm"))) + ((eq x 'PP) + (and hour (if (< hour 12) "AM" "PM"))) + ((eq x 'pppp) + (and hour (if (< hour 12) "a.m." "p.m."))) + ((eq x 'PPPP) + (and hour (if (< hour 12) "A.M." "P.M."))) + ((eq x 'm) + (and minute (format "%d" minute))) + ((eq x 'mm) + (and minute (format "%02d" minute))) + ((eq x 'bm) + (and minute (format "%2d" minute))) + ((eq x 'C) + (and second (not (math-zerop second)) + ":")) + ((memq x '(s ss bs SS BS)) + (and second + (not (and (memq x '(SS BS)) (math-zerop second))) + (if (integerp second) + (format (cond ((memq x '(ss SS)) "%02d") + ((memq x '(bs BS)) "%2d") + (t "%d")) + second) + (concat (if (Math-lessp second 10) + (cond ((memq x '(ss SS)) "0") + ((memq x '(bs BS)) " ") + (t "")) + "") + (let ((calc-float-format + (list 'fix (min (- 12 calc-internal-prec) + 0)))) + (math-format-number second))))))) +) + + +(defun math-parse-date (str) + (catch 'syntax + (or (math-parse-standard-date str t) + (math-parse-standard-date str nil) + (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" str) + (list 'date (math-read-number (math-match-substring str 1)))) + (let ((case-fold-search t) + (year nil) (month nil) (day nil) (weekday nil) + (hour nil) (minute nil) (second nil) (bc-flag nil) + (a nil) (b nil) (c nil) (bigyear nil) temp) + + ;; Extract the time, if any. + (if (or (string-match "\\([0-9][0-9]?\\):\\([0-9][0-9]?\\)\\(:\\([0-9][0-9]?\\(\\.[0-9]+\\)?\\)\\)? *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)?" str) + (string-match "\\([0-9][0-9]?\\)\\(\\)\\(\\(\\(\\)\\)\\) *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)" str)) + (let ((ampm (math-match-substring str 6))) + (setq hour (string-to-int (math-match-substring str 1)) + minute (math-match-substring str 2) + second (math-match-substring str 4) + str (concat (substring str 0 (match-beginning 0)) + (substring str (match-end 0)))) + (if (equal minute "") + (setq minute 0) + (setq minute (string-to-int minute))) + (if (equal second "") + (setq second 0) + (setq second (math-read-number second))) + (if (equal ampm "") + (if (> hour 23) + (throw 'syntax "Hour value out of range")) + (setq ampm (upcase (aref ampm 0))) + (if (memq ampm '(?N ?M)) + (if (and (= hour 12) (= minute 0) (eq second 0)) + (if (eq ampm ?M) (setq hour 0)) + (throw 'syntax + "Time must be 12:00:00 in this context")) + (if (or (= hour 0) (> hour 12)) + (throw 'syntax "Hour value out of range")) + (if (eq (= ampm ?A) (= hour 12)) + (setq hour (% (+ hour 12) 24))))))) + + ;; Rewrite xx-yy-zz to xx/yy/zz to avoid seeing "-" as a minus sign. + (while (string-match "[0-9a-zA-Z]\\(-\\)[0-9a-zA-Z]" str) + (progn + (setq str (copy-sequence str)) + (aset str (match-beginning 1) ?\/))) + + ;; Extract obvious month or weekday names. + (if (string-match "[a-zA-Z]" str) + (progn + (setq month (math-parse-date-word math-long-month-names)) + (setq weekday (math-parse-date-word math-long-weekday-names)) + (or month (setq month + (math-parse-date-word math-short-month-names))) + (or weekday (math-parse-date-word math-short-weekday-names)) + (or hour + (if (setq temp (math-parse-date-word + '( "noon" "midnight" "mid" ))) + (setq hour (if (= temp 1) 12 0) minute 0 second 0))) + (or (math-parse-date-word '( "ad" "a.d." )) + (if (math-parse-date-word '( "bc" "b.c." )) + (setq bc-flag t))) + (if (string-match "[a-zA-Z]+" str) + (throw 'syntax (format "Bad word in date: \"%s\"" + (math-match-substring str 0)))))) + + ;; If there is a huge number other than the year, ignore it. + (while (and (string-match "[-+]?0*[1-9][0-9][0-9][0-9][0-9]+" str) + (setq temp (concat (substring str 0 (match-beginning 0)) + (substring str (match-end 0)))) + (string-match "[4-9][0-9]\\|[0-9][0-9][0-9]\\|[-+][0-9]+[^-]*\\'" temp)) + (setq str temp)) + + ;; If there is a number with a sign or a large number, it is a year. + (if (or (string-match "\\([-+][0-9]+\\)[^-]*\\'" str) + (string-match "\\(0*[1-9][0-9][0-9]+\\)" str)) + (setq year (math-match-substring str 1) + str (concat (substring str 0 (match-beginning 1)) + (substring str (match-end 1))) + year (math-read-number year) + bigyear t)) + + ;; Collect remaining numbers. + (setq temp 0) + (while (string-match "[0-9]+" str temp) + (and c (throw 'syntax "Too many numbers in date")) + (setq c (string-to-int (math-match-substring str 0))) + (or b (setq b c c nil)) + (or a (setq a b b nil)) + (setq temp (match-end 0))) + + ;; Check that we have the right amount of information. + (setq temp (+ (if year 1 0) (if month 1 0) (if day 1 0) + (if a 1 0) (if b 1 0) (if c 1 0))) + (if (> temp 3) + (throw 'syntax "Too many numbers in date") + (if (or (< temp 2) (and year (= temp 2))) + (throw 'syntax "Not enough numbers in date") + (if (= temp 2) ; if year omitted, assume current year + (setq year (math-this-year))))) + + ;; A large number must be a year. + (or year + (if (and a (or (> a 31) (< a 1))) + (setq year a a b b c c nil) + (if (and b (or (> b 31) (< b 1))) + (setq year b b c c nil) + (if (and c (or (> c 31) (< c 1))) + (setq year c c nil))))) + + ;; A medium-large number must be a day. + (if year + (if (and a (> a 12)) + (setq day a a b b c c nil) + (if (and b (> b 12)) + (setq day b b c c nil) + (if (and c (> c 12)) + (setq day c c nil))))) + + ;; We may know enough to sort it out now. + (if (and year day) + (or month (setq month a)) + (if (and year month) + (setq day a) + + ;; Interpret order of numbers as same as for display format. + (setq temp calc-date-format) + (while temp + (cond ((not (symbolp (car temp)))) + ((memq (car temp) '(Y YY BY YYY YYYY)) + (or year (setq year a a b b c))) + ((memq (car temp) '(M MM BM mmm Mmm Mmmm MMM MMMM)) + (or month (setq month a a b b c))) + ((memq (car temp) '(D DD BD)) + (or day (setq day a a b b c)))) + (setq temp (cdr temp))) + + ;; If display format was not complete, assume American style. + (or month (setq month a a b b c)) + (or day (setq day a a b b c)) + (or year (setq year a a b b c)))) + + (if bc-flag + (setq year (math-neg (math-abs year)))) + + (math-parse-date-validate year bigyear month day + hour minute second)))) +) + +(defun math-parse-date-validate (year bigyear month day hour minute second) + (and (not bigyear) (natnump year) (< year 100) + (setq year (+ year (if (< year 40) 2000 1900)))) + (if (eq year 0) + (throw 'syntax "Year value is out of range")) + (if (or (< month 1) (> month 12)) + (throw 'syntax "Month value is out of range")) + (if (or (< day 1) (> day (math-days-in-month year month))) + (throw 'syntax "Day value is out of range")) + (and hour + (progn + (if (or (< hour 0) (> hour 23)) + (throw 'syntax "Hour value is out of range")) + (if (or (< minute 0) (> minute 59)) + (throw 'syntax "Minute value is out of range")) + (if (or (math-negp second) (not (Math-lessp second 60))) + (throw 'syntax "Seconds value is out of range")))) + (list 'date (math-dt-to-date (append (list year month day) + (and hour (list hour minute second))))) +) + +(defun math-parse-date-word (names &optional front) + (let ((n 1)) + (while (and names (not (string-match (if (equal (car names) "Sep") + "Sept?" + (regexp-quote (car names))) + str))) + (setq names (cdr names) + n (1+ n))) + (and names + (or (not front) (= (match-beginning 0) 0)) + (progn + (setq str (concat (substring str 0 (match-beginning 0)) + (if front "" " ") + (substring str (match-end 0)))) + n))) +) + +(defun math-parse-standard-date (str with-time) + (let ((case-fold-search t) + (okay t) num + (fmt calc-date-format) this next (gnext nil) + (year nil) (month nil) (day nil) (bigyear nil) (yearday nil) + (hour nil) (minute nil) (second nil) (bc-flag nil)) + (while (and fmt okay) + (setq this (car fmt) + fmt (setq fmt (or (cdr fmt) + (prog1 + gnext + (setq gnext nil)))) + next (car fmt)) + (if (consp next) (setq next (car next))) + (or (cond ((listp this) + (or (not with-time) + (not this) + (setq gnext fmt + fmt this))) + ((stringp this) + (if (and (<= (length this) (length str)) + (equal this + (substring str 0 (length this)))) + (setq str (substring str (length this))))) + ((eq this 'X) + t) + ((memq this '(n N j J)) + (and (string-match "\\`[-+]?[0-9.]+\\([eE][-+]?[0-9]+\\)?" str) + (setq num (math-match-substring str 0) + str (substring str (match-end 0)) + num (math-date-to-dt (math-read-number num)) + num (math-sub num + (if (memq this '(n N)) + 0 + (if (or (eq this 'j) + (math-integerp num)) + '(bigpos 424 721 1) + '(float (bigpos 235 214 17) + -1)))) + hour (or (nth 3 num) hour) + minute (or (nth 4 num) minute) + second (or (nth 5 num) second) + year (car num) + month (nth 1 num) + day (nth 2 num)))) + ((eq this 'U) + (and (string-match "\\`[-+]?[0-9]+" str) + (setq num (math-match-substring str 0) + str (substring str (match-end 0)) + num (math-date-to-dt + (math-add 719164 + (math-div (math-read-number num) + '(float 864 2)))) + hour (nth 3 num) + minute (nth 4 num) + second (nth 5 num) + year (car num) + month (nth 1 num) + day (nth 2 num)))) + ((memq this '(mmm Mmm MMM)) + (setq month (math-parse-date-word math-short-month-names t))) + ((memq this '(Mmmm MMMM)) + (setq month (math-parse-date-word math-long-month-names t))) + ((memq this '(www Www WWW)) + (math-parse-date-word math-short-weekday-names t)) + ((memq this '(Wwww WWWW)) + (math-parse-date-word math-long-weekday-names t)) + ((memq this '(p P)) + (if (string-match "\\`a" str) + (setq hour (if (= hour 12) 0 hour) + str (substring str 1)) + (if (string-match "\\`p" str) + (setq hour (if (= hour 12) 12 (% (+ hour 12) 24)) + str (substring str 1))))) + ((memq this '(pp PP pppp PPPP)) + (if (string-match "\\`am\\|a\\.m\\." str) + (setq hour (if (= hour 12) 0 hour) + str (substring str (match-end 0))) + (if (string-match "\\`pm\\|p\\.m\\." str) + (setq hour (if (= hour 12) 12 (% (+ hour 12) 24)) + str (substring str (match-end 0)))))) + ((memq this '(Y YY BY YYY YYYY)) + (and (if (memq next '(MM DD ddd hh HH mm ss SS)) + (if (memq this '(Y YY BYY)) + (string-match "\\` *[0-9][0-9]" str) + (string-match "\\`[0-9][0-9][0-9][0-9]" str)) + (string-match "\\`[-+]?[0-9]+" str)) + (setq year (math-match-substring str 0) + bigyear (or (eq this 'YYY) + (memq (aref str 0) '(?\+ ?\-))) + str (substring str (match-end 0)) + year (math-read-number year)))) + ((eq this 'b) + t) + ((memq this '(aa AA aaaa AAAA)) + (if (string-match "\\` *\\(ad\\|a\\.d\\.\\)" str) + (setq str (substring str (match-end 0))))) + ((memq this '(aaa AAA)) + (if (string-match "\\` *ad *" str) + (setq str (substring str (match-end 0))))) + ((memq this '(bb BB bbb BBB bbbb BBBB)) + (if (string-match "\\` *\\(bc\\|b\\.c\\.\\)" str) + (setq str (substring str (match-end 0)) + bc-flag t))) + ((memq this '(s ss bs SS BS)) + (and (if (memq next '(YY YYYY MM DD hh HH mm)) + (string-match "\\` *[0-9][0-9]\\(\\.[0-9]+\\)?" str) + (string-match "\\` *[0-9][0-9]?\\(\\.[0-9]+\\)?" str)) + (setq second (math-match-substring str 0) + str (substring str (match-end 0)) + second (math-read-number second)))) + ((eq this 'C) + (if (string-match "\\`:[0-9][0-9]" str) + (setq str (substring str 1)) + t)) + ((or (not (if (and (memq this '(ddd MM DD hh HH mm)) + (memq next '(YY YYYY MM DD ddd + hh HH mm ss SS))) + (if (eq this 'ddd) + (string-match "\\` *[0-9][0-9][0-9]" str) + (string-match "\\` *[0-9][0-9]" str)) + (string-match "\\` *[0-9]+" str))) + (and (setq num (string-to-int + (math-match-substring str 0)) + str (substring str (match-end 0))) + nil)) + nil) + ((eq this 'W) + (and (>= num 0) (< num 7))) + ((memq this '(d ddd bdd)) + (setq yearday num)) + ((memq this '(M MM BM)) + (setq month num)) + ((memq this '(D DD BD)) + (setq day num)) + ((memq this '(h hh bh H HH BH)) + (setq hour num)) + ((memq this '(m mm bm)) + (setq minute num))) + (setq okay nil))) + (if yearday + (if (and month day) + (setq yearday nil) + (setq month 1 day 1))) + (if (and okay (equal str "")) + (and month day (or (not (or hour minute second)) + (and hour minute)) + (progn + (or year (setq year (math-this-year))) + (or second (setq second 0)) + (if bc-flag + (setq year (math-neg (math-abs year)))) + (setq day (math-parse-date-validate year bigyear month day + hour minute second)) + (if yearday + (setq day (math-add day (1- yearday)))) + day)))) +) + + +(defun calcFunc-now (&optional zone) + (let ((date (let ((calc-date-format nil)) + (math-parse-date (current-time-string))))) + (if (consp date) + (if zone + (math-add date (math-div (math-sub (calcFunc-tzone nil date) + (calcFunc-tzone zone date)) + '(float 864 2))) + date) + (calc-record-why "*Unable to interpret current date from system") + (append (list 'calcFunc-now) (and zone (list zone))))) +) + +(defun calcFunc-year (date) + (car (math-date-to-dt date)) +) + +(defun calcFunc-month (date) + (nth 1 (math-date-to-dt date)) +) + +(defun calcFunc-day (date) + (nth 2 (math-date-to-dt date)) +) + +(defun calcFunc-weekday (date) + (if (eq (car-safe date) 'date) + (setq date (nth 1 date))) + (or (math-realp date) + (math-reject-arg date 'datep)) + (math-mod (math-add (math-floor date) 6) 7) +) + +(defun calcFunc-yearday (date) + (let ((dt (math-date-to-dt date))) + (math-day-number (car dt) (nth 1 dt) (nth 2 dt))) +) + +(defun calcFunc-hour (date) + (if (eq (car-safe date) 'hms) + (nth 1 date) + (or (nth 3 (math-date-to-dt date)) 0)) +) + +(defun calcFunc-minute (date) + (if (eq (car-safe date) 'hms) + (nth 2 date) + (or (nth 4 (math-date-to-dt date)) 0)) +) + +(defun calcFunc-second (date) + (if (eq (car-safe date) 'hms) + (nth 3 date) + (or (nth 5 (math-date-to-dt date)) 0)) +) + +(defun calcFunc-time (date) + (let ((dt (math-date-to-dt date))) + (if (nth 3 dt) + (cons 'hms (nthcdr 3 dt)) + (list 'hms 0 0 0))) +) + +(defun calcFunc-date (date &optional month day hour minute second) + (and (math-messy-integerp month) (setq month (math-trunc month))) + (and month (not (integerp month)) (math-reject-arg month 'fixnump)) + (and (math-messy-integerp day) (setq day (math-trunc day))) + (and day (not (integerp day)) (math-reject-arg day 'fixnump)) + (if (and (eq (car-safe hour) 'hms) (not minute)) + (setq second (nth 3 hour) + minute (nth 2 hour) + hour (nth 1 hour))) + (and (math-messy-integerp hour) (setq hour (math-trunc hour))) + (and hour (not (integerp hour)) (math-reject-arg hour 'fixnump)) + (and (math-messy-integerp minute) (setq minute (math-trunc minute))) + (and minute (not (integerp minute)) (math-reject-arg minute 'fixnump)) + (and (math-messy-integerp second) (setq second (math-trunc second))) + (and second (not (math-realp second)) (math-reject-arg second 'realp)) + (if month + (progn + (and (math-messy-integerp date) (setq date (math-trunc date))) + (and date (not (math-integerp date)) (math-reject-arg date 'integerp)) + (if day + (if hour + (list 'date (math-dt-to-date (list date month day hour + (or minute 0) + (or second 0)))) + (list 'date (math-dt-to-date (list date month day)))) + (list 'date (math-dt-to-date (list (math-this-year) date month))))) + (if (math-realp date) + (list 'date date) + (if (eq (car date) 'date) + (nth 1 date) + (math-reject-arg date 'datep)))) +) + +(defun calcFunc-julian (date &optional zone) + (if (math-realp date) + (list 'date (if (math-integerp date) + (math-sub date '(bigpos 424 721 1)) + (setq date (math-sub date '(float (bigpos 235 214 17) -1))) + (math-sub date (math-div (calcFunc-tzone zone date) + '(float 864 2))))) + (if (eq (car date) 'date) + (math-add (nth 1 date) (if (math-integerp (nth 1 date)) + '(bigpos 424 721 1) + (math-add '(float (bigpos 235 214 17) -1) + (math-div (calcFunc-tzone zone date) + '(float 864 2))))) + (math-reject-arg date 'datep))) +) + +(defun calcFunc-unixtime (date &optional zone) + (if (math-realp date) + (progn + (setq date (math-add 719164 (math-div date '(float 864 2)))) + (list 'date (math-sub date (math-div (calcFunc-tzone zone date) + '(float 864 2))))) + (if (eq (car date) 'date) + (math-add (nth 1 (math-date-parts (nth 1 date) 719164)) + (calcFunc-tzone zone date)) + (math-reject-arg date 'datep))) +) + +(defun calcFunc-tzone (&optional zone date) + (if zone + (cond ((math-realp zone) + (math-round (math-mul zone 3600))) + ((eq (car zone) 'hms) + (math-round (math-mul (math-from-hms zone 'deg) 3600))) + ((eq (car zone) '+) + (math-add (calcFunc-tzone (nth 1 zone) date) + (calcFunc-tzone (nth 2 zone) date))) + ((eq (car zone) '-) + (math-sub (calcFunc-tzone (nth 1 zone) date) + (calcFunc-tzone (nth 2 zone) date))) + ((eq (car zone) 'var) + (let ((name (upcase (symbol-name (nth 1 zone)))) + found) + (if (setq found (assoc name math-tzone-names)) + (calcFunc-tzone (math-add (nth 1 found) + (if (integerp (nth 2 found)) + (nth 2 found) + (or + (math-daylight-savings-adjust + date (car found)) + 0))) + date) + (if (equal name "LOCAL") + (calcFunc-tzone nil date) + (math-reject-arg zone "*Unrecognized time zone name"))))) + (t (math-reject-arg zone "*Expected a time zone"))) + (if (calc-var-value 'var-TimeZone) + (calcFunc-tzone (calc-var-value 'var-TimeZone) date) + (let ((p math-tzone-names) + (offset 0) + (tz '(var error var-error))) + (save-excursion + (set-buffer (get-buffer-create " *Calc Temporary*")) + (erase-buffer) + (call-process "date" nil t) + (goto-char 1) + (let ((case-fold-search t)) + (while (and p (not (search-forward (car (car p)) nil t))) + (setq p (cdr p)))) + (if (looking-at "\\([-+][0-9]?[0-9]\\)\\([0-9][0-9]\\)?\\(\\'\\|[^0-9]\\)") + (setq offset (math-add + (string-to-int (buffer-substring + (match-beginning 1) + (match-end 1))) + (if (match-beginning 2) + (math-div (string-to-int (buffer-substring + (match-beginning 2) + (match-end 2))) + 60) + 0))))) + (if p + (progn + (setq p (car p)) + ;; Try to convert to a generalized time zone. + (if (integerp (nth 2 p)) + (let ((gen math-tzone-names)) + (while (and gen + (not (equal (nth 2 (car gen)) (car p))) + (not (equal (nth 3 (car gen)) (car p))) + (not (equal (nth 4 (car gen)) (car p))) + (not (equal (nth 5 (car gen)) (car p)))) + (setq gen (cdr gen))) + (and gen + (setq gen (car gen)) + (equal (math-daylight-savings-adjust nil (car gen)) + (nth 2 p)) + (setq p gen)))) + (setq tz (math-add (list 'var + (intern (car p)) + (intern (concat "var-" (car p)))) + offset)))) + (kill-buffer " *Calc Temporary*") + (setq var-TimeZone tz) + (calc-refresh-evaltos 'var-TimeZone) + (calcFunc-tzone tz date)))) +) + +;;; Note: Longer names must appear before shorter names which are +;;; substrings of them. +(defvar math-tzone-names + '( ( "MEGT" -1 "MET" "METDST" ) ; Middle Europe + ( "METDST" -1 -1 ) ( "MET" -1 0 ) + ( "MEGZ" -1 "MEZ" "MESZ" ) ( "MEZ" -1 0 ) ( "MESZ" -1 -1 ) + ( "WEGT" 0 "WET" "WETDST" ) ; Western Europe + ( "WETDST" 0 -1 ) ( "WET" 0 0 ) + ( "BGT" 0 "GMT" "BST" ) ( "GMT" 0 0 ) ( "BST" 0 -1 ) ; Britain + ( "NGT" (float 35 -1) "NST" "NDT" ) ; Newfoundland + ( "NST" (float 35 -1) 0 ) ( "NDT" (float 35 -1) -1 ) + ( "AGT" 4 "AST" "ADT" ) ( "AST" 4 0 ) ( "ADT" 4 -1 ) ; Atlantic + ( "EGT" 5 "EST" "EDT" ) ( "EST" 5 0 ) ( "EDT" 5 -1 ) ; Eastern + ( "CGT" 6 "CST" "CDT" ) ( "CST" 6 0 ) ( "CDT" 6 -1 ) ; Central + ( "MGT" 7 "MST" "MDT" ) ( "MST" 7 0 ) ( "MDT" 7 -1 ) ; Mountain + ( "PGT" 8 "PST" "PDT" ) ( "PST" 8 0 ) ( "PDT" 8 -1 ) ; Pacific + ( "YGT" 9 "YST" "YDT" ) ( "YST" 9 0 ) ( "YDT" 9 -1 ) ; Yukon +)) + + +(defun math-daylight-savings-adjust (date zone &optional dt) + (or date (setq date (nth 1 (calcFunc-now)))) + (let (bump) + (if (eq (car-safe date) 'date) + (setq bump 0 + date (nth 1 date)) + (if (and date (math-realp date)) + (let ((zadj (assoc zone math-tzone-names))) + (if zadj (setq bump -1 + date (math-sub date (math-div (nth 1 zadj) + '(float 24 0)))))) + (math-reject-arg date 'datep))) + (setq date (math-float date)) + (or dt (setq dt (math-date-to-dt date))) + (and math-daylight-savings-hook + (funcall math-daylight-savings-hook date dt zone bump))) +) + +(defun calcFunc-dsadj (date &optional zone) + (if zone + (or (eq (car-safe zone) 'var) + (math-reject-arg zone "*Time zone variable expected")) + (setq zone (or (calc-var-value 'var-TimeZone) + (progn + (calcFunc-tzone) + (calc-var-value 'var-TimeZone))))) + (setq zone (and (eq (car-safe zone) 'var) + (upcase (symbol-name (nth 1 zone))))) + (let ((zadj (assoc zone math-tzone-names))) + (or zadj (math-reject-arg zone "*Unrecognized time zone name")) + (if (integerp (nth 2 zadj)) + (nth 2 zadj) + (math-daylight-savings-adjust date zone))) +) + +(defun calcFunc-tzconv (date z1 z2) + (if (math-realp date) + (nth 1 (calcFunc-tzconv (list 'date date) z1 z2)) + (calcFunc-unixtime (calcFunc-unixtime date z1) z2)) +) + +(defvar math-daylight-savings-hook 'math-std-daylight-savings) + +(defun math-std-daylight-savings (date dt zone bump) + "Standard North American daylight savings algorithm. +This implements the rules for the U.S. and Canada as of 1987. +Daylight savings begins on the first Sunday of April at 2 a.m., +and ends on the last Sunday of October at 2 a.m." + (cond ((< (nth 1 dt) 4) 0) + ((= (nth 1 dt) 4) + (let ((sunday (math-prev-weekday-in-month date dt 7 0))) + (cond ((< (nth 2 dt) sunday) 0) + ((= (nth 2 dt) sunday) + (if (>= (nth 3 dt) (+ 3 bump)) -1 0)) + (t -1)))) + ((< (nth 1 dt) 10) -1) + ((= (nth 1 dt) 10) + (let ((sunday (math-prev-weekday-in-month date dt 31 0))) + (cond ((< (nth 2 dt) sunday) -1) + ((= (nth 2 dt) sunday) + (if (>= (nth 3 dt) (+ 2 bump)) 0 -1)) + (t 0)))) + (t 0)) +) + +;;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given +;;; day of the given month. +(defun math-prev-weekday-in-month (date dt day wday) + (or day (setq day (nth 2 dt))) + (if (> day (math-days-in-month (car dt) (nth 1 dt))) + (setq day (math-days-in-month (car dt) (nth 1 dt)))) + (let ((zeroth (math-sub (math-floor date) (nth 2 dt)))) + (math-sub (nth 1 (calcFunc-newweek (math-add zeroth day))) zeroth)) +) + +(defun calcFunc-pwday (date &optional day weekday) + (if (eq (car-safe date) 'date) + (setq date (nth 1 date))) + (or (math-realp date) + (math-reject-arg date 'datep)) + (if (math-messy-integerp day) (setq day (math-trunc day))) + (or (integerp day) (math-reject-arg day 'fixnump)) + (if (= day 0) (setq day 31)) + (and (or (< day 7) (> day 31)) (math-reject-arg day 'range)) + (math-prev-weekday-in-month date (math-date-to-dt date) day (or weekday 0)) +) + + +(defun calcFunc-newweek (date &optional weekday) + (if (eq (car-safe date) 'date) + (setq date (nth 1 date))) + (or (math-realp date) + (math-reject-arg date 'datep)) + (or weekday (setq weekday 0)) + (and (math-messy-integerp weekday) (setq weekday (math-trunc weekday))) + (or (integerp weekday) (math-reject-arg weekday 'fixnump)) + (and (or (< weekday 0) (> weekday 6)) (math-reject-arg weekday 'range)) + (setq date (math-floor date)) + (list 'date (math-sub date (calcFunc-weekday (math-sub date weekday)))) +) + +(defun calcFunc-newmonth (date &optional day) + (or day (setq day 1)) + (and (math-messy-integerp day) (setq day (math-trunc day))) + (or (integerp day) (math-reject-arg day 'fixnump)) + (and (or (< day 0) (> day 31)) (math-reject-arg day 'range)) + (let ((dt (math-date-to-dt date))) + (if (or (= day 0) (> day (math-days-in-month (car dt) (nth 1 dt)))) + (setq day (math-days-in-month (car dt) (nth 1 dt)))) + (and (eq (car dt) 1752) (= (nth 1 dt) 9) + (if (>= day 14) (setq day (- day 11)))) + (list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1)) + (1- day)))) +) + +(defun calcFunc-newyear (date &optional day) + (or day (setq day 1)) + (and (math-messy-integerp day) (setq day (math-trunc day))) + (or (integerp day) (math-reject-arg day 'fixnump)) + (let ((dt (math-date-to-dt date))) + (if (and (>= day 0) (<= day 366)) + (let ((max (if (eq (car dt) 1752) 355 + (if (math-leap-year-p (car dt)) 366 365)))) + (if (or (= day 0) (> day max)) (setq day max)) + (list 'date (math-add (math-dt-to-date (list (car dt) 1 1)) + (1- day)))) + (if (and (>= day -12) (<= day -1)) + (list 'date (math-dt-to-date (list (car dt) (- day) 1))) + (math-reject-arg day 'range)))) +) + +(defun calcFunc-incmonth (date &optional step) + (or step (setq step 1)) + (and (math-messy-integerp step) (setq step (math-trunc step))) + (or (math-integerp step) (math-reject-arg step 'integerp)) + (let* ((dt (math-date-to-dt date)) + (year (car dt)) + (month (math-add (1- (nth 1 dt)) step)) + (extra (calcFunc-idiv month 12)) + (day (nth 2 dt))) + (setq month (1+ (math-sub month (math-mul extra 12))) + year (math-add year extra) + day (min day (math-days-in-month year month))) + (and (math-posp (car dt)) (not (math-posp year)) + (setq year (math-sub year 1))) ; did we go past the year zero? + (and (math-negp (car dt)) (not (math-negp year)) + (setq year (math-add year 1))) + (list 'date (math-dt-to-date + (cons year (cons month (cons day (cdr (cdr (cdr dt))))))))) +) + +(defun calcFunc-incyear (date &optional step) + (calcFunc-incmonth date (math-mul (or step 1) 12)) +) + + + +(defun calcFunc-bsub (a b) + (or (eq (car-safe a) 'date) + (math-reject-arg a 'datep)) + (if (eq (car-safe b) 'date) + (if (math-lessp (nth 1 a) (nth 1 b)) + (math-neg (calcFunc-bsub b a)) + (math-setup-holidays b) + (let* ((da (math-to-business-day a)) + (db (math-to-business-day b))) + (math-add (math-sub (car da) (car db)) + (if (and (cdr db) (not (cdr da))) 1 0)))) + (calcFunc-badd a (math-neg b))) +) + +(defun calcFunc-badd (a b) + (if (eq (car-safe b) 'date) + (if (eq (car-safe a) 'date) + (math-reject-arg nil "*Illegal combination in date arithmetic") + (calcFunc-badd b a)) + (if (eq (car-safe a) 'date) + (if (Math-realp b) + (if (Math-zerop b) + a + (let* ((d (math-to-business-day a)) + (bb (math-add (car d) + (if (and (cdr d) (Math-posp b)) + (math-sub b 1) b)))) + (or (math-from-business-day bb) + (calcFunc-badd a b)))) + (if (eq (car-safe b) 'hms) + (let ((hours (nth 7 math-holidays-cache))) + (setq b (math-div (math-from-hms b 'deg) 24)) + (if hours + (setq b (math-div b (cdr hours)))) + (calcFunc-badd a b)) + (math-reject-arg nil "*Illegal combination in date arithmetic"))) + (math-reject-arg a 'datep))) +) + +(defun calcFunc-holiday (a) + (if (cdr (math-to-business-day a)) 1 0) +) + + +(setq math-holidays-cache nil) +(setq math-holidays-cache-tag t) + + +;;; Compute the number of business days since Jan 1, 1 AD. + +(defun math-to-business-day (date &optional need-year) + (if (eq (car-safe date) 'date) + (setq date (nth 1 date))) + (or (Math-realp date) + (math-reject-arg date 'datep)) + (let* ((day (math-floor date)) + (time (math-sub date day)) + (dt (math-date-to-dt day)) + (delta 0) + (holiday nil)) + (or (not need-year) (eq (car dt) need-year) + (math-reject-arg (list 'date day) "*Generated holiday has wrong year")) + (math-setup-holidays date) + (let ((days (car math-holidays-cache))) + (while (and (setq days (cdr days)) (< (car days) day)) + (setq delta (1+ delta))) + (and days (= day (car days)) + (setq holiday t))) + (let* ((weekdays (nth 3 math-holidays-cache)) + (weeks (1- (/ (+ day 6) 7))) + (wkday (- day 1 (* weeks 7)))) + (setq delta (+ delta (* weeks (length weekdays)))) + (while (and weekdays (< (car weekdays) wkday)) + (setq weekdays (cdr weekdays) + delta (1+ delta))) + (and weekdays (eq wkday (car weekdays)) + (setq holiday t))) + (let ((hours (nth 7 math-holidays-cache))) + (if hours + (progn + (setq time (math-div (math-sub time (car hours)) (cdr hours))) + (if (Math-lessp time 0) (setq time 0)) + (or (Math-lessp time 1) + (setq time + (math-sub 1 + (math-div 1 (math-mul 86400 (cdr hours))))))))) + (cons (math-add (math-sub day delta) time) holiday)) +) + + +;;; Compute the date a certain number of business days since Jan 1, 1 AD. +;;; If this returns NIL, holiday table was adjusted; redo calculation. + +(defun math-from-business-day (num) + (let* ((day (math-floor num)) + (time (math-sub num day))) + (or (integerp day) + (math-reject-arg nil "*Date is outside valid range")) + (math-setup-holidays) + (let ((days (nth 1 math-holidays-cache)) + (delta 0)) + (while (and (setq days (cdr days)) (< (car days) day)) + (setq delta (1+ delta))) + (setq day (+ day delta))) + (let* ((weekdays (nth 3 math-holidays-cache)) + (bweek (- 7 (length weekdays))) + (weeks (1- (/ (+ day (1- bweek)) bweek))) + (wkday (- day 1 (* weeks bweek))) + (w 0)) + (setq day (+ day (* weeks (length weekdays)))) + (while (if (memq w weekdays) + (setq day (1+ day)) + (> (setq wkday (1- wkday)) 0)) + (setq w (1+ w))) + (let ((hours (nth 7 math-holidays-cache))) + (if hours + (setq time (math-add (math-mul time (cdr hours)) (car hours))))) + (and (not (math-setup-holidays day)) + (list 'date (math-add day time))))) +) + + +(defun math-setup-holidays (&optional date) + (or (eq (calc-var-value 'var-Holidays) math-holidays-cache-tag) + (let ((h (calc-var-value 'var-Holidays)) + (wdnames '( (sun . 0) (mon . 1) (tue . 2) (wed . 3) + (thu . 4) (fri . 5) (sat . 6) )) + (days nil) (weekdays nil) (exprs nil) (limit nil) (hours nil)) + (or (math-vectorp h) + (math-reject-arg h "*Holidays variable must be a vector")) + (while (setq h (cdr h)) + (cond ((or (and (eq (car-safe (car h)) 'date) + (integerp (nth 1 (car h)))) + (and (eq (car-safe (car h)) 'intv) + (eq (car-safe (nth 2 (car h))) 'date)) + (eq (car-safe (car h)) 'vec)) + (setq days (cons (car h) days))) + ((and (eq (car-safe (car h)) 'var) + (assq (nth 1 (car h)) wdnames)) + (setq weekdays (cons (cdr (assq (nth 1 (car h)) wdnames)) + weekdays))) + ((and (eq (car-safe (car h)) 'intv) + (eq (car-safe (nth 2 (car h))) 'hms) + (eq (car-safe (nth 3 (car h))) 'hms)) + (if hours + (math-reject-arg + (car h) "*Only one hours interval allowed in Holidays")) + (setq hours (math-div (car h) '(hms 24 0 0))) + (if (or (Math-lessp (nth 2 hours) 0) + (Math-lessp 1 (nth 3 hours))) + (math-reject-arg + (car h) "*Hours interval out of range")) + (setq hours (cons (nth 2 hours) + (math-sub (nth 3 hours) (nth 2 hours)))) + (if (Math-zerop (cdr hours)) + (math-reject-arg + (car h) "*Degenerate hours interval"))) + ((or (and (eq (car-safe (car h)) 'intv) + (Math-integerp (nth 2 (car h))) + (Math-integerp (nth 3 (car h)))) + (and (integerp (car h)) + (> (car h) 1900) (< (car h) 2100))) + (if limit + (math-reject-arg + (car h) "*Only one limit allowed in Holidays")) + (setq limit (calcFunc-vint (car h) '(intv 3 1 2737))) + (if (equal limit '(vec)) + (math-reject-arg (car h) "*Limit is out of range"))) + ((or (math-expr-contains (car h) '(var y var-y)) + (math-expr-contains (car h) '(var m var-m))) + (setq exprs (cons (car h) exprs))) + (t (math-reject-arg + (car h) "*Holidays must contain a vector of holidays")))) + (if (= (length weekdays) 7) + (math-reject-arg nil "*Too many weekend days")) + (setq math-holidays-cache (list (list -1) ; 0: days list + (list -1) ; 1: inverse-days list + nil ; 2: exprs + (sort weekdays '<) + (or limit '(intv 3 1 2737)) + nil ; 5: (lo.hi) expanded years + (cons exprs days) + hours) ; 7: business hours + math-holidays-cache-tag (calc-var-value 'var-Holidays)))) + (if date + (let ((year (calcFunc-year date)) + (limits (nth 5 math-holidays-cache)) + (done nil)) + (or (eq (calcFunc-in year (nth 4 math-holidays-cache)) 1) + (progn + (or (eq (car-safe date) 'date) (setq date (list 'date date))) + (math-reject-arg date "*Date is outside valid range"))) + (unwind-protect + (let ((days (nth 6 math-holidays-cache))) + (if days + (let ((year nil)) ; see below + (setcar (nthcdr 6 math-holidays-cache) nil) + (math-setup-add-holidays (cons 'vec (cdr days))) + (setcar (nthcdr 2 math-holidays-cache) (car days)))) + (cond ((not (nth 2 math-holidays-cache)) + (setq done t) + nil) + ((not limits) + (setcar (nthcdr 5 math-holidays-cache) (cons year year)) + (math-setup-year-holidays year) + (setq done t)) + ((< year (car limits)) + (message "Computing holidays, %d .. %d" + year (1- (car limits))) + (calc-set-command-flag 'clear-message) + (while (< year (car limits)) + (setcar limits (1- (car limits))) + (math-setup-year-holidays (car limits))) + (setq done t)) + ((> year (cdr limits)) + (message "Computing holidays, %d .. %d" + (1+ (cdr limits)) year) + (calc-set-command-flag 'clear-message) + (while (> year (cdr limits)) + (setcdr limits (1+ (cdr limits))) + (math-setup-year-holidays (cdr limits))) + (setq done t)) + (t + (setq done t) + nil))) + (or done (setq math-holidays-cache-tag t))))) +) + +(defun math-setup-year-holidays (year) + (let ((exprs (nth 2 math-holidays-cache))) + (while exprs + (let* ((var-y year) + (var-m nil) + (expr (math-evaluate-expr (car exprs)))) + (if (math-expr-contains expr '(var m var-m)) + (let ((var-m 0)) + (while (<= (setq var-m (1+ var-m)) 12) + (math-setup-add-holidays (math-evaluate-expr expr)))) + (math-setup-add-holidays expr))) + (setq exprs (cdr exprs)))) +) + +(defun math-setup-add-holidays (days) ; uses "year" + (cond ((eq (car-safe days) 'vec) + (while (setq days (cdr days)) + (math-setup-add-holidays (car days)))) + ((eq (car-safe days) 'intv) + (let ((day (math-ceiling (nth 2 days)))) + (or (eq (calcFunc-in day days) 1) + (setq day (math-add day 1))) + (while (eq (calcFunc-in day days) 1) + (math-setup-add-holidays day) + (setq day (math-add day 1))))) + ((eq (car-safe days) 'date) + (math-setup-add-holidays (nth 1 days))) + ((eq days 0)) + ((integerp days) + (let ((b (math-to-business-day days year))) + (or (cdr b) ; don't register holidays twice! + (let ((prev (car math-holidays-cache)) + (iprev (nth 1 math-holidays-cache))) + (while (and (cdr prev) (< (nth 1 prev) days)) + (setq prev (cdr prev) iprev (cdr iprev))) + (setcdr prev (cons days (cdr prev))) + (setcdr iprev (cons (car b) (cdr iprev))) + (while (setq iprev (cdr iprev)) + (setcar iprev (1- (car iprev)))))))) + ((Math-realp days) + (math-reject-arg (list 'date days) "*Invalid holiday value")) + (t + (math-reject-arg days "*Holiday formula failed to evaluate"))) +) + + + + +;;;; Error forms. + +;;; Build a standard deviation form. [X X X] +(defun math-make-sdev (x sigma) + (if (memq (car-safe x) '(date mod sdev intv vec)) + (math-reject-arg x 'realp)) + (if (memq (car-safe sigma) '(date mod sdev intv vec)) + (math-reject-arg sigma 'realp)) + (if (or (Math-negp sigma) (memq (car-safe sigma) '(cplx polar))) + (setq sigma (math-abs sigma))) + (if (and (Math-zerop sigma) (Math-scalarp x)) + x + (list 'sdev x sigma)) +) +(defun calcFunc-sdev (x sigma) + (math-make-sdev x sigma) +) + + + +;;;; Modulo forms. + +(defun math-normalize-mod (a) + (let ((n (math-normalize (nth 1 a))) + (m (math-normalize (nth 2 a)))) + (if (and (math-anglep n) (math-anglep m) (math-posp m)) + (math-make-mod n m) + (math-normalize (list 'calcFunc-makemod n m)))) +) + +;;; Build a modulo form. [N R R] +(defun math-make-mod (n m) + (setq calc-previous-modulo m) + (and n + (cond ((not (Math-anglep m)) + (math-reject-arg m 'anglep)) + ((not (math-posp m)) + (math-reject-arg m 'posp)) + ((Math-anglep n) + (if (or (Math-negp n) + (not (Math-lessp n m))) + (list 'mod (math-mod n m) m) + (list 'mod n m))) + ((memq (car n) '(+ - / vec neg)) + (math-normalize + (cons (car n) + (mapcar (function (lambda (x) (math-make-mod x m))) + (cdr n))))) + ((and (eq (car n) '*) (Math-anglep (nth 1 n))) + (math-mul (math-make-mod (nth 1 n) m) (nth 2 n))) + ((memq (car n) '(* ^ var calcFunc-subscr)) + (math-mul (math-make-mod 1 m) n)) + (t (math-reject-arg n 'anglep)))) +) +(defun calcFunc-makemod (n m) + (math-make-mod n m) +) + + + +;;;; Interval forms. + +;;; Build an interval form. [X S X X] +(defun math-make-intv (mask lo hi) + (if (memq (car-safe lo) '(cplx polar mod sdev intv vec)) + (math-reject-arg lo 'realp)) + (if (memq (car-safe hi) '(cplx polar mod sdev intv vec)) + (math-reject-arg hi 'realp)) + (or (eq (eq (car-safe lo) 'date) (eq (car-safe hi) 'date)) + (math-reject-arg (if (eq (car-safe lo) 'date) hi lo) 'datep)) + (if (and (or (Math-realp lo) (eq (car lo) 'date)) + (or (Math-realp hi) (eq (car hi) 'date))) + (let ((cmp (math-compare lo hi))) + (if (= cmp 0) + (if (= mask 3) + lo + (list 'intv mask lo hi)) + (if (> cmp 0) + (if (= mask 3) + (list 'intv 2 lo lo) + (list 'intv mask lo lo)) + (list 'intv mask lo hi)))) + (list 'intv mask lo hi)) +) +(defun calcFunc-intv (mask lo hi) + (if (math-messy-integerp mask) (setq mask (math-trunc mask))) + (or (natnump mask) (math-reject-arg mask 'fixnatnump)) + (or (<= mask 3) (math-reject-arg mask 'range)) + (math-make-intv mask lo hi) +) + +(defun math-sort-intv (mask lo hi) + (if (Math-lessp hi lo) + (math-make-intv (aref [0 2 1 3] mask) hi lo) + (math-make-intv mask lo hi)) +) + + + + +(defun math-combine-intervals (a am b bm c cm d dm) + (let (res) + (if (= (setq res (math-compare a c)) 1) + (setq a c am cm) + (if (= res 0) + (setq am (or am cm)))) + (if (= (setq res (math-compare b d)) -1) + (setq b d bm dm) + (if (= res 0) + (setq bm (or bm dm)))) + (math-make-intv (+ (if am 2 0) (if bm 1 0)) a b)) +) + + +(defun math-div-mod (a b m) ; [R R R R] (Returns nil if no solution) + (and (Math-integerp a) (Math-integerp b) (Math-integerp m) + (let ((u1 1) (u3 b) (v1 0) (v3 m)) + (while (not (eq v3 0)) ; See Knuth sec 4.5.2, exercise 15 + (let* ((q (math-idivmod u3 v3)) + (t1 (math-sub u1 (math-mul v1 (car q))))) + (setq u1 v1 u3 v3 v1 t1 v3 (cdr q)))) + (let ((q (math-idivmod a u3))) + (and (eq (cdr q) 0) + (math-mod (math-mul (car q) u1) m))))) +) + +(defun math-mod-intv (a b) + (let* ((q1 (math-floor (math-div (nth 2 a) b))) + (q2 (math-floor (math-div (nth 3 a) b))) + (m1 (math-sub (nth 2 a) (math-mul q1 b))) + (m2 (math-sub (nth 3 a) (math-mul q2 b)))) + (cond ((equal q1 q2) + (math-sort-intv (nth 1 a) m1 m2)) + ((and (math-equal-int (math-sub q2 q1) 1) + (math-zerop m2) + (memq (nth 1 a) '(0 2))) + (math-make-intv (nth 1 a) m1 b)) + (t + (math-make-intv 2 0 b)))) +) + + +(defun math-read-angle-brackets () + (let* ((last (or (math-check-for-commas t) (length exp-str))) + (str (substring exp-str exp-pos last)) + (res + (if (string-match "\\` *\\([a-zA-Z#][a-zA-Z0-9#]* *,? *\\)*:" str) + (let ((str1 (substring str 0 (1- (match-end 0)))) + (str2 (substring str (match-end 0))) + (calc-hashes-used 0)) + (setq str1 (math-read-expr (concat "[" str1 "]"))) + (if (eq (car-safe str1) 'error) + str1 + (setq str2 (math-read-expr str2)) + (if (eq (car-safe str2) 'error) + str2 + (append '(calcFunc-lambda) (cdr str1) (list str2))))) + (if (string-match "#" str) + (let ((calc-hashes-used 0)) + (and (setq str (math-read-expr str)) + (if (eq (car-safe str) 'error) + str + (append '(calcFunc-lambda) + (calc-invent-args calc-hashes-used) + (list str))))) + (math-parse-date str))))) + (if (stringp res) + (throw 'syntax res)) + (if (eq (car-safe res) 'error) + (throw 'syntax (nth 2 res))) + (setq exp-pos (1+ last)) + (math-read-token) + res) +) + diff --git a/lisp/calc/calc-frac.el b/lisp/calc/calc-frac.el new file mode 100644 index 0000000000..dc5bf6e2d2 --- /dev/null +++ b/lisp/calc/calc-frac.el @@ -0,0 +1,235 @@ +;; Calculator for GNU Emacs, part II [calc-frac.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-frac () nil) + + +(defun calc-fdiv (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op ":" 'calcFunc-fdiv arg 1)) +) + + +(defun calc-fraction (arg) + (interactive "P") + (calc-slow-wrapper + (let ((func (if (calc-is-hyperbolic) 'calcFunc-frac 'calcFunc-pfrac))) + (if (eq arg 0) + (calc-enter-result 2 "frac" (list func + (calc-top-n 2) + (calc-top-n 1))) + (calc-enter-result 1 "frac" (list func + (calc-top-n 1) + (prefix-numeric-value (or arg 0))))))) +) + + +(defun calc-over-notation (fmt) + (interactive "sFraction separator (:, ::, /, //, :/): ") + (calc-wrapper + (if (string-match "\\`\\([^ 0-9][^ 0-9]?\\)[0-9]*\\'" fmt) + (let ((n nil)) + (if (/= (match-end 0) (match-end 1)) + (setq n (string-to-int (substring fmt (match-end 1))) + fmt (math-match-substring fmt 1))) + (if (eq n 0) (error "Bad denominator")) + (calc-change-mode 'calc-frac-format (list fmt n) t)) + (error "Bad fraction separator format."))) +) + +(defun calc-slash-notation (n) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t)) +) + + +(defun calc-frac-mode (n) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-prefer-frac n nil t) + (message (if calc-prefer-frac + "Integer division will now generate fractions." + "Integer division will now generate floating-point results."))) +) + + + + + +;;;; Fractions. + +;;; Build a normalized fraction. [R I I] +;;; (This could probably be implemented more efficiently than using +;;; the plain gcd algorithm.) +(defun math-make-frac (num den) + (if (Math-integer-negp den) + (setq num (math-neg num) + den (math-neg den))) + (let ((gcd (math-gcd num den))) + (if (eq gcd 1) + (if (eq den 1) + num + (list 'frac num den)) + (if (equal gcd den) + (math-quotient num gcd) + (list 'frac (math-quotient num gcd) (math-quotient den gcd))))) +) + +(defun calc-add-fractions (a b) + (if (eq (car-safe a) 'frac) + (if (eq (car-safe b) 'frac) + (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b)) + (math-mul (nth 2 a) (nth 1 b))) + (math-mul (nth 2 a) (nth 2 b))) + (math-make-frac (math-add (nth 1 a) + (math-mul (nth 2 a) b)) + (nth 2 a))) + (math-make-frac (math-add (math-mul a (nth 2 b)) + (nth 1 b)) + (nth 2 b))) +) + +(defun calc-mul-fractions (a b) + (if (eq (car-safe a) 'frac) + (if (eq (car-safe b) 'frac) + (math-make-frac (math-mul (nth 1 a) (nth 1 b)) + (math-mul (nth 2 a) (nth 2 b))) + (math-make-frac (math-mul (nth 1 a) b) + (nth 2 a))) + (math-make-frac (math-mul a (nth 1 b)) + (nth 2 b))) +) + +(defun calc-div-fractions (a b) + (if (eq (car-safe a) 'frac) + (if (eq (car-safe b) 'frac) + (math-make-frac (math-mul (nth 1 a) (nth 2 b)) + (math-mul (nth 2 a) (nth 1 b))) + (math-make-frac (nth 1 a) + (math-mul (nth 2 a) b))) + (math-make-frac (math-mul a (nth 2 b)) + (nth 1 b))) +) + + + + +;;; Convert a real value to fractional form. [T R I; T R F] [Public] +(defun calcFunc-frac (a &optional tol) + (or tol (setq tol 0)) + (cond ((Math-ratp a) + a) + ((memq (car a) '(cplx polar vec hms date sdev intv mod)) + (cons (car a) (mapcar (function + (lambda (x) + (calcFunc-frac x tol))) + (cdr a)))) + ((Math-messy-integerp a) + (math-trunc a)) + ((Math-negp a) + (math-neg (calcFunc-frac (math-neg a) tol))) + ((not (eq (car a) 'float)) + (if (math-infinitep a) + a + (if (math-provably-integerp a) + a + (math-reject-arg a 'numberp)))) + ((integerp tol) + (if (<= tol 0) + (setq tol (+ tol calc-internal-prec))) + (calcFunc-frac a (list 'float 5 + (- (+ (math-numdigs (nth 1 a)) + (nth 2 a)) + (1+ tol))))) + ((not (eq (car tol) 'float)) + (if (Math-realp tol) + (calcFunc-frac a (math-float tol)) + (math-reject-arg tol 'realp))) + ((Math-negp tol) + (calcFunc-frac a (math-neg tol))) + ((Math-zerop tol) + (calcFunc-frac a 0)) + ((not (math-lessp-float tol '(float 1 0))) + (math-trunc a)) + ((Math-zerop a) + 0) + (t + (let ((cfrac (math-continued-fraction a tol)) + (calc-prefer-frac t)) + (math-eval-continued-fraction cfrac)))) +) + +(defun math-continued-fraction (a tol) + (let ((calc-internal-prec (+ calc-internal-prec 2))) + (let ((cfrac nil) + (aa a) + (calc-prefer-frac nil) + int) + (while (or (null cfrac) + (and (not (Math-zerop aa)) + (not (math-lessp-float + (math-abs + (math-sub a + (let ((f (math-eval-continued-fraction + cfrac))) + (math-working "Fractionalize" f) + f))) + tol)))) + (setq int (math-trunc aa) + aa (math-sub aa int) + cfrac (cons int cfrac)) + (or (Math-zerop aa) + (setq aa (math-div 1 aa)))) + cfrac)) +) + +(defun math-eval-continued-fraction (cf) + (let ((n (car cf)) + (d 1) + temp) + (while (setq cf (cdr cf)) + (setq temp (math-add (math-mul (car cf) n) d) + d n + n temp)) + (math-div n d)) +) + + + +(defun calcFunc-fdiv (a b) ; [R I I] [Public] + (if (Math-num-integerp a) + (if (Math-num-integerp b) + (if (Math-zerop b) + (math-reject-arg a "*Division by zero") + (math-make-frac (math-trunc a) (math-trunc b))) + (math-reject-arg b 'integerp)) + (math-reject-arg a 'integerp)) +) + diff --git a/lisp/calc/calc-funcs.el b/lisp/calc/calc-funcs.el new file mode 100644 index 0000000000..90b4761a8a --- /dev/null +++ b/lisp/calc/calc-funcs.el @@ -0,0 +1,1034 @@ +;; Calculator for GNU Emacs, part II [calc-funcs.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-funcs () nil) + + +(defun calc-inc-gamma (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (if (calc-is-hyperbolic) + (calc-binary-op "gamG" 'calcFunc-gammaG arg) + (calc-binary-op "gamQ" 'calcFunc-gammaQ arg)) + (if (calc-is-hyperbolic) + (calc-binary-op "gamg" 'calcFunc-gammag arg) + (calc-binary-op "gamP" 'calcFunc-gammaP arg)))) +) + +(defun calc-erf (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-unary-op "erfc" 'calcFunc-erfc arg) + (calc-unary-op "erf" 'calcFunc-erf arg))) +) + +(defun calc-erfc (arg) + (interactive "P") + (calc-invert-func) + (calc-erf arg) +) + +(defun calc-beta (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "beta" 'calcFunc-beta arg)) +) + +(defun calc-inc-beta () + (interactive) + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-enter-result 3 "betB" (cons 'calcFunc-betaB (calc-top-list-n 3))) + (calc-enter-result 3 "betI" (cons 'calcFunc-betaI (calc-top-list-n 3))))) +) + +(defun calc-bessel-J (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "besJ" 'calcFunc-besJ arg)) +) + +(defun calc-bessel-Y (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "besY" 'calcFunc-besY arg)) +) + +(defun calc-bernoulli-number (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-binary-op "bern" 'calcFunc-bern arg) + (calc-unary-op "bern" 'calcFunc-bern arg))) +) + +(defun calc-euler-number (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-binary-op "eulr" 'calcFunc-euler arg) + (calc-unary-op "eulr" 'calcFunc-euler arg))) +) + +(defun calc-stirling-number (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-binary-op "str2" 'calcFunc-stir2 arg) + (calc-binary-op "str1" 'calcFunc-stir1 arg))) +) + +(defun calc-utpb () + (interactive) + (calc-prob-dist "b" 3) +) + +(defun calc-utpc () + (interactive) + (calc-prob-dist "c" 2) +) + +(defun calc-utpf () + (interactive) + (calc-prob-dist "f" 3) +) + +(defun calc-utpn () + (interactive) + (calc-prob-dist "n" 3) +) + +(defun calc-utpp () + (interactive) + (calc-prob-dist "p" 2) +) + +(defun calc-utpt () + (interactive) + (calc-prob-dist "t" 2) +) + +(defun calc-prob-dist (letter nargs) + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-enter-result nargs (concat "ltp" letter) + (append (list (intern (concat "calcFunc-ltp" letter)) + (calc-top-n 1)) + (calc-top-list-n (1- nargs) 2))) + (calc-enter-result nargs (concat "utp" letter) + (append (list (intern (concat "calcFunc-utp" letter)) + (calc-top-n 1)) + (calc-top-list-n (1- nargs) 2))))) +) + + + + +;;; Sources: Numerical Recipes, Press et al; +;;; Handbook of Mathematical Functions, Abramowitz & Stegun. + + +;;; Gamma function. + +(defun calcFunc-gamma (x) + (or (math-numberp x) (math-reject-arg x 'numberp)) + (calcFunc-fact (math-add x -1)) +) + +(defun math-gammap1-raw (x &optional fprec nfprec) ; compute gamma(1 + x) + (or fprec + (setq fprec (math-float calc-internal-prec) + nfprec (math-float (- calc-internal-prec)))) + (cond ((math-lessp-float (calcFunc-re x) fprec) + (if (math-lessp-float (calcFunc-re x) nfprec) + (math-neg (math-div + (math-pi) + (math-mul (math-gammap1-raw + (math-add (math-neg x) + '(float -1 0)) + fprec nfprec) + (math-sin-raw + (math-mul (math-pi) x))))) + (let ((xplus1 (math-add x '(float 1 0)))) + (math-div (math-gammap1-raw xplus1 fprec nfprec) xplus1)))) + ((and (math-realp x) + (math-lessp-float '(float 736276 0) x)) + (math-overflow)) + (t ; re(x) now >= 10.0 + (let ((xinv (math-div 1 x)) + (lnx (math-ln-raw x))) + (math-mul (math-sqrt-two-pi) + (math-exp-raw + (math-gamma-series + (math-sub (math-mul (math-add x '(float 5 -1)) + lnx) + x) + xinv + (math-sqr xinv) + '(float 0 0) + 2)))))) +) + +(defun math-gamma-series (sum x xinvsqr oterm n) + (math-working "gamma" sum) + (let* ((bn (math-bernoulli-number n)) + (term (math-mul (math-div-float (math-float (nth 1 bn)) + (math-float (* (nth 2 bn) + (* n (1- n))))) + x)) + (next (math-add sum term))) + (if (math-nearly-equal sum next) + next + (if (> n (* 2 calc-internal-prec)) + (progn + ;; Need this because series eventually diverges for large enough n. + (calc-record-why + "*Gamma computation stopped early, not all digits may be valid") + next) + (math-gamma-series next (math-mul x xinvsqr) xinvsqr term (+ n 2))))) +) + + +;;; Incomplete gamma function. + +(defun calcFunc-gammaP (a x) + (if (equal x '(var inf var-inf)) + '(float 1 0) + (math-inexact-result) + (or (Math-numberp a) (math-reject-arg a 'numberp)) + (or (math-numberp x) (math-reject-arg x 'numberp)) + (if (and (math-num-integerp a) + (integerp (setq a (math-trunc a))) + (> a 0) (< a 20)) + (math-sub 1 (calcFunc-gammaQ a x)) + (let ((math-current-gamma-value (calcFunc-gamma a))) + (math-div (calcFunc-gammag a x) math-current-gamma-value)))) +) + +(defun calcFunc-gammaQ (a x) + (if (equal x '(var inf var-inf)) + '(float 0 0) + (math-inexact-result) + (or (Math-numberp a) (math-reject-arg a 'numberp)) + (or (math-numberp x) (math-reject-arg x 'numberp)) + (if (and (math-num-integerp a) + (integerp (setq a (math-trunc a))) + (> a 0) (< a 20)) + (let ((n 0) + (sum '(float 1 0)) + (term '(float 1 0))) + (math-with-extra-prec 1 + (while (< (setq n (1+ n)) a) + (setq term (math-div (math-mul term x) n) + sum (math-add sum term)) + (math-working "gamma" sum)) + (math-mul sum (calcFunc-exp (math-neg x))))) + (let ((math-current-gamma-value (calcFunc-gamma a))) + (math-div (calcFunc-gammaG a x) math-current-gamma-value)))) +) + +(defun calcFunc-gammag (a x) + (if (equal x '(var inf var-inf)) + (calcFunc-gamma a) + (math-inexact-result) + (or (Math-numberp a) (math-reject-arg a 'numberp)) + (or (Math-numberp x) (math-reject-arg x 'numberp)) + (math-with-extra-prec 2 + (setq a (math-float a)) + (setq x (math-float x)) + (if (or (math-negp (calcFunc-re a)) + (math-lessp-float (calcFunc-re x) + (math-add-float (calcFunc-re a) + '(float 1 0)))) + (math-inc-gamma-series a x) + (math-sub (or math-current-gamma-value (calcFunc-gamma a)) + (math-inc-gamma-cfrac a x))))) +) +(setq math-current-gamma-value nil) + +(defun calcFunc-gammaG (a x) + (if (equal x '(var inf var-inf)) + '(float 0 0) + (math-inexact-result) + (or (Math-numberp a) (math-reject-arg a 'numberp)) + (or (Math-numberp x) (math-reject-arg x 'numberp)) + (math-with-extra-prec 2 + (setq a (math-float a)) + (setq x (math-float x)) + (if (or (math-negp (calcFunc-re a)) + (math-lessp-float (calcFunc-re x) + (math-add-float (math-abs-approx a) + '(float 1 0)))) + (math-sub (or math-current-gamma-value (calcFunc-gamma a)) + (math-inc-gamma-series a x)) + (math-inc-gamma-cfrac a x)))) +) + +(defun math-inc-gamma-series (a x) + (if (Math-zerop x) + '(float 0 0) + (math-mul (math-exp-raw (math-sub (math-mul a (math-ln-raw x)) x)) + (math-with-extra-prec 2 + (let ((start (math-div '(float 1 0) a))) + (math-inc-gamma-series-step start start a x))))) +) + +(defun math-inc-gamma-series-step (sum term a x) + (math-working "gamma" sum) + (setq a (math-add a '(float 1 0)) + term (math-div (math-mul term x) a)) + (let ((next (math-add sum term))) + (if (math-nearly-equal sum next) + next + (math-inc-gamma-series-step next term a x))) +) + +(defun math-inc-gamma-cfrac (a x) + (if (Math-zerop x) + (or math-current-gamma-value (calcFunc-gamma a)) + (math-mul (math-exp-raw (math-sub (math-mul a (math-ln-raw x)) x)) + (math-inc-gamma-cfrac-step '(float 1 0) x + '(float 0 0) '(float 1 0) + '(float 1 0) '(float 1 0) '(float 0 0) + a x))) +) + +(defun math-inc-gamma-cfrac-step (a0 a1 b0 b1 n fac g a x) + (let ((ana (math-sub n a)) + (anf (math-mul n fac))) + (setq n (math-add n '(float 1 0)) + a0 (math-mul (math-add a1 (math-mul a0 ana)) fac) + b0 (math-mul (math-add b1 (math-mul b0 ana)) fac) + a1 (math-add (math-mul x a0) (math-mul anf a1)) + b1 (math-add (math-mul x b0) (math-mul anf b1))) + (if (math-zerop a1) + (math-inc-gamma-cfrac-step a0 a1 b0 b1 n fac g a x) + (setq fac (math-div '(float 1 0) a1)) + (let ((next (math-mul b1 fac))) + (math-working "gamma" next) + (if (math-nearly-equal next g) + next + (math-inc-gamma-cfrac-step a0 a1 b0 b1 n fac next a x))))) +) + + +;;; Error function. + +(defun calcFunc-erf (x) + (if (equal x '(var inf var-inf)) + '(float 1 0) + (if (equal x '(neg (var inf var-inf))) + '(float -1 0) + (if (Math-zerop x) + x + (let ((math-current-gamma-value (math-sqrt-pi))) + (math-to-same-complex-quad + (math-div (calcFunc-gammag '(float 5 -1) + (math-sqr (math-to-complex-quad-one x))) + math-current-gamma-value) + x))))) +) + +(defun calcFunc-erfc (x) + (if (equal x '(var inf var-inf)) + '(float 0 0) + (if (math-posp x) + (let ((math-current-gamma-value (math-sqrt-pi))) + (math-div (calcFunc-gammaG '(float 5 -1) (math-sqr x)) + math-current-gamma-value)) + (math-sub 1 (calcFunc-erf x)))) +) + +(defun math-to-complex-quad-one (x) + (if (eq (car-safe x) 'polar) (setq x (math-complex x))) + (if (eq (car-safe x) 'cplx) + (list 'cplx (math-abs (nth 1 x)) (math-abs (nth 2 x))) + x) +) + +(defun math-to-same-complex-quad (x y) + (if (eq (car-safe y) 'cplx) + (if (eq (car-safe x) 'cplx) + (list 'cplx + (if (math-negp (nth 1 y)) (math-neg (nth 1 x)) (nth 1 x)) + (if (math-negp (nth 2 y)) (math-neg (nth 2 x)) (nth 2 x))) + (if (math-negp (nth 1 y)) (math-neg x) x)) + (if (math-negp y) + (if (eq (car-safe x) 'cplx) + (list 'cplx (math-neg (nth 1 x)) (nth 2 x)) + (math-neg x)) + x)) +) + + +;;; Beta function. + +(defun calcFunc-beta (a b) + (if (math-num-integerp a) + (let ((am (math-add a -1))) + (or (math-numberp b) (math-reject-arg b 'numberp)) + (math-div 1 (math-mul b (calcFunc-choose (math-add b am) am)))) + (if (math-num-integerp b) + (calcFunc-beta b a) + (math-div (math-mul (calcFunc-gamma a) (calcFunc-gamma b)) + (calcFunc-gamma (math-add a b))))) +) + + +;;; Incomplete beta function. + +(defun calcFunc-betaI (x a b) + (cond ((math-zerop x) + '(float 0 0)) + ((math-equal-int x 1) + '(float 1 0)) + ((or (math-zerop a) + (and (math-num-integerp a) + (math-negp a))) + (if (or (math-zerop b) + (and (math-num-integerp b) + (math-negp b))) + (math-reject-arg b 'range) + '(float 1 0))) + ((or (math-zerop b) + (and (math-num-integerp b) + (math-negp b))) + '(float 0 0)) + ((not (math-numberp a)) (math-reject-arg a 'numberp)) + ((not (math-numberp b)) (math-reject-arg b 'numberp)) + ((math-inexact-result)) + (t (let ((math-current-beta-value (calcFunc-beta a b))) + (math-div (calcFunc-betaB x a b) math-current-beta-value)))) +) + +(defun calcFunc-betaB (x a b) + (cond + ((math-zerop x) + '(float 0 0)) + ((math-equal-int x 1) + (calcFunc-beta a b)) + ((not (math-numberp x)) (math-reject-arg x 'numberp)) + ((not (math-numberp a)) (math-reject-arg a 'numberp)) + ((not (math-numberp b)) (math-reject-arg b 'numberp)) + ((math-zerop a) (math-reject-arg a 'nonzerop)) + ((math-zerop b) (math-reject-arg b 'nonzerop)) + ((and (math-num-integerp b) + (if (math-negp b) + (math-reject-arg b 'range) + (Math-natnum-lessp (setq b (math-trunc b)) 20))) + (and calc-symbolic-mode (or (math-floatp a) (math-floatp b)) + (math-inexact-result)) + (math-mul + (math-with-extra-prec 2 + (let* ((i 0) + (term 1) + (sum (math-div term a))) + (while (< (setq i (1+ i)) b) + (setq term (math-mul (math-div (math-mul term (- i b)) i) x) + sum (math-add sum (math-div term (math-add a i)))) + (math-working "beta" sum)) + sum)) + (math-pow x a))) + ((and (math-num-integerp a) + (if (math-negp a) + (math-reject-arg a 'range) + (Math-natnum-lessp (setq a (math-trunc a)) 20))) + (math-sub (or math-current-beta-value (calcFunc-beta a b)) + (calcFunc-betaB (math-sub 1 x) b a))) + (t + (math-inexact-result) + (math-with-extra-prec 2 + (setq x (math-float x)) + (setq a (math-float a)) + (setq b (math-float b)) + (let ((bt (math-exp-raw (math-add (math-mul a (math-ln-raw x)) + (math-mul b (math-ln-raw + (math-sub '(float 1 0) + x))))))) + (if (Math-lessp x (math-div (math-add a '(float 1 0)) + (math-add (math-add a b) '(float 2 0)))) + (math-div (math-mul bt (math-beta-cfrac a b x)) a) + (math-sub (or math-current-beta-value (calcFunc-beta a b)) + (math-div (math-mul bt + (math-beta-cfrac b a (math-sub 1 x))) + b))))))) +) +(setq math-current-beta-value nil) + +(defun math-beta-cfrac (a b x) + (let ((qab (math-add a b)) + (qap (math-add a '(float 1 0))) + (qam (math-add a '(float -1 0)))) + (math-beta-cfrac-step '(float 1 0) + (math-sub '(float 1 0) + (math-div (math-mul qab x) qap)) + '(float 1 0) '(float 1 0) + '(float 1 0) + qab qap qam a b x)) +) + +(defun math-beta-cfrac-step (az bz am bm m qab qap qam a b x) + (let* ((two-m (math-mul m '(float 2 0))) + (d (math-div (math-mul (math-mul (math-sub b m) m) x) + (math-mul (math-add qam two-m) (math-add a two-m)))) + (ap (math-add az (math-mul d am))) + (bp (math-add bz (math-mul d bm))) + (d2 (math-neg + (math-div (math-mul (math-mul (math-add a m) (math-add qab m)) x) + (math-mul (math-add qap two-m) (math-add a two-m))))) + (app (math-add ap (math-mul d2 az))) + (bpp (math-add bp (math-mul d2 bz))) + (next (math-div app bpp))) + (math-working "beta" next) + (if (math-nearly-equal next az) + next + (math-beta-cfrac-step next '(float 1 0) + (math-div ap bpp) (math-div bp bpp) + (math-add m '(float 1 0)) + qab qap qam a b x))) +) + + +;;; Bessel functions. + +;;; Should generalize this to handle arbitrary precision! + +(defun calcFunc-besJ (v x) + (or (math-numberp v) (math-reject-arg v 'numberp)) + (or (math-numberp x) (math-reject-arg x 'numberp)) + (let ((calc-internal-prec (min 8 calc-internal-prec))) + (math-with-extra-prec 3 + (setq x (math-float (math-normalize x))) + (setq v (math-float (math-normalize v))) + (cond ((math-zerop x) + (if (math-zerop v) + '(float 1 0) + '(float 0 0))) + ((math-inexact-result)) + ((not (math-num-integerp v)) + (let ((start (math-div 1 (calcFunc-fact v)))) + (math-mul (math-besJ-series start start + 0 + (math-mul '(float -25 -2) + (math-sqr x)) + v) + (math-pow (math-div x 2) v)))) + ((math-negp (setq v (math-trunc v))) + (if (math-oddp v) + (math-neg (calcFunc-besJ (math-neg v) x)) + (calcFunc-besJ (math-neg v) x))) + ((eq v 0) + (math-besJ0 x)) + ((eq v 1) + (math-besJ1 x)) + ((Math-lessp v (math-abs-approx x)) + (let ((j 0) + (bjm (math-besJ0 x)) + (bj (math-besJ1 x)) + (two-over-x (math-div 2 x)) + bjp) + (while (< (setq j (1+ j)) v) + (setq bjp (math-sub (math-mul (math-mul j two-over-x) bj) + bjm) + bjm bj + bj bjp)) + bj)) + (t + (if (Math-lessp 100 v) (math-reject-arg v 'range)) + (let* ((j (logior (+ v (math-isqrt-small (* 40 v))) 1)) + (two-over-x (math-div 2 x)) + (jsum nil) + (bjp '(float 0 0)) + (sum '(float 0 0)) + (bj '(float 1 0)) + bjm ans) + (while (> (setq j (1- j)) 0) + (setq bjm (math-sub (math-mul (math-mul j two-over-x) bj) + bjp) + bjp bj + bj bjm) + (if (> (nth 2 (math-abs-approx bj)) 10) + (setq bj (math-mul bj '(float 1 -10)) + bjp (math-mul bjp '(float 1 -10)) + ans (and ans (math-mul ans '(float 1 -10))) + sum (math-mul sum '(float 1 -10)))) + (or (setq jsum (not jsum)) + (setq sum (math-add sum bj))) + (if (= j v) + (setq ans bjp))) + (math-div ans (math-sub (math-mul 2 sum) bj))))))) +) + +(defun math-besJ-series (sum term k zz vk) + (math-working "besJ" sum) + (setq k (1+ k) + vk (math-add 1 vk) + term (math-div (math-mul term zz) (math-mul k vk))) + (let ((next (math-add sum term))) + (if (math-nearly-equal next sum) + next + (math-besJ-series next term k zz vk))) +) + +(defun math-besJ0 (x &optional yflag) + (cond ((and (not yflag) (math-negp (calcFunc-re x))) + (math-besJ0 (math-neg x))) + ((Math-lessp '(float 8 0) (math-abs-approx x)) + (let* ((z (math-div '(float 8 0) x)) + (y (math-sqr z)) + (xx (math-add x '(float (bigneg 164 398 785) -9))) + (a1 (math-poly-eval y + '((float (bigpos 211 887 093 2) -16) + (float (bigneg 639 370 073 2) -15) + (float (bigpos 407 510 734 2) -14) + (float (bigneg 627 628 098 1) -12) + (float 1 0)))) + (a2 (math-poly-eval y + '((float (bigneg 152 935 934) -16) + (float (bigpos 161 095 621 7) -16) + (float (bigneg 651 147 911 6) -15) + (float (bigpos 765 488 430 1) -13) + (float (bigneg 995 499 562 1) -11)))) + (sc (math-sin-cos-raw xx))) + (if yflag + (setq sc (cons (math-neg (cdr sc)) (car sc)))) + (math-mul (math-sqrt + (math-div '(float (bigpos 722 619 636) -9) x)) + (math-sub (math-mul (cdr sc) a1) + (math-mul (car sc) (math-mul z a2)))))) + (t + (let ((y (math-sqr x))) + (math-div (math-poly-eval y + '((float (bigneg 456 052 849 1) -7) + (float (bigpos 017 233 739 7) -5) + (float (bigneg 418 442 121 1) -2) + (float (bigpos 407 196 516 6) -1) + (float (bigneg 354 590 362 13) 0) + (float (bigpos 574 490 568 57) 0))) + (math-poly-eval y + '((float 1 0) + (float (bigpos 712 532 678 2) -7) + (float (bigpos 853 264 927 5) -5) + (float (bigpos 718 680 494 9) -3) + (float (bigpos 985 532 029 1) 0) + (float (bigpos 411 490 568 57) 0))))))) +) + +(defun math-besJ1 (x &optional yflag) + (cond ((and (math-negp (calcFunc-re x)) (not yflag)) + (math-neg (math-besJ1 (math-neg x)))) + ((Math-lessp '(float 8 0) (math-abs-approx x)) + (let* ((z (math-div '(float 8 0) x)) + (y (math-sqr z)) + (xx (math-add x '(float (bigneg 491 194 356 2) -9))) + (a1 (math-poly-eval y + '((float (bigneg 019 337 240) -15) + (float (bigpos 174 520 457 2) -15) + (float (bigneg 496 396 516 3) -14) + (float 183105 -8) + (float 1 0)))) + (a2 (math-poly-eval y + '((float (bigpos 412 787 105) -15) + (float (bigneg 987 228 88) -14) + (float (bigpos 096 199 449 8) -15) + (float (bigneg 873 690 002 2) -13) + (float (bigpos 995 499 687 4) -11)))) + (sc (math-sin-cos-raw xx))) + (if yflag + (setq sc (cons (math-neg (cdr sc)) (car sc))) + (if (math-negp x) + (setq sc (cons (math-neg (car sc)) (math-neg (cdr sc)))))) + (math-mul (math-sqrt (math-div '(float (bigpos 722 619 636) -9) x)) + (math-sub (math-mul (cdr sc) a1) + (math-mul (car sc) (math-mul z a2)))))) + (t + (let ((y (math-sqr x))) + (math-mul + x + (math-div (math-poly-eval y + '((float (bigneg 606 036 016 3) -8) + (float (bigpos 826 044 157) -4) + (float (bigneg 439 611 972 2) -3) + (float (bigpos 531 968 423 2) -1) + (float (bigneg 235 059 895 7) 0) + (float (bigpos 232 614 362 72) 0))) + (math-poly-eval y + '((float 1 0) + (float (bigpos 397 991 769 3) -7) + (float (bigpos 394 743 944 9) -5) + (float (bigpos 474 330 858 1) -2) + (float (bigpos 178 535 300 2) 0) + (float (bigpos 442 228 725 144) + 0)))))))) +) + +(defun calcFunc-besY (v x) + (math-inexact-result) + (or (math-numberp v) (math-reject-arg v 'numberp)) + (or (math-numberp x) (math-reject-arg x 'numberp)) + (let ((calc-internal-prec (min 8 calc-internal-prec))) + (math-with-extra-prec 3 + (setq x (math-float (math-normalize x))) + (setq v (math-float (math-normalize v))) + (cond ((not (math-num-integerp v)) + (let ((sc (math-sin-cos-raw (math-mul v (math-pi))))) + (math-div (math-sub (math-mul (calcFunc-besJ v x) (cdr sc)) + (calcFunc-besJ (math-neg v) x)) + (car sc)))) + ((math-negp (setq v (math-trunc v))) + (if (math-oddp v) + (math-neg (calcFunc-besY (math-neg v) x)) + (calcFunc-besY (math-neg v) x))) + ((eq v 0) + (math-besY0 x)) + ((eq v 1) + (math-besY1 x)) + (t + (let ((j 0) + (bym (math-besY0 x)) + (by (math-besY1 x)) + (two-over-x (math-div 2 x)) + byp) + (while (< (setq j (1+ j)) v) + (setq byp (math-sub (math-mul (math-mul j two-over-x) by) + bym) + bym by + by byp)) + by))))) +) + +(defun math-besY0 (x) + (cond ((Math-lessp (math-abs-approx x) '(float 8 0)) + (let ((y (math-sqr x))) + (math-add + (math-div (math-poly-eval y + '((float (bigpos 733 622 284 2) -7) + (float (bigneg 757 792 632 8) -5) + (float (bigpos 129 988 087 1) -2) + (float (bigneg 036 598 123 5) -1) + (float (bigpos 065 834 062 7) 0) + (float (bigneg 389 821 957 2) 0))) + (math-poly-eval y + '((float 1 0) + (float (bigpos 244 030 261 2) -7) + (float (bigpos 647 472 474) -4) + (float (bigpos 438 466 189 7) -3) + (float (bigpos 648 499 452 7) -1) + (float (bigpos 269 544 076 40) 0)))) + (math-mul '(float (bigpos 772 619 636) -9) + (math-mul (math-besJ0 x) (math-ln-raw x)))))) + ((math-negp (calcFunc-re x)) + (math-add (math-besJ0 (math-neg x) t) + (math-mul '(cplx 0 2) + (math-besJ0 (math-neg x))))) + (t + (math-besJ0 x t))) +) + +(defun math-besY1 (x) + (cond ((Math-lessp (math-abs-approx x) '(float 8 0)) + (let ((y (math-sqr x))) + (math-add + (math-mul + x + (math-div (math-poly-eval y + '((float (bigpos 935 937 511 8) -6) + (float (bigneg 726 922 237 4) -3) + (float (bigpos 551 264 349 7) -1) + (float (bigneg 139 438 153 5) 1) + (float (bigpos 439 527 127) 4) + (float (bigneg 943 604 900 4) 3))) + (math-poly-eval y + '((float 1 0) + (float (bigpos 885 632 549 3) -7) + (float (bigpos 605 042 102) -3) + (float (bigpos 002 904 245 2) -2) + (float (bigpos 367 650 733 3) 0) + (float (bigpos 664 419 244 4) 2) + (float (bigpos 057 958 249) 5))))) + (math-mul '(float (bigpos 772 619 636) -9) + (math-sub (math-mul (math-besJ1 x) (math-ln-raw x)) + (math-div 1 x)))))) + ((math-negp (calcFunc-re x)) + (math-neg + (math-add (math-besJ1 (math-neg x) t) + (math-mul '(cplx 0 2) + (math-besJ1 (math-neg x)))))) + (t + (math-besJ1 x t))) +) + +(defun math-poly-eval (x coefs) + (let ((accum (car coefs))) + (while (setq coefs (cdr coefs)) + (setq accum (math-add (car coefs) (math-mul accum x)))) + accum) +) + + +;;;; Bernoulli and Euler polynomials and numbers. + +(defun calcFunc-bern (n &optional x) + (if (and x (not (math-zerop x))) + (if (and calc-symbolic-mode (math-floatp x)) + (math-inexact-result) + (math-build-polynomial-expr (math-bernoulli-coefs n) x)) + (or (math-num-natnump n) (math-reject-arg n 'natnump)) + (if (consp n) + (progn + (math-inexact-result) + (math-float (math-bernoulli-number (math-trunc n)))) + (math-bernoulli-number n))) +) + +(defun calcFunc-euler (n &optional x) + (or (math-num-natnump n) (math-reject-arg n 'natnump)) + (if x + (let* ((n1 (math-add n 1)) + (coefs (math-bernoulli-coefs n1)) + (fac (math-div (math-pow 2 n1) n1)) + (k -1) + (x1 (math-div (math-add x 1) 2)) + (x2 (math-div x 2))) + (if (math-numberp x) + (if (and calc-symbolic-mode (math-floatp x)) + (math-inexact-result) + (math-mul fac + (math-sub (math-build-polynomial-expr coefs x1) + (math-build-polynomial-expr coefs x2)))) + (calcFunc-collect + (math-reduce-vec + 'math-add + (cons 'vec + (mapcar (function + (lambda (c) + (setq k (1+ k)) + (math-mul (math-mul fac c) + (math-sub (math-pow x1 k) + (math-pow x2 k))))) + coefs))) + x))) + (math-mul (math-pow 2 n) + (if (consp n) + (progn + (math-inexact-result) + (calcFunc-euler n '(float 5 -1))) + (calcFunc-euler n '(frac 1 2))))) +) + +(defun math-bernoulli-coefs (n) + (let* ((coefs (list (calcFunc-bern n))) + (nn (math-trunc n)) + (k nn) + (term nn) + coef + (calc-prefer-frac (or (integerp n) calc-prefer-frac))) + (while (>= (setq k (1- k)) 0) + (setq term (math-div term (- nn k)) + coef (math-mul term (math-bernoulli-number k)) + coefs (cons (if (consp n) (math-float coef) coef) coefs) + term (math-mul term k))) + (nreverse coefs)) +) + +(defun math-bernoulli-number (n) + (if (= (% n 2) 1) + (if (= n 1) + '(frac -1 2) + 0) + (setq n (/ n 2)) + (while (>= n math-bernoulli-cache-size) + (let* ((sum 0) + (nk 1) ; nk = n-k+1 + (fact 1) ; fact = (n-k+1)! + ofact + (p math-bernoulli-b-cache) + (calc-prefer-frac t)) + (math-working "bernoulli B" (* 2 math-bernoulli-cache-size)) + (while p + (setq nk (+ nk 2) + ofact fact + fact (math-mul fact (* nk (1- nk))) + sum (math-add sum (math-div (car p) fact)) + p (cdr p))) + (setq ofact (math-mul ofact (1- nk)) + sum (math-sub (math-div '(frac 1 2) ofact) sum) + math-bernoulli-b-cache (cons sum math-bernoulli-b-cache) + math-bernoulli-B-cache (cons (math-mul sum ofact) + math-bernoulli-B-cache) + math-bernoulli-cache-size (1+ math-bernoulli-cache-size)))) + (nth (- math-bernoulli-cache-size n 1) math-bernoulli-B-cache)) +) + +;;; Bn = n! bn +;;; bn = - sum_k=0^n-1 bk / (n-k+1)! + +;;; A faster method would be to use "tangent numbers", c.f., Concrete +;;; Mathematics pg. 273. + +(setq math-bernoulli-b-cache '( (frac -174611 + (bigpos 0 200 291 698 662 857 802)) + (frac 43867 (bigpos 0 944 170 217 94 109 5)) + (frac -3617 (bigpos 0 880 842 622 670 10)) + (frac 1 (bigpos 600 249 724 74)) + (frac -691 (bigpos 0 368 674 307 1)) + (frac 1 (bigpos 160 900 47)) + (frac -1 (bigpos 600 209 1)) + (frac 1 30240) (frac -1 720) + (frac 1 12) 1 )) + +(setq math-bernoulli-B-cache '( (frac -174611 330) (frac 43867 798) + (frac -3617 510) (frac 7 6) (frac -691 2730) + (frac 5 66) (frac -1 30) (frac 1 42) + (frac -1 30) (frac 1 6) 1 )) + +(setq math-bernoulli-cache-size 11) + + + +;;; Probability distributions. + +;;; Binomial. +(defun calcFunc-utpb (x n p) + (if math-expand-formulas + (math-normalize (list 'calcFunc-betaI p x (list '+ (list '- n x) 1))) + (calcFunc-betaI p x (math-add (math-sub n x) 1))) +) +(put 'calcFunc-utpb 'math-expandable t) + +(defun calcFunc-ltpb (x n p) + (math-sub 1 (calcFunc-utpb x n p)) +) +(put 'calcFunc-ltpb 'math-expandable t) + +;;; Chi-square. +(defun calcFunc-utpc (chisq v) + (if math-expand-formulas + (math-normalize (list 'calcFunc-gammaQ (list '/ v 2) (list '/ chisq 2))) + (calcFunc-gammaQ (math-div v 2) (math-div chisq 2))) +) +(put 'calcFunc-utpc 'math-expandable t) + +(defun calcFunc-ltpc (chisq v) + (if math-expand-formulas + (math-normalize (list 'calcFunc-gammaP (list '/ v 2) (list '/ chisq 2))) + (calcFunc-gammaP (math-div v 2) (math-div chisq 2))) +) +(put 'calcFunc-ltpc 'math-expandable t) + +;;; F-distribution. +(defun calcFunc-utpf (f v1 v2) + (if math-expand-formulas + (math-normalize (list 'calcFunc-betaI + (list '/ v2 (list '+ v2 (list '* v1 f))) + (list '/ v2 2) + (list '/ v1 2))) + (calcFunc-betaI (math-div v2 (math-add v2 (math-mul v1 f))) + (math-div v2 2) + (math-div v1 2))) +) +(put 'calcFunc-utpf 'math-expandable t) + +(defun calcFunc-ltpf (f v1 v2) + (math-sub 1 (calcFunc-utpf f v1 v2)) +) +(put 'calcFunc-ltpf 'math-expandable t) + +;;; Normal. +(defun calcFunc-utpn (x mean sdev) + (if math-expand-formulas + (math-normalize + (list '/ + (list '+ 1 + (list 'calcFunc-erf + (list '/ (list '- mean x) + (list '* sdev (list 'calcFunc-sqrt 2))))) + 2)) + (math-mul (math-add '(float 1 0) + (calcFunc-erf + (math-div (math-sub mean x) + (math-mul sdev (math-sqrt-2))))) + '(float 5 -1))) +) +(put 'calcFunc-utpn 'math-expandable t) + +(defun calcFunc-ltpn (x mean sdev) + (if math-expand-formulas + (math-normalize + (list '/ + (list '+ 1 + (list 'calcFunc-erf + (list '/ (list '- x mean) + (list '* sdev (list 'calcFunc-sqrt 2))))) + 2)) + (math-mul (math-add '(float 1 0) + (calcFunc-erf + (math-div (math-sub x mean) + (math-mul sdev (math-sqrt-2))))) + '(float 5 -1))) +) +(put 'calcFunc-ltpn 'math-expandable t) + +;;; Poisson. +(defun calcFunc-utpp (n x) + (if math-expand-formulas + (math-normalize (list 'calcFunc-gammaP x n)) + (calcFunc-gammaP x n)) +) +(put 'calcFunc-utpp 'math-expandable t) + +(defun calcFunc-ltpp (n x) + (if math-expand-formulas + (math-normalize (list 'calcFunc-gammaQ x n)) + (calcFunc-gammaQ x n)) +) +(put 'calcFunc-ltpp 'math-expandable t) + +;;; Student's t. (As defined in Abramowitz & Stegun and Numerical Recipes.) +(defun calcFunc-utpt (tt v) + (if math-expand-formulas + (math-normalize (list 'calcFunc-betaI + (list '/ v (list '+ v (list '^ tt 2))) + (list '/ v 2) + '(float 5 -1))) + (calcFunc-betaI (math-div v (math-add v (math-sqr tt))) + (math-div v 2) + '(float 5 -1))) +) +(put 'calcFunc-utpt 'math-expandable t) + +(defun calcFunc-ltpt (tt v) + (math-sub 1 (calcFunc-utpt tt v)) +) +(put 'calcFunc-ltpt 'math-expandable t) + + + + diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el new file mode 100644 index 0000000000..955942e11b --- /dev/null +++ b/lisp/calc/calc-graph.el @@ -0,0 +1,1496 @@ +;; Calculator for GNU Emacs, part II [calc-graph.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-graph () nil) + + +;;; Graphics + +;;; Note that some of the following initial values also occur in calc.el. +(defvar calc-gnuplot-tempfile "/tmp/calc") + +(defvar calc-gnuplot-default-device "default") +(defvar calc-gnuplot-default-output "STDOUT") +(defvar calc-gnuplot-print-device "postscript") +(defvar calc-gnuplot-print-output "auto") +(defvar calc-gnuplot-keep-outfile nil) +(defvar calc-gnuplot-version nil) + +(defvar calc-gnuplot-display (getenv "DISPLAY")) +(defvar calc-gnuplot-geometry nil) + +(defvar calc-graph-default-resolution 15) +(defvar calc-graph-default-resolution-3d 5) +(defvar calc-graph-default-precision 5) + +(defvar calc-gnuplot-buffer nil) +(defvar calc-gnuplot-input nil) + +(defvar calc-gnuplot-last-error-pos 1) +(defvar calc-graph-last-device nil) +(defvar calc-graph-last-output nil) +(defvar calc-graph-file-cache nil) +(defvar calc-graph-var-cache nil) +(defvar calc-graph-data-cache nil) +(defvar calc-graph-data-cache-limit 10) + +(defun calc-graph-fast (many) + (interactive "P") + (let ((calc-graph-no-auto-view t)) + (calc-graph-delete t) + (calc-graph-add many) + (calc-graph-plot nil)) +) + +(defun calc-graph-fast-3d (many) + (interactive "P") + (let ((calc-graph-no-auto-view t)) + (calc-graph-delete t) + (calc-graph-add-3d many) + (calc-graph-plot nil)) +) + +(defun calc-graph-delete (all) + (interactive "P") + (calc-wrapper + (calc-graph-init) + (save-excursion + (set-buffer calc-gnuplot-input) + (and (calc-graph-find-plot t all) + (progn + (if (looking-at "s?plot") + (progn + (setq calc-graph-var-cache nil) + (delete-region (point) (point-max))) + (delete-region (point) (1- (point-max))))))) + (calc-graph-view-commands)) +) + +(defun calc-graph-find-plot (&optional before all) + (goto-char (point-min)) + (and (re-search-forward "^s?plot[ \t]+" nil t) + (let ((beg (point))) + (goto-char (point-max)) + (if (or all + (not (search-backward "," nil t)) + (< (point) beg)) + (progn + (goto-char beg) + (if before + (beginning-of-line))) + (or before + (re-search-forward ",[ \t]+"))) + t)) +) + +(defun calc-graph-add (many) + (interactive "P") + (calc-wrapper + (calc-graph-init) + (cond ((null many) + (calc-graph-add-curve (calc-graph-lookup (calc-top-n 2)) + (calc-graph-lookup (calc-top-n 1)))) + ((or (consp many) (eq many 0)) + (let ((xdata (calc-graph-lookup (calc-top-n 2))) + (ylist (calc-top-n 1))) + (or (eq (car-safe ylist) 'vec) + (error "Y argument must be a vector")) + (while (setq ylist (cdr ylist)) + (calc-graph-add-curve xdata (calc-graph-lookup (car ylist)))))) + ((> (setq many (prefix-numeric-value many)) 0) + (let ((xdata (calc-graph-lookup (calc-top-n (1+ many))))) + (while (> many 0) + (calc-graph-add-curve xdata + (calc-graph-lookup (calc-top-n many))) + (setq many (1- many))))) + (t + (let (pair) + (setq many (- many)) + (while (> many 0) + (setq pair (calc-top-n many)) + (or (and (eq (car-safe pair) 'vec) + (= (length pair) 3)) + (error "Argument must be an [x,y] vector")) + (calc-graph-add-curve (calc-graph-lookup (nth 1 pair)) + (calc-graph-lookup (nth 2 pair))) + (setq many (1- many)))))) + (calc-graph-view-commands)) +) + +(defun calc-graph-add-3d (many) + (interactive "P") + (calc-wrapper + (calc-graph-init) + (cond ((null many) + (calc-graph-add-curve (calc-graph-lookup (calc-top-n 3)) + (calc-graph-lookup (calc-top-n 2)) + (calc-graph-lookup (calc-top-n 1)))) + ((or (consp many) (eq many 0)) + (let ((xdata (calc-graph-lookup (calc-top-n 3))) + (ydata (calc-graph-lookup (calc-top-n 2))) + (zlist (calc-top-n 1))) + (or (eq (car-safe zlist) 'vec) + (error "Z argument must be a vector")) + (while (setq zlist (cdr zlist)) + (calc-graph-add-curve xdata ydata + (calc-graph-lookup (car zlist)))))) + ((> (setq many (prefix-numeric-value many)) 0) + (let ((xdata (calc-graph-lookup (calc-top-n (+ many 2)))) + (ydata (calc-graph-lookup (calc-top-n (+ many 1))))) + (while (> many 0) + (calc-graph-add-curve xdata ydata + (calc-graph-lookup (calc-top-n many))) + (setq many (1- many))))) + (t + (let (curve) + (setq many (- many)) + (while (> many 0) + (setq curve (calc-top-n many)) + (or (and (eq (car-safe curve) 'vec) + (= (length curve) 4)) + (error "Argument must be an [x,y,z] vector")) + (calc-graph-add-curve (calc-graph-lookup (nth 1 curve)) + (calc-graph-lookup (nth 2 curve)) + (calc-graph-lookup (nth 3 curve))) + (setq many (1- many)))))) + (calc-graph-view-commands)) +) + +(defun calc-graph-add-curve (xdata ydata &optional zdata) + (let ((num (calc-graph-count-curves)) + (pstyle (calc-var-value 'var-PointStyles)) + (lstyle (calc-var-value 'var-LineStyles))) + (save-excursion + (set-buffer calc-gnuplot-input) + (goto-char (point-min)) + (if (re-search-forward (if zdata "^plot[ \t]" "^splot[ \t]") + nil t) + (error "Can't mix 2d and 3d curves on one graph")) + (if (re-search-forward "^s?plot[ \t]" nil t) + (progn + (end-of-line) + (insert ", ")) + (goto-char (point-max)) + (or (eq (preceding-char) ?\n) + (insert "\n")) + (insert (if zdata "splot" "plot") " \n") + (forward-char -1)) + (insert "{" (symbol-name (nth 1 xdata)) + ":" (symbol-name (nth 1 ydata))) + (if zdata + (insert ":" (symbol-name (nth 1 zdata)))) + (insert "} " + "title \"" (symbol-name (nth 1 ydata)) "\" " + "with dots") + (setq pstyle (and (eq (car-safe pstyle) 'vec) (nth (1+ num) pstyle))) + (setq lstyle (and (eq (car-safe lstyle) 'vec) (nth (1+ num) lstyle))) + (calc-graph-set-styles + (or (and (Math-num-integerp lstyle) (math-trunc lstyle)) + 0) + (or (and (Math-num-integerp pstyle) (math-trunc pstyle)) + (if (eq (car-safe (calc-var-value (nth 2 ydata))) 'vec) + 0 -1))))) +) + +(defun calc-graph-lookup (thing) + (if (and (eq (car-safe thing) 'var) + (calc-var-value (nth 2 thing))) + thing + (let ((found (assoc thing calc-graph-var-cache))) + (or found + (progn + (setq varname (concat "PlotData" + (int-to-string + (1+ (length calc-graph-var-cache)))) + var (list 'var (intern varname) + (intern (concat "var-" varname))) + found (cons thing var) + calc-graph-var-cache (cons found calc-graph-var-cache)) + (set (nth 2 var) thing))) + (cdr found))) +) + +(defun calc-graph-juggle (arg) + (interactive "p") + (calc-graph-init) + (save-excursion + (set-buffer calc-gnuplot-input) + (if (< arg 0) + (let ((num (calc-graph-count-curves))) + (if (> num 0) + (while (< arg 0) + (setq arg (+ arg num)))))) + (while (>= (setq arg (1- arg)) 0) + (calc-graph-do-juggle))) +) + +(defun calc-graph-count-curves () + (save-excursion + (set-buffer calc-gnuplot-input) + (if (re-search-forward "^s?plot[ \t]" nil t) + (let ((num 1)) + (goto-char (point-min)) + (while (search-forward "," nil t) + (setq num (1+ num))) + num) + 0)) +) + +(defun calc-graph-do-juggle () + (let (base) + (and (calc-graph-find-plot t t) + (progn + (setq base (point)) + (calc-graph-find-plot t nil) + (or (eq base (point)) + (let ((str (buffer-substring (+ (point) 2) (1- (point-max))))) + (delete-region (point) (1- (point-max))) + (goto-char (+ base 5)) + (insert str ", ")))))) +) + +(defun calc-graph-print (flag) + (interactive "P") + (calc-graph-plot flag t) +) + +(defun calc-graph-plot (flag &optional printing) + (interactive "P") + (calc-slow-wrapper + (let ((calcbuf (current-buffer)) + (tempbuf (get-buffer-create "*Gnuplot Temp-2*")) + (tempbuftop 1) + (tempoutfile nil) + (curve-num 0) + (refine (and flag (> (prefix-numeric-value flag) 0))) + (recompute (and flag (< (prefix-numeric-value flag) 0))) + (surprise-splot nil) + (tty-output nil) + cache-env is-splot device output resolution precision samples-pos) + (or (boundp 'calc-graph-prev-kill-hook) + (if calc-emacs-type-19 + (progn + (setq calc-graph-prev-kill-hook nil) + (add-hook 'kill-emacs-hook 'calc-graph-kill-hook)) + (setq calc-graph-prev-kill-hook kill-emacs-hook) + (setq kill-emacs-hook 'calc-graph-kill-hook))) + (save-excursion + (calc-graph-init) + (set-buffer tempbuf) + (erase-buffer) + (set-buffer calc-gnuplot-input) + (goto-char (point-min)) + (setq is-splot (re-search-forward "^splot[ \t]" nil t)) + (let ((str (buffer-string)) + (ver calc-gnuplot-version)) + (set-buffer (get-buffer-create "*Gnuplot Temp*")) + (erase-buffer) + (insert "# (Note: This is a temporary copy---do not edit!)\n") + (if (>= ver 2) + (insert "set noarrow\nset nolabel\n" + "set autoscale xy\nset nologscale xy\n" + "set xlabel\nset ylabel\nset title\n" + "set noclip points\nset clip one\nset clip two\n" + "set format \"%g\"\nset tics\nset xtics\nset ytics\n" + "set data style linespoints\n" + "set nogrid\nset nokey\nset nopolar\n")) + (if (>= ver 3) + (insert "set surface\nset nocontour\n" + "set " (if is-splot "" "no") "parametric\n" + "set notime\nset border\nset ztics\nset zeroaxis\n" + "set view 60,30,1,1\nset offsets 0,0,0,0\n")) + (setq samples-pos (point)) + (insert "\n\n" str)) + (goto-char (point-min)) + (if is-splot + (if refine + (error "This option works only for 2d plots") + (setq recompute t))) + (let ((calc-gnuplot-input (current-buffer)) + (calc-graph-no-auto-view t)) + (if printing + (setq device calc-gnuplot-print-device + output calc-gnuplot-print-output) + (setq device (calc-graph-find-command "terminal") + output (calc-graph-find-command "output")) + (or device + (setq device calc-gnuplot-default-device)) + (if output + (setq output (car (read-from-string output))) + (setq output calc-gnuplot-default-output))) + (if (or (equal device "") (equal device "default")) + (setq device (if printing + "postscript" + (if (or (eq window-system 'x) (getenv "DISPLAY")) + "x11" + (if (>= calc-gnuplot-version 3) + "dumb" "postscript"))))) + (if (equal device "dumb") + (setq device (format "dumb %d %d" + (1- (screen-width)) (1- (screen-height))))) + (if (equal device "big") + (setq device (format "dumb %d %d" + (* 4 (- (screen-width) 3)) + (* 4 (- (screen-height) 3))))) + (if (stringp output) + (if (or (equal output "auto") + (and (equal output "tty") (setq tty-output t))) + (setq tempoutfile (calc-temp-file-name -1) + output tempoutfile)) + (setq output (eval output))) + (or (equal device calc-graph-last-device) + (progn + (setq calc-graph-last-device device) + (calc-gnuplot-command "set terminal" device))) + (or (equal output calc-graph-last-output) + (progn + (setq calc-graph-last-output output) + (calc-gnuplot-command "set output" + (if (equal output "STDOUT") + "" + (prin1-to-string output))))) + (setq resolution (calc-graph-find-command "samples")) + (if resolution + (setq resolution (string-to-int resolution)) + (setq resolution (if is-splot + calc-graph-default-resolution-3d + calc-graph-default-resolution))) + (setq precision (calc-graph-find-command "precision")) + (if precision + (setq precision (string-to-int precision)) + (setq precision calc-graph-default-precision)) + (calc-graph-set-command "terminal") + (calc-graph-set-command "output") + (calc-graph-set-command "samples") + (calc-graph-set-command "precision")) + (goto-char samples-pos) + (insert "set samples " (int-to-string (max (if is-splot 20 200) + (+ 5 resolution))) "\n") + (while (re-search-forward "{\\*[^}]+}[^,\n]*" nil t) + (delete-region (match-beginning 0) (match-end 0)) + (if (looking-at ",") + (delete-char 1) + (while (memq (preceding-char) '(?\ ?\t)) + (forward-char -1)) + (if (eq (preceding-char) ?\,) + (delete-backward-char 1)))) + (save-excursion + (set-buffer calcbuf) + (setq cache-env (list calc-angle-mode + calc-complex-mode + calc-simplify-mode + calc-infinite-mode + calc-word-size + precision is-splot)) + (if (and (not recompute) + (equal (cdr (car calc-graph-data-cache)) cache-env)) + (while (> (length calc-graph-data-cache) + calc-graph-data-cache-limit) + (setcdr calc-graph-data-cache + (cdr (cdr calc-graph-data-cache)))) + (setq calc-graph-data-cache (list (cons nil cache-env))))) + (calc-graph-find-plot t t) + (while (re-search-forward + (if is-splot + "{\\([^{}:\n]+\\):\\([^{}:\n]+\\):\\([^{}:\n]+\\)}" + "{\\([^{}:\n]+\\)\\(:\\)\\([^{}:\n]+\\)}") + nil t) + (setq curve-num (1+ curve-num)) + (let* ((xname (buffer-substring (match-beginning 1) (match-end 1))) + (xvar (intern (concat "var-" xname))) + (xvalue (math-evaluate-expr (calc-var-value xvar))) + (y3name (and is-splot + (buffer-substring (match-beginning 2) + (match-end 2)))) + (y3var (and is-splot (intern (concat "var-" y3name)))) + (y3value (and is-splot (calc-var-value y3var))) + (yname (buffer-substring (match-beginning 3) (match-end 3))) + (yvar (intern (concat "var-" yname))) + (yvalue (calc-var-value yvar)) + filename) + (delete-region (match-beginning 0) (match-end 0)) + (setq filename (calc-temp-file-name curve-num)) + (save-excursion + (set-buffer calcbuf) + (let (tempbuftop + (xp xvalue) + (yp yvalue) + (zp nil) + (xlow nil) (xhigh nil) (y3low nil) (y3high nil) + xvec xval xstep var-DUMMY + y3vec y3val y3step var-DUMMY2 (zval nil) + yvec yval ycache ycacheptr yvector + numsteps numsteps3 + (keep-file (and (not is-splot) (file-exists-p filename))) + (stepcount 0) + (calc-symbolic-mode nil) + (calc-prefer-frac nil) + (calc-internal-prec (max 3 precision)) + (calc-simplify-mode (and (not (memq calc-simplify-mode + '(none num))) + calc-simplify-mode)) + (blank t) + (non-blank nil) + (math-working-step 0) + (math-working-step-2 nil)) + (save-excursion + (if is-splot + (calc-graph-compute-3d) + (calc-graph-compute-2d)) + (set-buffer tempbuf) + (goto-char (point-max)) + (insert "\n" xname) + (if is-splot + (insert ":" y3name)) + (insert ":" yname "\n\n") + (setq tempbuftop (point)) + (let ((calc-group-digits nil) + (calc-leading-zeros nil) + (calc-number-radix 10) + (entry (and (not is-splot) + (list xp yp xhigh numsteps)))) + (or (equal entry + (nth 1 (nth (1+ curve-num) + calc-graph-file-cache))) + (setq keep-file nil)) + (setcar (cdr (nth (1+ curve-num) calc-graph-file-cache)) + entry) + (or keep-file + (calc-graph-format-data))) + (or keep-file + (progn + (or non-blank + (error "No valid data points for %s:%s" + xname yname)) + (write-region tempbuftop (point-max) filename + nil 'quiet)))))) + (insert (prin1-to-string filename)))) + (if surprise-splot + (setcdr cache-env nil)) + (if (= curve-num 0) + (progn + (calc-gnuplot-command "clear") + (calc-clear-command-flag 'clear-message) + (message "No data to plot!")) + (setq calc-graph-data-cache-limit (max curve-num + calc-graph-data-cache-limit) + filename (calc-temp-file-name 0)) + (write-region (point-min) (point-max) filename nil 'quiet) + (calc-gnuplot-command "load" (prin1-to-string filename)) + (or (equal output "STDOUT") + calc-gnuplot-keep-outfile + (progn ; need to close the output file before printing/plotting + (setq calc-graph-last-output "STDOUT") + (calc-gnuplot-command "set output"))) + (let ((command (if printing + calc-gnuplot-print-command + (or calc-gnuplot-plot-command + (and (string-match "^dumb" device) + 'calc-graph-show-dumb) + (and tty-output + 'calc-graph-show-tty))))) + (if command + (if (stringp command) + (calc-gnuplot-command + "!" (format command + (or tempoutfile + calc-gnuplot-print-output))) + (if (symbolp command) + (funcall command output) + (eval command))))))))) +) + +(defun calc-graph-compute-2d () + (if (setq yvec (eq (car-safe yvalue) 'vec)) + (if (= (setq numsteps (1- (length yvalue))) 0) + (error "Can't plot an empty vector") + (if (setq xvec (eq (car-safe xvalue) 'vec)) + (or (= (1- (length xvalue)) numsteps) + (error "%s and %s have different lengths" xname yname)) + (if (and (eq (car-safe xvalue) 'intv) + (math-constp xvalue)) + (setq xstep (math-div (math-sub (nth 3 xvalue) + (nth 2 xvalue)) + (1- numsteps)) + xvalue (nth 2 xvalue)) + (if (math-realp xvalue) + (setq xstep 1) + (error "%s is not a suitable basis for %s" xname yname))))) + (or (math-realp yvalue) + (let ((arglist nil)) + (setq yvalue (math-evaluate-expr yvalue)) + (calc-default-formula-arglist yvalue) + (or arglist + (error "%s does not contain any unassigned variables" yname)) + (and (cdr arglist) + (error "%s contains more than one variable: %s" + yname arglist)) + (setq yvalue (math-expr-subst yvalue + (math-build-var-name (car arglist)) + '(var DUMMY var-DUMMY))))) + (setq ycache (assoc yvalue calc-graph-data-cache)) + (delq ycache calc-graph-data-cache) + (nconc calc-graph-data-cache + (list (or ycache (setq ycache (list yvalue))))) + (if (and (not (setq xvec (eq (car-safe xvalue) 'vec))) + refine (cdr (cdr ycache))) + (calc-graph-refine-2d) + (calc-graph-recompute-2d))) +) + +(defun calc-graph-refine-2d () + (setq keep-file nil + ycacheptr (cdr ycache)) + (if (and (setq xval (calc-graph-find-command "xrange")) + (string-match "\\`\\[\\([0-9.eE+-]*\\):\\([0-9.eE+-]*\\)\\]\\'" + xval)) + (let ((b2 (match-beginning 2)) + (e2 (match-end 2))) + (setq xlow (math-read-number (substring xval + (match-beginning 1) + (match-end 1))) + xhigh (math-read-number (substring xval b2 e2)))) + (if xlow + (while (and (cdr ycacheptr) + (Math-lessp (car (nth 1 ycacheptr)) xlow)) + (setq ycacheptr (cdr ycacheptr))))) + (setq math-working-step-2 (1- (length ycacheptr))) + (while (and (cdr ycacheptr) + (or (not xhigh) + (Math-lessp (car (car ycacheptr)) xhigh))) + (setq var-DUMMY (math-div (math-add (car (car ycacheptr)) + (car (nth 1 ycacheptr))) + 2) + math-working-step (1+ math-working-step) + yval (math-evaluate-expr yvalue)) + (setcdr ycacheptr (cons (cons var-DUMMY yval) + (cdr ycacheptr))) + (setq ycacheptr (cdr (cdr ycacheptr)))) + (setq yp ycache + numsteps 1000000) +) + +(defun calc-graph-recompute-2d () + (setq ycacheptr ycache) + (if xvec + (setq numsteps (1- (length xvalue)) + yvector nil) + (if (and (eq (car-safe xvalue) 'intv) + (math-constp xvalue)) + (setq numsteps resolution + yp nil + xlow (nth 2 xvalue) + xhigh (nth 3 xvalue) + xstep (math-div (math-sub xhigh xlow) + (1- numsteps)) + xvalue (nth 2 xvalue)) + (error "%s is not a suitable basis for %s" + xname yname))) + (setq math-working-step-2 numsteps) + (while (>= (setq numsteps (1- numsteps)) 0) + (setq math-working-step (1+ math-working-step)) + (if xvec + (progn + (setq xp (cdr xp) + xval (car xp)) + (and (not (eq ycacheptr ycache)) + (consp (car ycacheptr)) + (not (Math-lessp (car (car ycacheptr)) xval)) + (setq ycacheptr ycache))) + (if (= numsteps 0) + (setq xval xhigh) ; avoid cumulative roundoff + (setq xval xvalue + xvalue (math-add xvalue xstep)))) + (while (and (cdr ycacheptr) + (Math-lessp (car (nth 1 ycacheptr)) xval)) + (setq ycacheptr (cdr ycacheptr))) + (or (and (cdr ycacheptr) + (Math-equal (car (nth 1 ycacheptr)) xval)) + (progn + (setq keep-file nil + var-DUMMY xval) + (setcdr ycacheptr (cons (cons xval (math-evaluate-expr yvalue)) + (cdr ycacheptr))))) + (setq ycacheptr (cdr ycacheptr)) + (if xvec + (setq yvector (cons (cdr (car ycacheptr)) yvector)) + (or yp (setq yp ycacheptr)))) + (if xvec + (setq xp xvalue + yvec t + yp (cons 'vec (nreverse yvector)) + numsteps (1- (length xp))) + (setq numsteps 1000000)) +) + +(defun calc-graph-compute-3d () + (if (setq yvec (eq (car-safe yvalue) 'vec)) + (if (math-matrixp yvalue) + (progn + (setq numsteps (1- (length yvalue)) + numsteps3 (1- (length (nth 1 yvalue)))) + (if (eq (car-safe xvalue) 'vec) + (or (= (1- (length xvalue)) numsteps) + (error "%s has wrong length" xname)) + (if (and (eq (car-safe xvalue) 'intv) + (math-constp xvalue)) + (setq xvalue (calcFunc-index numsteps + (nth 2 xvalue) + (math-div + (math-sub (nth 3 xvalue) + (nth 2 xvalue)) + (1- numsteps)))) + (if (math-realp xvalue) + (setq xvalue (calcFunc-index numsteps xvalue 1)) + (error "%s is not a suitable basis for %s" xname yname)))) + (if (eq (car-safe y3value) 'vec) + (or (= (1- (length y3value)) numsteps3) + (error "%s has wrong length" y3name)) + (if (and (eq (car-safe y3value) 'intv) + (math-constp y3value)) + (setq y3value (calcFunc-index numsteps3 + (nth 2 y3value) + (math-div + (math-sub (nth 3 y3value) + (nth 2 y3value)) + (1- numsteps3)))) + (if (math-realp y3value) + (setq y3value (calcFunc-index numsteps3 y3value 1)) + (error "%s is not a suitable basis for %s" y3name yname)))) + (setq xp nil + yp nil + zp nil + xvec t) + (while (setq xvalue (cdr xvalue) yvalue (cdr yvalue)) + (setq xp (nconc xp (make-list (1+ numsteps3) (car xvalue))) + yp (nconc yp (cons 0 (copy-sequence (cdr y3value)))) + zp (nconc zp (cons '(skip) + (copy-sequence (cdr (car yvalue))))))) + (setq numsteps (1- (* numsteps (1+ numsteps3))))) + (if (= (setq numsteps (1- (length yvalue))) 0) + (error "Can't plot an empty vector")) + (or (and (eq (car-safe xvalue) 'vec) + (= (1- (length xvalue)) numsteps)) + (error "%s is not a suitable basis for %s" xname yname)) + (or (and (eq (car-safe y3value) 'vec) + (= (1- (length y3value)) numsteps)) + (error "%s is not a suitable basis for %s" y3name yname)) + (setq xp xvalue + yp y3value + zp yvalue + xvec t)) + (or (math-realp yvalue) + (let ((arglist nil)) + (setq yvalue (math-evaluate-expr yvalue)) + (calc-default-formula-arglist yvalue) + (setq arglist (sort arglist 'string-lessp)) + (or (cdr arglist) + (error "%s does not contain enough unassigned variables" yname)) + (and (cdr (cdr arglist)) + (error "%s contains too many variables: %s" yname arglist)) + (setq yvalue (math-multi-subst yvalue + (mapcar 'math-build-var-name + arglist) + '((var DUMMY var-DUMMY) + (var DUMMY2 var-DUMMY2)))))) + (if (setq xvec (eq (car-safe xvalue) 'vec)) + (setq numsteps (1- (length xvalue))) + (if (and (eq (car-safe xvalue) 'intv) + (math-constp xvalue)) + (setq numsteps resolution + xvalue (calcFunc-index numsteps + (nth 2 xvalue) + (math-div (math-sub (nth 3 xvalue) + (nth 2 xvalue)) + (1- numsteps)))) + (error "%s is not a suitable basis for %s" + xname yname))) + (if (setq y3vec (eq (car-safe y3value) 'vec)) + (setq numsteps3 (1- (length y3value))) + (if (and (eq (car-safe y3value) 'intv) + (math-constp y3value)) + (setq numsteps3 resolution + y3value (calcFunc-index numsteps3 + (nth 2 y3value) + (math-div (math-sub (nth 3 y3value) + (nth 2 y3value)) + (1- numsteps3)))) + (error "%s is not a suitable basis for %s" + y3name yname))) + (setq xp nil + yp nil + zp nil + xvec t) + (setq math-working-step 0) + (while (setq xvalue (cdr xvalue)) + (setq xp (nconc xp (make-list (1+ numsteps3) (car xvalue))) + yp (nconc yp (cons 0 (copy-sequence (cdr y3value)))) + zp (cons '(skip) zp) + y3step y3value + var-DUMMY (car xvalue) + math-working-step-2 0 + math-working-step (1+ math-working-step)) + (while (setq y3step (cdr y3step)) + (setq math-working-step-2 (1+ math-working-step-2) + var-DUMMY2 (car y3step) + zp (cons (math-evaluate-expr yvalue) zp)))) + (setq zp (nreverse zp) + numsteps (1- (* numsteps (1+ numsteps3))))) +) + +(defun calc-graph-format-data () + (while (<= (setq stepcount (1+ stepcount)) numsteps) + (if xvec + (setq xp (cdr xp) + xval (car xp) + yp (cdr yp) + yval (car yp) + zp (cdr zp) + zval (car zp)) + (if yvec + (setq xval xvalue + xvalue (math-add xvalue xstep) + yp (cdr yp) + yval (car yp)) + (setq xval (car (car yp)) + yval (cdr (car yp)) + yp (cdr yp)) + (if (or (not yp) + (and xhigh (equal xval xhigh))) + (setq numsteps 0)))) + (if is-splot + (if (and (eq (car-safe zval) 'calcFunc-xyz) + (= (length zval) 4)) + (setq xval (nth 1 zval) + yval (nth 2 zval) + zval (nth 3 zval))) + (if (and (eq (car-safe yval) 'calcFunc-xyz) + (= (length yval) 4)) + (progn + (or surprise-splot + (save-excursion + (set-buffer (get-buffer-create "*Gnuplot Temp*")) + (save-excursion + (goto-char (point-max)) + (re-search-backward "^plot[ \t]") + (insert "set parametric\ns") + (setq surprise-splot t)))) + (setq xval (nth 1 yval) + zval (nth 3 yval) + yval (nth 2 yval))) + (if (and (eq (car-safe yval) 'calcFunc-xy) + (= (length yval) 3)) + (setq xval (nth 1 yval) + yval (nth 2 yval))))) + (if (and (Math-realp xval) + (Math-realp yval) + (or (not zval) (Math-realp zval))) + (progn + (setq blank nil + non-blank t) + (if (Math-integerp xval) + (insert (math-format-number xval)) + (if (eq (car xval) 'frac) + (setq xval (math-float xval))) + (insert (math-format-number (nth 1 xval)) + "e" (int-to-string (nth 2 xval)))) + (insert " ") + (if (Math-integerp yval) + (insert (math-format-number yval)) + (if (eq (car yval) 'frac) + (setq yval (math-float yval))) + (insert (math-format-number (nth 1 yval)) + "e" (int-to-string (nth 2 yval)))) + (if zval + (progn + (insert " ") + (if (Math-integerp zval) + (insert (math-format-number zval)) + (if (eq (car zval) 'frac) + (setq zval (math-float zval))) + (insert (math-format-number (nth 1 zval)) + "e" (int-to-string (nth 2 zval)))))) + (insert "\n")) + (and (not (equal zval '(skip))) + (boundp 'var-PlotRejects) + (eq (car-safe var-PlotRejects) 'vec) + (nconc var-PlotRejects + (list (list 'vec + curve-num + stepcount + xval yval))) + (calc-refresh-evaltos 'var-PlotRejects)) + (or blank + (progn + (insert "\n") + (setq blank t))))) +) + +(defun calc-temp-file-name (num) + (while (<= (length calc-graph-file-cache) (1+ num)) + (setq calc-graph-file-cache (nconc calc-graph-file-cache (list nil)))) + (car (or (nth (1+ num) calc-graph-file-cache) + (setcar (nthcdr (1+ num) calc-graph-file-cache) + (list (make-temp-name + (concat calc-gnuplot-tempfile + (if (<= num 0) + (char-to-string (- ?A num)) + (int-to-string num)))) + nil)))) +) + +(defun calc-graph-delete-temps () + (while calc-graph-file-cache + (and (car calc-graph-file-cache) + (file-exists-p (car (car calc-graph-file-cache))) + (condition-case err + (delete-file (car (car calc-graph-file-cache))) + (error nil))) + (setq calc-graph-file-cache (cdr calc-graph-file-cache))) +) + +(defun calc-graph-kill-hook () + (calc-graph-delete-temps) + (if calc-graph-prev-kill-hook + (funcall calc-graph-prev-kill-hook)) +) + +(defun calc-graph-show-tty (output) + "Default calc-gnuplot-plot-command for \"tty\" output mode. +This is useful for tek40xx and other graphics-terminal types." + (call-process-region 1 1 shell-file-name + nil calc-gnuplot-buffer nil + "-c" (format "cat %s >/dev/tty; rm %s" output output)) +) + +(defun calc-graph-show-dumb (&optional output) + "Default calc-gnuplot-plot-command for Pinard's \"dumb\" terminal type. +This \"dumb\" driver will be present in Gnuplot 3.0." + (interactive) + (save-window-excursion + (switch-to-buffer calc-gnuplot-buffer) + (delete-other-windows) + (goto-char calc-gnuplot-trail-mark) + (or (search-forward "\f" nil t) + (sleep-for 1)) + (goto-char (point-max)) + (re-search-backward "\f\\|^[ \t]+\\^$\\|G N U P L O T") + (setq found-pt (point)) + (if (looking-at "\f") + (progn + (forward-char 1) + (if (eolp) (forward-line 1)) + (or (calc-graph-find-command "time") + (calc-graph-find-command "title") + (calc-graph-find-command "ylabel") + (let ((pt (point))) + (insert-before-markers (format "(%s)" (current-time-string))) + (goto-char pt))) + (set-window-start (selected-window) (point)) + (goto-char (point-max))) + (end-of-line) + (backward-char 1) + (recenter '(4))) + (or (boundp 'calc-dumb-map) + (progn + (setq calc-dumb-map (make-sparse-keymap)) + (define-key calc-dumb-map "\n" 'scroll-up) + (define-key calc-dumb-map " " 'scroll-up) + (define-key calc-dumb-map "\177" 'scroll-down) + (define-key calc-dumb-map "<" 'scroll-left) + (define-key calc-dumb-map ">" 'scroll-right) + (define-key calc-dumb-map "{" 'scroll-down) + (define-key calc-dumb-map "}" 'scroll-up) + (define-key calc-dumb-map "q" 'exit-recursive-edit) + (define-key calc-dumb-map "\C-c\C-c" 'exit-recursive-edit))) + (use-local-map calc-dumb-map) + (setq truncate-lines t) + (message "Type `q'%s to return to Calc." + (if (eq (lookup-key (current-global-map) "\e#") 'calc-dispatch) + " or `M-# M-#'" "")) + (recursive-edit) + (bury-buffer "*Gnuplot Trail*")) +) + +(defun calc-graph-clear () + (interactive) + (if calc-graph-last-device + (if (or (equal calc-graph-last-device "x11") + (equal calc-graph-last-device "X11")) + (calc-gnuplot-command "set output" + (if (equal calc-graph-last-output "STDOUT") + "" + (prin1-to-string calc-graph-last-output))) + (calc-gnuplot-command "clear"))) +) + +(defun calc-graph-title-x (title) + (interactive "sX axis title: ") + (calc-graph-set-command "xlabel" (if (not (equal title "")) + (prin1-to-string title))) +) + +(defun calc-graph-title-y (title) + (interactive "sY axis title: ") + (calc-graph-set-command "ylabel" (if (not (equal title "")) + (prin1-to-string title))) +) + +(defun calc-graph-title-z (title) + (interactive "sZ axis title: ") + (calc-graph-set-command "zlabel" (if (not (equal title "")) + (prin1-to-string title))) +) + +(defun calc-graph-range-x (range) + (interactive "sX axis range: ") + (calc-graph-set-range "xrange" range) +) + +(defun calc-graph-range-y (range) + (interactive "sY axis range: ") + (calc-graph-set-range "yrange" range) +) + +(defun calc-graph-range-z (range) + (interactive "sZ axis range: ") + (calc-graph-set-range "zrange" range) +) + +(defun calc-graph-set-range (cmd range) + (if (equal range "$") + (calc-wrapper + (let ((val (calc-top-n 1))) + (if (and (eq (car-safe val) 'intv) (math-constp val)) + (setq range (concat + (math-format-number (math-float (nth 2 val))) ":" + (math-format-number (math-float (nth 3 val))))) + (if (and (eq (car-safe val) 'vec) + (= (length val) 3)) + (setq range (concat + (math-format-number (math-float (nth 1 val))) ":" + (math-format-number (math-float (nth 2 val))))) + (error "Range specification must be an interval or 2-vector"))) + (calc-pop-stack 1)))) + (if (string-match "\\[.+\\]" range) + (setq range (substring range 1 -1))) + (if (and (not (string-match ":" range)) + (or (string-match "," range) + (string-match " " range))) + (aset range (match-beginning 0) ?\:)) + (calc-graph-set-command cmd (if (not (equal range "")) + (concat "[" range "]"))) +) + +(defun calc-graph-log-x (flag) + (interactive "P") + (calc-graph-set-log flag 0 0) +) + +(defun calc-graph-log-y (flag) + (interactive "P") + (calc-graph-set-log 0 flag 0) +) + +(defun calc-graph-log-z (flag) + (interactive "P") + (calc-graph-set-log 0 0 flag) +) + +(defun calc-graph-set-log (xflag yflag zflag) + (let* ((old (or (calc-graph-find-command "logscale") "")) + (xold (string-match "x" old)) + (yold (string-match "y" old)) + (zold (string-match "z" old)) + str) + (setq str (concat (if (if xflag + (if (eq xflag 0) xold + (> (prefix-numeric-value xflag) 0)) + (not xold)) "x" "") + (if (if yflag + (if (eq yflag 0) yold + (> (prefix-numeric-value yflag) 0)) + (not yold)) "y" "") + (if (if zflag + (if (eq zflag 0) zold + (> (prefix-numeric-value zflag) 0)) + (not zold)) "z" ""))) + (calc-graph-set-command "logscale" (if (not (equal str "")) str))) +) + +(defun calc-graph-line-style (style) + (interactive "P") + (calc-graph-set-styles (and style (prefix-numeric-value style)) t) +) + +(defun calc-graph-point-style (style) + (interactive "P") + (calc-graph-set-styles t (and style (prefix-numeric-value style))) +) + +(defun calc-graph-set-styles (lines points) + (calc-graph-init) + (save-excursion + (set-buffer calc-gnuplot-input) + (or (calc-graph-find-plot nil nil) + (error "No data points have been set!")) + (let ((base (point)) + (mode nil) (lstyle nil) (pstyle nil) + start end lenbl penbl) + (re-search-forward "[,\n]") + (forward-char -1) + (setq end (point) start end) + (goto-char base) + (if (looking-at "[^,\n]*[^,\n \t]\\([ \t]+with\\)") + (progn + (setq start (match-beginning 1)) + (goto-char (match-end 0)) + (if (looking-at "[ \t]+\\([a-z]+\\)") + (setq mode (buffer-substring (match-beginning 1) + (match-end 1)))) + (if (looking-at "[ \ta-z]+\\([0-9]+\\)") + (setq lstyle (string-to-int + (buffer-substring (match-beginning 1) + (match-end 1))))) + (if (looking-at "[ \ta-z]+[0-9]+[ \t]+\\([0-9]+\\)") + (setq pstyle (string-to-int + (buffer-substring (match-beginning 1) + (match-end 1))))))) + (setq lenbl (or (equal mode "lines") (equal mode "linespoints")) + penbl (or (equal mode "points") (equal mode "linespoints"))) + (if lines + (or (eq lines t) + (setq lstyle lines + lenbl (>= lines 0))) + (setq lenbl (not lenbl))) + (if points + (or (eq points t) + (setq pstyle points + penbl (>= points 0))) + (setq penbl (not penbl))) + (delete-region start end) + (goto-char start) + (insert " with " + (if lenbl + (if penbl "linespoints" "lines") + (if penbl "points" "dots"))) + (if (and pstyle (> pstyle 0)) + (insert " " (if (and lstyle (> lstyle 0)) (int-to-string lstyle) "1") + " " (int-to-string pstyle)) + (if (and lstyle (> lstyle 0)) + (insert " " (int-to-string lstyle)))))) + (calc-graph-view-commands) +) + +(defun calc-graph-zero-x (flag) + (interactive "P") + (calc-graph-set-command "noxzeroaxis" + (and (if flag + (<= (prefix-numeric-value flag) 0) + (not (calc-graph-find-command "noxzeroaxis"))) + " ")) +) + +(defun calc-graph-zero-y (flag) + (interactive "P") + (calc-graph-set-command "noyzeroaxis" + (and (if flag + (<= (prefix-numeric-value flag) 0) + (not (calc-graph-find-command "noyzeroaxis"))) + " ")) +) + +(defun calc-graph-name (name) + (interactive "sTitle for current curve: ") + (calc-graph-init) + (save-excursion + (set-buffer calc-gnuplot-input) + (or (calc-graph-find-plot nil nil) + (error "No data points have been set!")) + (let ((base (point)) + start) + (re-search-forward "[,\n]\\|[ \t]+with") + (setq end (match-beginning 0)) + (goto-char base) + (if (looking-at "[^,\n]*[^,\n \t]\\([ \t]+title\\)") + (progn + (goto-char (match-beginning 1)) + (delete-region (point) end)) + (goto-char end)) + (insert " title " (prin1-to-string name)))) + (calc-graph-view-commands) +) + +(defun calc-graph-hide (flag) + (interactive "P") + (calc-graph-init) + (and (calc-graph-find-plot nil nil) + (progn + (or (looking-at "{") + (error "Can't hide this curve (wrong format)")) + (forward-char 1) + (if (looking-at "*") + (if (or (null flag) (<= (prefix-numeric-value flag) 0)) + (delete-char 1)) + (if (or (null flag) (> (prefix-numeric-value flag) 0)) + (insert "*"))))) +) + +(defun calc-graph-header (title) + (interactive "sTitle for entire graph: ") + (calc-graph-set-command "title" (if (not (equal title "")) + (prin1-to-string title))) +) + +(defun calc-graph-border (flag) + (interactive "P") + (calc-graph-set-command "noborder" + (and (if flag + (<= (prefix-numeric-value flag) 0) + (not (calc-graph-find-command "noborder"))) + " ")) +) + +(defun calc-graph-grid (flag) + (interactive "P") + (calc-graph-set-command "grid" (and (if flag + (> (prefix-numeric-value flag) 0) + (not (calc-graph-find-command "grid"))) + " ")) +) + +(defun calc-graph-key (flag) + (interactive "P") + (calc-graph-set-command "key" (and (if flag + (> (prefix-numeric-value flag) 0) + (not (calc-graph-find-command "key"))) + " ")) +) + +(defun calc-graph-num-points (res flag) + (interactive "sNumber of data points: \nP") + (if flag + (if (> (prefix-numeric-value flag) 0) + (if (equal res "") + (message "Default resolution is %d." + calc-graph-default-resolution) + (setq calc-graph-default-resolution (string-to-int res))) + (if (equal res "") + (message "Default 3D resolution is %d." + calc-graph-default-resolution-3d) + (setq calc-graph-default-resolution-3d (string-to-int res)))) + (calc-graph-set-command "samples" (if (not (equal res "")) res))) +) + +(defun calc-graph-device (name flag) + (interactive "sDevice name: \nP") + (if (equal name "?") + (progn + (calc-gnuplot-command "set terminal") + (calc-graph-view-trail)) + (if flag + (if (> (prefix-numeric-value flag) 0) + (if (equal name "") + (message "Default GNUPLOT device is \"%s\"." + calc-gnuplot-default-device) + (setq calc-gnuplot-default-device name)) + (if (equal name "") + (message "GNUPLOT device for Print command is \"%s\"." + calc-gnuplot-print-device) + (setq calc-gnuplot-print-device name))) + (calc-graph-set-command "terminal" (if (not (equal name "")) + name)))) +) + +(defun calc-graph-output (name flag) + (interactive "FOutput file name: \np") + (cond ((string-match "\\<[aA][uU][tT][oO]$" name) + (setq name "auto")) + ((string-match "\\<[tT][tT][yY]$" name) + (setq name "tty")) + ((string-match "\\<[sS][tT][dD][oO][uU][tT]$" name) + (setq name "STDOUT")) + ((equal (file-name-nondirectory name) "") + (setq name "")) + (t (setq name (expand-file-name name)))) + (if flag + (if (> (prefix-numeric-value flag) 0) + (if (equal name "") + (message "Default GNUPLOT output file is \"%s\"." + calc-gnuplot-default-output) + (setq calc-gnuplot-default-output name)) + (if (equal name "") + (message "GNUPLOT output file for Print command is \"%s\"." + calc-gnuplot-print-output) + (setq calc-gnuplot-print-output name))) + (calc-graph-set-command "output" (if (not (equal name "")) + (prin1-to-string name)))) +) + +(defun calc-graph-display (name) + (interactive "sX display name: ") + (if (equal name "") + (message "Current X display is \"%s\"." + (or calc-gnuplot-display "<none>")) + (setq calc-gnuplot-display name) + (if (calc-gnuplot-alive) + (calc-gnuplot-command "exit"))) +) + +(defun calc-graph-geometry (name) + (interactive "sX geometry spec (or \"default\"): ") + (if (equal name "") + (message "Current X geometry is \"%s\"." + (or calc-gnuplot-geometry "default")) + (setq calc-gnuplot-geometry (and (not (equal name "default")) name)) + (if (calc-gnuplot-alive) + (calc-gnuplot-command "exit"))) +) + +(defun calc-graph-find-command (cmd) + (calc-graph-init) + (save-excursion + (set-buffer calc-gnuplot-input) + (goto-char (point-min)) + (if (re-search-forward (concat "^set[ \t]+" cmd "[ \t]*\\(.*\\)$") nil t) + (buffer-substring (match-beginning 1) (match-end 1)))) +) + +(defun calc-graph-set-command (cmd &rest args) + (calc-graph-init) + (save-excursion + (set-buffer calc-gnuplot-input) + (goto-char (point-min)) + (if (re-search-forward (concat "^set[ \t]+" cmd "[ \t\n]") nil t) + (progn + (forward-char -1) + (end-of-line) + (let ((end (point))) + (beginning-of-line) + (delete-region (point) (1+ end)))) + (if (calc-graph-find-plot t t) + (if (eq (preceding-char) ?\n) + (forward-char -1)) + (goto-char (1- (point-max))))) + (if (and args (car args)) + (progn + (or (bolp) + (insert "\n")) + (insert "set " (mapconcat 'identity (cons cmd args) " ") "\n")))) + (calc-graph-view-commands) +) + +(defun calc-graph-command (cmd) + (interactive "sGNUPLOT command: ") + (calc-wrapper + (calc-graph-init) + (calc-graph-view-trail) + (calc-gnuplot-command cmd) + (accept-process-output) + (calc-graph-view-trail)) +) + +(defun calc-graph-kill (&optional no-view) + (interactive) + (calc-graph-delete-temps) + (if (calc-gnuplot-alive) + (calc-wrapper + (or no-view (calc-graph-view-trail)) + (let ((calc-graph-no-wait t)) + (calc-gnuplot-command "exit")) + (sit-for 1) + (if (process-status calc-gnuplot-process) + (delete-process calc-gnuplot-process)) + (setq calc-gnuplot-process nil))) +) + +(defun calc-graph-quit () + (interactive) + (if (get-buffer-window calc-gnuplot-input) + (calc-graph-view-commands t)) + (if (get-buffer-window calc-gnuplot-buffer) + (calc-graph-view-trail t)) + (calc-graph-kill t) +) + +(defun calc-graph-view-commands (&optional no-need) + (interactive "p") + (or calc-graph-no-auto-view (calc-graph-init-buffers)) + (calc-graph-view calc-gnuplot-input calc-gnuplot-buffer (null no-need)) +) + +(defun calc-graph-view-trail (&optional no-need) + (interactive "p") + (or calc-graph-no-auto-view (calc-graph-init-buffers)) + (calc-graph-view calc-gnuplot-buffer calc-gnuplot-input (null no-need)) +) + +(defun calc-graph-view (buf other-buf need) + (let (win) + (or calc-graph-no-auto-view + (if (setq win (get-buffer-window buf)) + (or need + (and (eq buf calc-gnuplot-buffer) + (save-excursion + (set-buffer buf) + (not (pos-visible-in-window-p (point-max) win)))) + (progn + (bury-buffer buf) + (bury-buffer other-buf) + (let ((curwin (selected-window))) + (select-window win) + (switch-to-buffer nil) + (select-window curwin)))) + (if (setq win (get-buffer-window other-buf)) + (set-window-buffer win buf) + (if (eq major-mode 'calc-mode) + (if (or need + (< (window-height) (1- (screen-height)))) + (display-buffer buf)) + (switch-to-buffer buf))))) + (save-excursion + (set-buffer buf) + (if (and (eq buf calc-gnuplot-buffer) + (setq win (get-buffer-window buf)) + (not (pos-visible-in-window-p (point-max) win))) + (progn + (goto-char (point-max)) + (vertical-motion (- 6 (window-height win))) + (set-window-start win (point)) + (goto-char (point-max))))) + (or calc-graph-no-auto-view (sit-for 0))) +) +(setq calc-graph-no-auto-view nil) + +(defun calc-gnuplot-check-for-errors () + (if (save-excursion + (prog2 + (progn + (set-buffer calc-gnuplot-buffer) + (goto-char calc-gnuplot-last-error-pos)) + (re-search-forward "^[ \t]+\\^$" nil t) + (goto-char (point-max)) + (setq calc-gnuplot-last-error-pos (point-max)))) + (calc-graph-view-trail)) +) + +(defun calc-gnuplot-command (&rest args) + (calc-graph-init) + (let ((cmd (concat (mapconcat 'identity args " ") "\n"))) + (accept-process-output) + (save-excursion + (set-buffer calc-gnuplot-buffer) + (calc-gnuplot-check-for-errors) + (goto-char (point-max)) + (setq calc-gnuplot-trail-mark (point)) + (or (>= calc-gnuplot-version 3) + (insert cmd)) + (set-marker (process-mark calc-gnuplot-process) (point)) + (process-send-string calc-gnuplot-process cmd) + (if (get-buffer-window calc-gnuplot-buffer) + (calc-graph-view-trail)) + (accept-process-output (and (not calc-graph-no-wait) + calc-gnuplot-process)) + (calc-gnuplot-check-for-errors) + (if (get-buffer-window calc-gnuplot-buffer) + (calc-graph-view-trail)))) +) +(setq calc-graph-no-wait nil) + +(defun calc-graph-init-buffers () + (or (and calc-gnuplot-buffer + (buffer-name calc-gnuplot-buffer)) + (setq calc-gnuplot-buffer (get-buffer-create "*Gnuplot Trail*"))) + (or (and calc-gnuplot-input + (buffer-name calc-gnuplot-input)) + (setq calc-gnuplot-input (get-buffer-create "*Gnuplot Commands*"))) +) + +(defun calc-graph-init () + (or (calc-gnuplot-alive) + (let ((process-connection-type t) + origin) + (if calc-gnuplot-process + (progn + (delete-process calc-gnuplot-process) + (setq calc-gnuplot-process nil))) + (calc-graph-init-buffers) + (save-excursion + (set-buffer calc-gnuplot-buffer) + (insert "\nStarting gnuplot...\n") + (setq origin (point))) + (setq calc-graph-last-device nil) + (setq calc-graph-last-output nil) + (condition-case err + (let ((args (append (and calc-gnuplot-display + (not (equal calc-gnuplot-display + (getenv "DISPLAY"))) + (list "-display" + calc-gnuplot-display)) + (and calc-gnuplot-geometry + (list "-geometry" + calc-gnuplot-geometry))))) + (setq calc-gnuplot-process + (apply 'start-process + "gnuplot" + calc-gnuplot-buffer + calc-gnuplot-name + args)) + (process-kill-without-query calc-gnuplot-process)) + (file-error + (error "Sorry, can't find \"%s\" on your system." + calc-gnuplot-name))) + (save-excursion + (set-buffer calc-gnuplot-buffer) + (while (and (not (save-excursion + (goto-char origin) + (search-forward "gnuplot> " nil t))) + (memq (process-status calc-gnuplot-process) '(run stop))) + (accept-process-output calc-gnuplot-process)) + (or (memq (process-status calc-gnuplot-process) '(run stop)) + (error "Unable to start GNUPLOT process.")) + (if (save-excursion + (goto-char origin) + (re-search-forward + "G N U P L O T.*\n.*version \\([0-9]+\\)\\." nil t)) + (setq calc-gnuplot-version (string-to-int (buffer-substring + (match-beginning 1) + (match-end 1)))) + (setq calc-gnuplot-version 1)) + (goto-char (point-max))))) + (save-excursion + (set-buffer calc-gnuplot-input) + (if (= (buffer-size) 0) + (insert "# Commands for running gnuplot\n\n\n") + (or calc-graph-no-auto-view + (eq (char-after (1- (point-max))) ?\n) + (progn + (goto-char (point-max)) + (insert "\n"))))) +) + diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el new file mode 100644 index 0000000000..ad3fbe4e90 --- /dev/null +++ b/lisp/calc/calc-help.el @@ -0,0 +1,686 @@ +;; Calculator for GNU Emacs, part II [calc-help.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-help () nil) + + +(defun calc-help-prefix (arg) + "This key is the prefix for Calc help functions. See calc-help-for-help." + (interactive "P") + (or calc-dispatch-help (sit-for echo-keystrokes)) + (let ((key (calc-read-key-sequence + (if calc-dispatch-help + "Calc Help options: Help, Info, Tutorial, Summary; Key, Function; ?=more" + (format "%s (Type ? for a list of Calc Help options)" + (key-description (this-command-keys)))) + calc-help-map))) + (setq key (lookup-key calc-help-map key)) + (message "") + (if key + (call-interactively key) + (beep))) +) + +(defun calc-help-for-help (arg) + "You have typed `h', the Calc help character. Type a Help option: + +B calc-describe-bindings. Display a table of all key bindings. +H calc-full-help. Display all `?' key messages at once. + +I calc-info. Read the Calc manual using the Info system. +T calc-tutorial. Read the Calc tutorial using the Info system. +S calc-info-summary. Read the Calc summary using the Info system. + +C calc-describe-key-briefly. Look up the command name for a given key. +K calc-describe-key. Look up a key's documentation in the manual. +F calc-describe-function. Look up a function's documentation in the manual. +V calc-describe-variable. Look up a variable's documentation in the manual. + +N calc-view-news. Display Calc history of changes. + +C-c Describe conditions for copying Calc. +C-d Describe how you can get a new copy of Calc or report a bug. +C-w Describe how there is no warranty for Calc." + (interactive "P") + (if calc-dispatch-help + (let (key) + (save-window-excursion + (describe-function 'calc-help-for-help) + (select-window (get-buffer-window "*Help*")) + (while (progn + (message "Calc Help options: Help, Info, ... press SPC, DEL to scroll, C-g to cancel") + (memq (car (setq key (calc-read-key t))) + '(? ?\C-h ?\C-? ?\C-v ?\M-v))) + (condition-case err + (if (memq (car key) '(? ?\C-v)) + (scroll-up) + (scroll-down)) + (error (beep))))) + (calc-unread-command (cdr key)) + (calc-help-prefix nil)) + (let ((calc-dispatch-help t)) + (calc-help-prefix arg))) +) + +(defun calc-describe-copying () + (interactive) + (calc-info) + (Info-goto-node "Copying") +) + +(defun calc-describe-distribution () + (interactive) + (calc-info) + (Info-goto-node "Reporting Bugs") +) + +(defun calc-describe-no-warranty () + (interactive) + (calc-info) + (Info-goto-node "Copying") + (let ((case-fold-search nil)) + (search-forward " NO WARRANTY")) + (beginning-of-line) + (recenter 0) +) + +(defun calc-describe-bindings () + (interactive) + (describe-bindings) + (save-excursion + (set-buffer "*Help*") + (goto-char (point-min)) + (if (search-forward "Global bindings:" nil t) + (delete-region (match-beginning 0) (point-max))) + (goto-char (point-min)) + (while (re-search-forward "\n[a-z] ESC" nil t) + (end-of-line) + (delete-region (match-beginning 0) (point))) + (goto-char (point-min)) + (while (re-search-forward "\nESC m" nil t) + (end-of-line) + (delete-region (match-beginning 0) (point))) + (goto-char (point-min)) + (while (search-forward "\n\n\n" nil t) + (backward-delete-char 1) + (backward-char 2)) + (goto-char (point-min)) + (while + (re-search-forward + "\n[a-z] [0-9]\\(\t\t.*\n\\)\\([a-z] [0-9]\\1\\)*[a-z] \\([0-9]\\)\\1" + nil t) + (let ((dig1 (char-after (1- (match-beginning 1)))) + (dig2 (char-after (match-beginning 3)))) + (delete-region (match-end 1) (match-end 0)) + (goto-char (match-beginning 1)) + (delete-backward-char 1) + (delete-char 1) + (insert (format "%c .. %c" (min dig1 dig2) (max dig1 dig2))))) + (goto-char (point-min))) +) + +(defun calc-describe-key-briefly (key) + (interactive "kDescribe key briefly: ") + (calc-describe-key key t) +) + +(defun calc-describe-key (key &optional briefly) + (interactive "kDescribe key: ") + (let ((defn (if (eq (key-binding key) 'calc-dispatch) + (let ((key2 (calc-read-key-sequence + (format "Describe key briefly: %s-" + (key-description key)) + calc-dispatch-map))) + (setq key (concat key key2)) + (lookup-key calc-dispatch-map key2)) + (if (eq (key-binding key) 'calc-help-prefix) + (let ((key2 (calc-read-key-sequence + (format "Describe key briefly: %s-" + (key-description key)) + calc-help-map))) + (setq key (concat key key2)) + (lookup-key calc-help-map key2)) + (key-binding key)))) + (inv nil) + (hyp nil)) + (while (or (equal key "I") (equal key "H")) + (if (equal key "I") + (setq inv (not inv)) + (setq hyp (not hyp))) + (setq key (read-key-sequence (format "Describe key%s:%s%s " + (if briefly " briefly" "") + (if inv " I" "") + (if hyp " H" ""))) + defn (key-binding key))) + (let ((desc (key-description key)) + target) + (if (string-match "^ESC " desc) + (setq desc (concat "M-" (substring desc 4)))) + (while (string-match "^M-# \\(ESC \\|C-\\)" desc) + (setq desc (concat "M-# " (substring desc (match-end 0))))) + (if briefly + (let ((msg (save-excursion + (set-buffer (get-buffer-create "*Calc Summary*")) + (if (= (buffer-size) 0) + (progn + (message "Reading Calc summary from manual...") + (save-window-excursion + (save-excursion + (calc-info) + (Info-goto-node "Summary") + (goto-char (point-min)) + (forward-line 1) + (copy-to-buffer "*Calc Summary*" + (point) (point-max)) + (Info-last))) + (setq case-fold-search nil) + (re-search-forward "^\\(.*\\)\\[\\.\\. a b") + (setq calc-summary-indentation + (- (match-end 1) (match-beginning 1))))) + (goto-char (point-min)) + (setq target (if (and (string-match "[0-9]\\'" desc) + (not (string-match "[d#]" desc))) + (concat (substring desc 0 -1) "0-9") + desc)) + (if (re-search-forward + (format "\n%s%s%s%s[ a-zA-Z]" + (make-string (+ calc-summary-indentation 9) + ?\.) + (if (string-match "M-#" desc) " " + (if inv + (if hyp "I H " " I ") + (if hyp " H " " "))) + (regexp-quote target) + (make-string (max (- 6 (length target)) 0) + ?\ )) + nil t) + (let (pt) + (beginning-of-line) + (forward-char calc-summary-indentation) + (setq pt (point)) + (end-of-line) + (buffer-substring pt (point))))))) + (if msg + (let ((args (substring msg 0 9)) + (keys (substring msg 9 19)) + (prompts (substring msg 19 38)) + (notes "") + (cmd (substring msg 40)) + msg) + (if (string-match "\\` +" args) + (setq args (substring args (match-end 0)))) + (if (string-match " +\\'" args) + (setq args (substring args 0 (match-beginning 0)))) + (if (string-match "\\` +" keys) + (setq keys (substring keys (match-end 0)))) + (if (string-match " +\\'" keys) + (setq keys (substring keys 0 (match-beginning 0)))) + (if (string-match " [0-9,]+\\'" prompts) + (setq notes (substring prompts (1+ (match-beginning 0))) + prompts (substring prompts 0 (match-beginning 0)))) + (if (string-match " +\\'" prompts) + (setq prompts (substring prompts 0 (match-beginning 0)))) + (if (string-match "\\` +" prompts) + (setq prompts (substring prompts (match-end 0)))) + (setq msg (format + "%s: %s%s`%s'%s%s %s%s" + (if (string-match + "\\`\\(calc-[-a-zA-Z0-9]+\\) *\\(.*\\)\\'" + cmd) + (prog1 (math-match-substring cmd 1) + (setq cmd (math-match-substring cmd 2))) + defn) + args (if (equal args "") "" " ") + keys + (if (equal prompts "") "" " ") prompts + (if (equal cmd "") "" " => ") cmd)) + (message "%s%s%s runs %s%s" + (if inv "I " "") (if hyp "H " "") desc + msg + (if (equal notes "") "" + (format " (?=notes %s)" notes))) + (let ((key (calc-read-key t))) + (if (eq (car key) ??) + (if (equal notes "") + (message "No notes for this command") + (while (string-match "," notes) + (aset notes (match-beginning 0) ? )) + (setq notes (sort (car (read-from-string + (format "(%s)" notes))) + '<)) + (with-output-to-temp-buffer "*Help*" + (princ (format "%s\n\n" msg)) + (set-buffer "*Calc Summary*") + (re-search-forward "^ *NOTES") + (while notes + (re-search-forward + (format "^ *%d\\. " (car notes))) + (beginning-of-line) + (let ((pt (point))) + (forward-line 1) + (or (re-search-forward "^ ? ?[0-9]+\\. " nil t) + (goto-char (point-max))) + (beginning-of-line) + (princ (buffer-substring pt (point)))) + (setq notes (cdr notes))) + (print-help-return-message))) + (calc-unread-command (cdr key))))) + (if (or (null defn) (integerp defn)) + (message "%s is undefined" desc) + (message "%s runs the command %s" + desc + (if (symbolp defn) defn (prin1-to-string defn)))))) + (if inv (setq desc (concat "I " desc))) + (if hyp (setq desc (concat "H " desc))) + (calc-describe-thing desc "Key Index" nil + (string-match "[A-Z][A-Z][A-Z]" desc))))) +) + +(defun calc-describe-function (&optional func) + (interactive) + (or func + (setq func (intern (completing-read "Describe function: " + obarray nil t "calcFunc-")))) + (setq func (symbol-name func)) + (if (string-match "\\`calc-." func) + (calc-describe-thing func "Command Index") + (calc-describe-thing (if (string-match "\\`calcFunc-." func) + (substring func 9) + func) + "Function Index")) +) + +(defun calc-describe-variable (&optional var) + (interactive) + (or var + (setq var (intern (completing-read "Describe variable: " + obarray nil t "var-")))) + (setq var (symbol-name var)) + (calc-describe-thing var "Variable Index" + (if (string-match "\\`var-." var) + (substring var 4) + var)) +) + +(defun calc-describe-thing (thing where &optional target not-quoted) + (message "Looking for `%s' in %s..." thing where) + (let ((savewin (current-window-configuration))) + (calc-info) + (Info-goto-node where) + (or (let ((case-fold-search nil)) + (re-search-forward (format "\n\\* +%s: \\(.*\\)\\." + (regexp-quote thing)) + nil t)) + (and (string-match "\\`\\([a-z ]*\\)[0-9]\\'" thing) + (re-search-forward (format "\n\\* +%s[01]-9: \\(.*\\)\\." + (substring thing 0 -1)) + nil t) + (setq thing (format "%s9" (substring thing 0 -1)))) + (progn + (Info-last) + (set-window-configuration savewin) + (error "Can't find `%s' in %s" thing where))) + (let (Info-history) + (Info-goto-node (buffer-substring (match-beginning 1) (match-end 1)))) + (or (let ((case-fold-search nil)) + (or (search-forward (format "\\[`%s'\\]\\|(`%s')\\|\\<The[ \n]`%s'" + (or target thing) + (or target thing) + (or target thing)) nil t) + (and not-quoted + (let ((case-fold-search t)) + (search-forward (or target thing) nil t))) + (search-forward (format "`%s'" (or target thing)) nil t) + (search-forward (or target thing) nil t))) + (let ((case-fold-search t)) + (or (search-forward (format "\\[`%s'\\]\\|(`%s')\\|\\<The[ \n]`%s'" + (or target thing) + (or target thing) + (or target thing)) nil t) + (search-forward (format "`%s'" (or target thing)) nil t) + (search-forward (or target thing) nil t)))) + (beginning-of-line) + (message "Found `%s' in %s" thing where)) +) + +(defun calc-view-news () + (interactive) + (let ((path load-path)) + (while (and path + (not (file-exists-p (expand-file-name "calc.el" (car path))))) + (setq path (cdr path))) + (or (and path + (file-exists-p (expand-file-name "README" (car path)))) + (error "Can't locate Calc sources")) + (calc-quit) + (switch-to-buffer "*Help*") + (erase-buffer) + (insert-file-contents (expand-file-name "README" (car path))) + (search-forward "Summary of changes") + (forward-line -1) + (delete-region (point-min) (point)) + (goto-char (point-min))) +) + + + +(defun calc-full-help () + (interactive) + (with-output-to-temp-buffer "*Help*" + (princ (format "GNU Emacs Calculator version %s of %s.\n" + calc-version calc-version-date)) + (princ " By Dave Gillespie, [email protected].\n") + (princ (format " Installed %s.\n" calc-installed-date)) + (princ " Copyright (C) 1990, 1993 Free Software Foundation, Inc.\n\n") + (princ "Type `h s' for a more detailed summary.\n") + (princ "Or type `h i' to read the full Calc manual on-line.\n\n") + (princ "Basic keys:\n") + (let* ((calc-full-help-flag t)) + (mapcar (function (lambda (x) (princ (format " %s\n" x)))) + (nreverse (cdr (reverse (cdr (calc-help)))))) + (mapcar (function (lambda (prefix) + (let ((msgs (condition-case err + (funcall prefix) + (error nil)))) + (if (car msgs) + (princ + (if (eq (nth 2 msgs) ?v) + "\n`v' or `V' prefix (vector/matrix) keys: \n" + (if (nth 2 msgs) + (format + "\n`%c' prefix (%s) keys:\n" + (nth 2 msgs) + (or (cdr (assq (nth 2 msgs) + calc-help-long-names)) + (nth 1 msgs))) + (format "\n%s-modified keys:\n" + (capitalize (nth 1 msgs))))))) + (mapcar (function (lambda (x) + (princ (format " %s\n" x)))) + (car msgs))))) + '(calc-inverse-prefix-help + calc-hyperbolic-prefix-help + calc-inv-hyp-prefix-help + calc-a-prefix-help + calc-b-prefix-help + calc-c-prefix-help + calc-d-prefix-help + calc-f-prefix-help + calc-g-prefix-help + calc-h-prefix-help + calc-j-prefix-help + calc-k-prefix-help + calc-m-prefix-help + calc-r-prefix-help + calc-s-prefix-help + calc-t-prefix-help + calc-u-prefix-help + calc-v-prefix-help + calc-shift-Y-prefix-help + calc-shift-Z-prefix-help + calc-z-prefix-help))) + (print-help-return-message)) +) + +(defvar calc-help-long-names '( ( ?b . "binary/business" ) + ( ?g . "graphics" ) + ( ?j . "selection" ) + ( ?k . "combinatorics/statistics" ) + ( ?u . "units/statistics" ) +)) + +(defun calc-h-prefix-help () + (interactive) + (calc-do-prefix-help + '("Help; Bindings; Info, Tutorial, Summary; News" + "describe: Key, C (briefly), Function, Variable") + "help" ?h) +) + +(defun calc-inverse-prefix-help () + (interactive) + (calc-do-prefix-help + '("I + S (arcsin), C (arccos), T (arctan); Q (square)" + "I + E (ln), L (exp), B (alog: B^X); f E (lnp1), f L (expm1)" + "I + F (ceiling), R (truncate); a S (invert func)" + "I + a m (match-not); c h (from-hms); k n (prev prime)" + "I + f G (gamma-Q); f e (erfc); k B (etc., lower-tail dists)" + "I + V S (reverse sort); V G (reverse grade)" + "I + v s (remove subvec); v h (tail)" + "I + t + (alt sum), t M (mean with error)" + "I + t S (pop std dev), t C (pop covar)") + "inverse" nil) +) + +(defun calc-hyperbolic-prefix-help () + (interactive) + (calc-do-prefix-help + '("H + S (sinh), C (cosh), T (tanh); E (exp10), L (log10)" + "H + F (float floor), R (float round); P (constant \"e\")" + "H + a d (total derivative); k c (permutations)" + "H + k b (bern-poly), k e (euler-poly); k s (stirling-2)" + "H + f G (gamma-g), f B (beta-B); v h (rhead), v k (rcons)" + "H + v e (expand w/filler); V H (weighted histogram)" + "H + a S (general solve eqn), j I (general isolate)" + "H + a R (widen/root), a N (widen/min), a X (widen/max)" + "H + t M (median), t S (variance), t C (correlation coef)" + "H + c f/F/c (pervasive float/frac/clean)") + "hyperbolic" nil) +) + +(defun calc-inv-hyp-prefix-help () + (interactive) + (calc-do-prefix-help + '("I H + S (arcsinh), C (arccosh), T (arctanh)" + "I H + E (log10), L (exp10); f G (gamma-G)" + "I H + F (float ceiling), R (float truncate)" + "I H + t S (pop variance)" + "I H + a S (general invert func); v h (rtail)") + "inverse-hyperbolic" nil) +) + + +(defun calc-f-prefix-help () + (interactive) + (calc-do-prefix-help + '("miN, maX; Hypot; Im, Re; Sign; [, ] (incr/decr)" + "Gamma, Beta, Erf, besselJ, besselY" + "SHIFT + int-sQrt; Int-log, Exp(x)-1, Ln(x+1); arcTan2" + "SHIFT + Abssqr; Mantissa, eXponent, Scale" + "SHIFT + incomplete: Gamma-P, Beta-I") + "functions" ?f) +) + + +(defun calc-s-prefix-help () + (interactive) + (calc-do-prefix-help + '("Store, inTo, Xchg, Unstore; Recall, 0-9; : (:=); = (=>)" + "Let; Copy; Declare; Insert, Perm; Edit" + "Negate, +, -, *, /, ^, &, |, [, ]; Map" + "SHIFT + Decls, GenCount, TimeZone, Holidays; IntegLimit" + "SHIFT + LineStyles, PointStyles, plotRejects; Units" + "SHIFT + Eval-, AlgSimp-, ExtSimp-, FitRules") + "store" ?s) +) + +(defun calc-r-prefix-help () + (interactive) + (calc-do-prefix-help + '("digits 0-9: recall, same as `s r 0-9'") + "recall" ?r) +) + + +(defun calc-j-prefix-help () + (interactive) + (calc-do-prefix-help + '("Select, Additional, Once; eVal, Formula; Rewrite" + "More, Less, 1-9, Next, Previous" + "Unselect, Clear; Display; Enable; Breakable" + "' (replace), ` (edit), +, -, *, /, RET (grab), DEL" + "SHIFT + swap: Left, Right; maybe: Select, Once" + "SHIFT + Commute, Merge, Distrib, jump-Eqn, Isolate" + "SHIFT + Negate, & (invert); Unpack") + "select" ?j) +) + + +(defun calc-a-prefix-help () + (interactive) + (calc-do-prefix-help + '("Simplify, Extended-simplify, eVal; \" (exp-formula)" + "eXpand, Collect, Factor, Apart, Norm-rat" + "GCD, /, \\, % (polys); Polint" + "Derivative, Integral, Taylor; _ (subscr)" + "suBstitute; Rewrite, Match" + "SHIFT + Solve; Root, miN, maX; Poly-roots; Fit" + "SHIFT + Map; Tabulate, + (sum), * (prod); num-Integ" + "relations: =, # (not =), <, >, [ (< or =), ] (> or =)" + "logical: & (and), | (or), ! (not); : (if)" + "misc: { (in-set); . (rmeq)") + "algebra" ?a) +) + + +(defun calc-b-prefix-help () + (interactive) + (calc-do-prefix-help + '("And, Or, Xor, Diff, Not; Wordsize, Clip" + "Lshift, Rshift, roTate; SHIFT + signed Lshift, Rshift" + "SHIFT + business: Pv, Npv, Fv, pMt, #pmts, raTe, Irr" + "SHIFT + business: Sln, sYd, Ddb; %ch") + "binary/bus" ?b) +) + + +(defun calc-c-prefix-help () + (interactive) + (calc-do-prefix-help + '("Deg, Rad, HMS; Float; Polar/rect; Clean, 0-9; %" + "SHIFT + Fraction") + "convert" ?c) +) + + +(defun calc-d-prefix-help () + (interactive) + (calc-do-prefix-help + '("Group, \",\"; Normal, Fix, Sci, Eng, \".\"; Over" + "Radix, Zeros, 2, 8, 0, 6; Hms; Date; Complex, I, J" + "Why; Line-nums, line-Breaks; <, =, > (justify); Plain" + "\" (strings); Truncate, [, ]; SPC (refresh), RET" + "SHIFT + language: Normal, One-line, Big, Unformatted" + "SHIFT + language: C, Pascal, Fortran; TeX, Eqn" + "SHIFT + language: Mathematica, W=Maple") + "display" ?d) +) + + +(defun calc-g-prefix-help () + (interactive) + (calc-do-prefix-help + '("Fast; Add, Delete, Juggle; Plot, Clear; Quit" + "Header, Name, Grid, Border, Key; View-commands, X-display" + "x-axis: Range, Title, Log, Zero; lineStyle" + "SHIFT + y-axis: Range, Title, Log, Zero; pointStyle" + "SHIFT + Print; Device, Output-file; X-geometry" + "SHIFT + Num-pts; Command, Kill, View-trail" + "SHIFT + 3d: Fast, Add; CTRL + z-axis: Range, Title, Log") + "graph" ?g) +) + + +(defun calc-k-prefix-help () + (interactive) + (calc-do-prefix-help + '("GCD, LCM; Choose (binomial), Double-factorial" + "Random, random-Again, sHuffle" + "Factors, Prime-test, Next-prime, Totient, Moebius" + "Bernoulli, Euler, Stirling" + "SHIFT + Extended-gcd" + "SHIFT + dists: Binomial, Chi-square, F, Normal" + "SHIFT + dists: Poisson, student's-T") + "combinatorics" ?k) +) + + +(defun calc-m-prefix-help () + (interactive) + (calc-do-prefix-help + '("Deg, Rad, HMS; Frac; Polar; Inf; Alg, Total; Symb; Vec/mat" + "Working; Xtensions; Mode-save" + "SHIFT + Shifted-prefixes, mode-Filename; Record; reCompute" + "SHIFT + simplify: Off, Num, Default, Bin, Alg, Ext, Units") + "mode" ?m) +) + + +(defun calc-t-prefix-help () + (interactive) + (calc-do-prefix-help + '("Display; Fwd, Back; Next, Prev, Here, [, ]; Yank" + "Search, Rev; In, Out; <, >; Kill; Marker; . (abbrev)" + "SHIFT + time: Now; Part; Date, Julian, Unix, Czone" + "SHIFT + time: newWeek, newMonth, newYear; Incmonth" + "SHIFT + time: +, - (business days)" + "digits 0-9: store-to, same as `s t 0-9'") + "trail/time" ?t) +) + + +(defun calc-u-prefix-help () + (interactive) + (calc-do-prefix-help + '("Simplify, Convert, Temperature-convert, Base-units" + "Autorange; Remove, eXtract; Explain; View-table; 0-9" + "Define, Undefine, Get-defn, Permanent" + "SHIFT + View-table-other-window" + "SHIFT + stat: Mean, G-mean, Std-dev, Covar, maX, miN" + "SHIFT + stat: + (sum), - (asum), * (prod), # (count)") + "units/stat" ?u) +) + + +(defun calc-v-prefix-help () + (interactive) + (calc-do-prefix-help + '("Pack, Unpack, Identity, Diagonal, indeX, Build" + "Row, Column, Subvector; Length; Find; Mask, Expand" + "Tranpose, Arrange, reVerse; Head, Kons; rNorm" + "SHIFT + Det, & (inverse), LUD, Trace, conJtrn, Cross" + "SHIFT + Sort, Grade, Histogram; cNorm" + "SHIFT + Apply, Map, Reduce, accUm, Inner-, Outer-prod" + "SHIFT + sets: V (union), ^ (intersection), - (diff)" + "SHIFT + sets: Xor, ~ (complement), Floor, Enum" + "SHIFT + sets: : (span), # (card), + (rdup)" + "<, =, > (justification); , (commas); [, {, ( (brackets)" + "} (matrix brackets); . (abbreviate); / (multi-lines)") + "vec/mat" ?v) +) + diff --git a/lisp/calc/calc-incom.el b/lisp/calc/calc-incom.el new file mode 100644 index 0000000000..07d6d93b9d --- /dev/null +++ b/lisp/calc/calc-incom.el @@ -0,0 +1,234 @@ +;; Calculator for GNU Emacs, part II [calc-incom.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-incom () nil) + + +;;; Incomplete forms. + +(defun calc-begin-complex () + (interactive) + (calc-wrapper + (if (or calc-algebraic-mode calc-incomplete-algebraic-mode) + (calc-alg-entry "(") + (calc-push (list 'incomplete calc-complex-mode)))) +) + +(defun calc-end-complex () + (interactive) + (calc-comma t) + (calc-wrapper + (let ((top (calc-top 1))) + (if (and (eq (car-safe top) 'incomplete) + (eq (nth 1 top) 'intv)) + (progn + (if (< (length top) 4) + (setq top (append top '((neg (var inf var-inf)))))) + (if (< (length top) 5) + (setq top (append top '((var inf var-inf))))) + (calc-enter-result 1 "..)" (cdr top))) + (if (not (and (eq (car-safe top) 'incomplete) + (memq (nth 1 top) '(cplx polar)))) + (error "Not entering a complex number")) + (while (< (length top) 4) + (setq top (append top '(0)))) + (if (not (and (math-realp (nth 2 top)) + (math-anglep (nth 3 top)))) + (error "Components must be real")) + (calc-enter-result 1 "()" (cdr top))))) +) + +(defun calc-begin-vector () + (interactive) + (calc-wrapper + (if (or calc-algebraic-mode calc-incomplete-algebraic-mode) + (calc-alg-entry "[") + (calc-push '(incomplete vec)))) +) + +(defun calc-end-vector () + (interactive) + (calc-comma t) + (calc-wrapper + (let ((top (calc-top 1))) + (if (and (eq (car-safe top) 'incomplete) + (eq (nth 1 top) 'intv)) + (progn + (if (< (length top) 4) + (setq top (append top '((neg (var inf var-inf)))))) + (if (< (length top) 5) + (setq top (append top '((var inf var-inf))))) + (setcar (cdr (cdr top)) (1+ (nth 2 top))) + (calc-enter-result 1 "..]" (cdr top))) + (if (not (and (eq (car-safe top) 'incomplete) + (eq (nth 1 top) 'vec))) + (error "Not entering a vector")) + (calc-pop-push-record 1 "[]" (cdr top))))) +) + +(defun calc-comma (&optional allow-polar) + (interactive) + (calc-wrapper + (let ((num (calc-find-first-incomplete + (nthcdr calc-stack-top calc-stack) 1))) + (if (= num 0) + (error "Not entering a vector or complex number")) + (let* ((inc (calc-top num)) + (stuff (calc-top-list (1- num))) + (new (append inc stuff))) + (if (and (null stuff) + (not allow-polar) + (or (eq (nth 1 inc) 'vec) + (< (length new) 4))) + (setq new (append new + (if (= (length new) 2) + '(0) + (nthcdr (1- (length new)) new))))) + (or allow-polar + (if (eq (nth 1 new) 'polar) + (setq new (append '(incomplete cplx) (cdr (cdr new)))) + (if (eq (nth 1 new) 'intv) + (setq new (append '(incomplete cplx) + (cdr (cdr (cdr new)))))))) + (if (and (memq (nth 1 new) '(cplx polar)) + (> (length new) 4)) + (error "Too many components in complex number")) + (if (and (eq (nth 1 new) 'intv) + (> (length new) 5)) + (error "Too many components in interval form")) + (calc-pop-push num new)))) +) + +(defun calc-semi () + (interactive) + (calc-wrapper + (let ((num (calc-find-first-incomplete + (nthcdr calc-stack-top calc-stack) 1))) + (if (= num 0) + (error "Not entering a vector or complex number")) + (let ((inc (calc-top num)) + (stuff (calc-top-list (1- num)))) + (if (eq (nth 1 inc) 'cplx) + (setq inc (append '(incomplete polar) (cdr (cdr inc)))) + (if (eq (nth 1 inc) 'intv) + (setq inc (append '(incomplete polar) (cdr (cdr (cdr inc))))))) + (cond ((eq (nth 1 inc) 'polar) + (let ((new (append inc stuff))) + (if (> (length new) 4) + (error "Too many components in complex number") + (if (= (length new) 2) + (setq new (append new '(1))))) + (calc-pop-push num new))) + ((null stuff) + (if (> (length inc) 2) + (if (math-vectorp (nth 2 inc)) + (calc-comma) + (calc-pop-push 1 + (list 'incomplete 'vec (cdr (cdr inc))) + (list 'incomplete 'vec))))) + ((math-vectorp (car stuff)) + (calc-comma)) + ((eq (car-safe (car-safe (nth (+ num calc-stack-top) + calc-stack))) 'incomplete) + (calc-end-vector) + (calc-comma) + (let ((calc-algebraic-mode nil) + (calc-incomplete-algebraic-mode nil)) + (calc-begin-vector))) + ((or (= (length inc) 2) + (math-vectorp (nth 2 inc))) + (calc-pop-push num + (append inc (list (cons 'vec stuff))) + (list 'incomplete 'vec))) + (t + (calc-pop-push num + (list 'incomplete 'vec + (cons 'vec (append (cdr (cdr inc)) stuff))) + (list 'incomplete 'vec))))))) +) + +(defun calc-digit-dots () + (if (eq calc-prev-char ?.) + (progn + (delete-backward-char 1) + (if (calc-minibuffer-contains ".*\\.\\'") + (delete-backward-char 1)) + (setq calc-prev-char 'dots + last-command-char 32) + (if calc-prev-prev-char + (calcDigit-nondigit) + (setq calc-digit-value nil) + (erase-buffer) + (exit-minibuffer))) + ;; just ignore extra decimal point, anticipating ".." + (delete-backward-char 1)) +) + +(defun calc-dots () + (interactive) + (calc-wrapper + (let ((num (calc-find-first-incomplete + (nthcdr calc-stack-top calc-stack) 1))) + (if (= num 0) + (error "Not entering an interval form")) + (let* ((inc (calc-top num)) + (stuff (calc-top-list (1- num))) + (new (append inc stuff))) + (if (not (eq (nth 1 new) 'intv)) + (setq new (append '(incomplete intv) + (if (eq (nth 1 new) 'vec) '(2) '(0)) + (cdr (cdr new))))) + (if (and (null stuff) + (= (length new) 3)) + (setq new (append new '((neg (var inf var-inf)))))) + (if (> (length new) 5) + (error "Too many components in interval form")) + (calc-pop-push num new)))) +) + +(defun calc-find-first-incomplete (stack n) + (cond ((null stack) + 0) + ((eq (car-safe (car-safe (car stack))) 'incomplete) + n) + (t + (calc-find-first-incomplete (cdr stack) (1+ n)))) +) + +(defun calc-incomplete-error (a) + (cond ((memq (nth 1 a) '(cplx polar)) + (error "Complex number is incomplete")) + ((eq (nth 1 a) 'vec) + (error "Vector is incomplete")) + ((eq (nth 1 a) 'intv) + (error "Interval form is incomplete")) + (t (error "Object is incomplete"))) +) + + + diff --git a/lisp/calc/calc-keypd.el b/lisp/calc/calc-keypd.el new file mode 100644 index 0000000000..3c087abb07 --- /dev/null +++ b/lisp/calc/calc-keypd.el @@ -0,0 +1,682 @@ +;; Calculator for GNU Emacs, part II [calc-keypd.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-keypd () nil) + + + +;;; Pictorial interface to Calc using the X window system mouse. + +(defvar calc-keypad-buffer nil) +(defvar calc-keypad-menu 0) +(defvar calc-keypad-full-layout nil) +(defvar calc-keypad-input nil) +(defvar calc-keypad-prev-input nil) +(defvar calc-keypad-prev-x-left-click nil) +(defvar calc-keypad-prev-x-middle-click nil) +(defvar calc-keypad-prev-x-right-click nil) +(defvar calc-keypad-said-hello nil) + +(defvar calc-keypad-map nil) +(if calc-keypad-map + () + (setq calc-keypad-map (make-sparse-keymap)) + (define-key calc-keypad-map " " 'calc-keypad-press) + (define-key calc-keypad-map "\r" 'calc-keypad-press) + (define-key calc-keypad-map "\t" 'calc-keypad-menu) + (define-key calc-keypad-map "q" 'calc-keypad-off)) + +(defun calc-do-keypad (&optional full-display interactive) + (if (string-match "^19" emacs-version) + (error "Sorry, calc-keypad not yet implemented for Emacs 19")) + (calc-create-buffer) + (let ((calcbuf (current-buffer))) + (or (and calc-keypad-buffer + (buffer-name calc-keypad-buffer)) + (progn + (setq calc-keypad-buffer (get-buffer-create "*Calc Keypad*")) + (set-buffer calc-keypad-buffer) + (use-local-map calc-keypad-map) + (setq major-mode 'calc-keypad) + (setq mode-name "Calculator") + (put 'calc-keypad 'mode-class 'special) + (make-local-variable 'calc-main-buffer) + (setq calc-main-buffer calcbuf) + (calc-keypad-redraw) + (calc-trail-buffer))) + (let ((width 29) + (height 17) + win old-win) + (if (setq win (get-buffer-window "*Calculator*")) + (delete-window win)) + (if (setq win (get-buffer-window "*Calc Trail*")) + (if (one-window-p) + (switch-to-buffer (other-buffer)) + (delete-window win))) + (if (setq win (get-buffer-window calc-keypad-buffer)) + (progn + (bury-buffer "*Calculator*") + (bury-buffer "*Calc Trail*") + (bury-buffer calc-keypad-buffer) + (if (one-window-p) + (switch-to-buffer (other-buffer)) + (delete-window win)) + (if (and calc-keypad-prev-x-left-click + (eq (aref mouse-map 0) 'calc-keypad-x-right-click) + (eq (aref mouse-map 1) 'calc-keypad-x-middle-click) + (eq (aref mouse-map 2) 'calc-keypad-x-left-click)) + (progn + (aset mouse-map 0 calc-keypad-prev-x-right-click) + (aset mouse-map 1 calc-keypad-prev-x-middle-click) + (aset mouse-map 2 calc-keypad-prev-x-left-click) + (setq calc-keypad-prev-x-left-click nil)))) + (setq calc-was-keypad-mode t + old-win (get-largest-window)) + (if (or (< (window-height old-win) (+ height 6)) + (< (window-width old-win) (+ width 15)) + full-display) + (delete-other-windows old-win)) + (if (< (window-height old-win) (+ height 4)) + (error "Screen is not tall enough for this mode")) + (if full-display + (progn + (setq win (split-window old-win (- (window-height old-win) + height 1))) + (set-window-buffer old-win (calc-trail-buffer)) + (set-window-buffer win calc-keypad-buffer) + (set-window-start win 1) + (setq win (split-window win (+ width 3) t)) + (set-window-buffer win calcbuf)) + (if (or t ; left-side keypad not yet fully implemented + (< (save-excursion + (set-buffer (window-buffer old-win)) + (current-column)) + (/ (window-width) 2))) + (setq win (split-window old-win (- (window-width old-win) + width 2) + t)) + (setq old-win (split-window old-win (+ width 2) t))) + (set-window-buffer win calc-keypad-buffer) + (set-window-start win 1) + (split-window win (- (window-height win) height 1)) + (set-window-buffer win calcbuf)) + (select-window old-win) + (if (and (eq window-system 'x) + (not calc-keypad-prev-x-left-click)) + (progn + (setq calc-keypad-prev-x-right-click (aref mouse-map 0) + calc-keypad-prev-x-middle-click (aref mouse-map 1) + calc-keypad-prev-x-left-click (aref mouse-map 2)) + (aset mouse-map 0 'calc-keypad-x-right-click) + (aset mouse-map 1 'calc-keypad-x-middle-click) + (aset mouse-map 2 'calc-keypad-x-left-click))) + (message "Welcome to GNU Emacs Calc! Use the left and right mouse buttons.") + (run-hooks 'calc-keypad-start-hook) + (and calc-keypad-said-hello interactive + (progn + (sit-for 2) + (message ""))) + (setq calc-keypad-said-hello t)))) + (setq calc-keypad-input nil) +) + +(defun calc-keypad-off () + (interactive) + (if calc-standalone-flag + (save-buffers-kill-emacs nil) + (calc-keypad)) +) + +(defun calc-keypad-redraw () + (set-buffer calc-keypad-buffer) + (setq buffer-read-only t) + (setq calc-keypad-full-layout (append (symbol-value (nth calc-keypad-menu + calc-keypad-menus)) + calc-keypad-layout)) + (let ((buffer-read-only nil) + (row calc-keypad-full-layout) + (y 0)) + (erase-buffer) + (insert "\n") + (while row + (let ((col (car row))) + (while col + (let* ((key (car col)) + (cwid (if (>= y 4) + 5 + (if (and (= y 3) (eq col (car row))) + (progn (setq col (cdr col)) 9) + 4))) + (name (if (and calc-standalone-flag + (eq (nth 1 key) 'calc-keypad-off)) + "EXIT" + (if (> (length (car key)) cwid) + (substring (car key) 0 cwid) + (car key)))) + (wid (length name)) + (pad (- cwid (/ wid 2)))) + (insert (make-string (/ (- cwid wid) 2) 32) + name + (make-string (/ (- cwid wid -1) 2) 32) + (if (equal name "MENU") + (int-to-string (1+ calc-keypad-menu)) + "|"))) + (or (setq col (cdr col)) + (insert "\n"))) + (insert (if (>= y 4) + "-----+-----+-----+-----+-----" + (if (= y 3) + "-----+---+-+--+--+-+---++----" + "----+----+----+----+----+----")) + (if (= y 7) "+\n" "|\n")) + (setq y (1+ y) + row (cdr row))))) + (setq calc-keypad-prev-input t) + (calc-keypad-show-input) + (goto-char (point-min)) +) + +(defun calc-keypad-show-input () + (or (equal calc-keypad-input calc-keypad-prev-input) + (let ((buffer-read-only nil)) + (save-excursion + (goto-char (point-min)) + (forward-line 1) + (delete-region (point-min) (point)) + (if calc-keypad-input + (insert "Calc: " calc-keypad-input "\n") + (insert "----+-----Calc " calc-version "-----+----" + (int-to-string (1+ calc-keypad-menu)) + "\n"))))) + (setq calc-keypad-prev-input calc-keypad-input) +) + +(defun calc-keypad-press () + (interactive) + (or (eq major-mode 'calc-keypad) + (error "Must be in *Calc Keypad* buffer for this command")) + (let* ((row (save-excursion + (beginning-of-line) + (count-lines (point-min) (point)))) + (y (/ row 2)) + (x (/ (current-column) (if (>= y 4) 6 5))) + radix frac inv + (hyp (save-excursion + (set-buffer calc-main-buffer) + (setq radix calc-number-radix + frac calc-prefer-frac + inv calc-inverse-flag) + calc-hyperbolic-flag)) + (invhyp t) + (menu (symbol-value (nth calc-keypad-menu calc-keypad-menus))) + (input calc-keypad-input) + (iexpon (and input + (or (string-match "\\*[0-9]+\\.\\^" input) + (and (<= radix 14) (string-match "e" input))) + (match-end 0))) + (key (nth x (nth y calc-keypad-full-layout))) + (cmd (or (nth (if inv (if hyp 4 2) (if hyp 3 99)) key) + (setq invhyp nil) + (nth 1 key))) + (isstring (and (consp cmd) (stringp (car cmd)))) + (calc-is-keypad-press t)) + (if invhyp (calc-wrapper)) ; clear Inv and Hyp flags + (unwind-protect + (cond ((or (null cmd) + (= (% row 2) 0)) + (beep)) + ((and (> (minibuffer-depth) 0)) + (cond (isstring + (setq unread-command-char (aref (car cmd) 0))) + ((eq cmd 'calc-pop) + (setq unread-command-char ?\177)) + ((eq cmd 'calc-enter) + (setq unread-command-char 13)) + ((eq cmd 'calc-undo) + (setq unread-command-char 7)) + (t + (beep)))) + ((and input (string-match "STO\\|RCL" input)) + (cond ((and isstring (string-match "[0-9]" (car cmd))) + (setq calc-keypad-input nil) + (let ((var (intern (concat "var-q" (car cmd))))) + (cond ((equal input "STO+") (calc-store-plus var)) + ((equal input "STO-") (calc-store-minus var)) + ((equal input "STO*") (calc-store-times var)) + ((equal input "STO/") (calc-store-div var)) + ((equal input "STO^") (calc-store-power var)) + ((equal input "STOn") (calc-store-neg 1 var)) + ((equal input "STO&") (calc-store-inv 1 var)) + ((equal input "STO") (calc-store-into var)) + (t (calc-recall var))))) + ((memq cmd '(calc-pop calc-undo)) + (setq calc-keypad-input nil)) + ((and (equal input "STO") + (setq frac (assq cmd '( ( calc-plus . "+" ) + ( calc-minus . "-" ) + ( calc-times . "*" ) + ( calc-divide . "/" ) + ( calc-power . "^") + ( calc-change-sign . "n") + ( calc-inv . "&") )))) + (setq calc-keypad-input (concat input (cdr frac)))) + (t + (beep)))) + (isstring + (setq cmd (car cmd)) + (if (or (and (equal cmd ".") + input + (string-match "[.:e^]" input)) + (and (equal cmd "e") + input + (or (and (<= radix 14) (string-match "e" input)) + (string-match "\\^\\|[-.:]\\'" input))) + (and (not (equal cmd ".")) + (let ((case-fold-search nil)) + (string-match cmd "0123456789ABCDEF" + (if (string-match + "[e^]" (or input "")) + 10 radix))))) + (beep) + (setq calc-keypad-input (concat + (and (/= radix 10) + (or (not input) + (equal input "-")) + (format "%d#" radix)) + (and (or (not input) + (equal input "-")) + (or (and (equal cmd "e") "1") + (and (equal cmd ".") + (if frac "1" "0")))) + input + (if (and (equal cmd ".") frac) + ":" + (if (and (equal cmd "e") + (or (not input) + (string-match + "#" input)) + (> radix 14)) + (format "*%d.^" radix) + cmd)))))) + ((and (eq cmd 'calc-change-sign) + input) + (let* ((epos (or iexpon 0)) + (suffix (substring input epos))) + (setq calc-keypad-input (concat + (substring input 0 epos) + (if (string-match "\\`-" suffix) + (substring suffix 1) + (concat "-" suffix)))))) + ((and (eq cmd 'calc-pop) + input) + (if (equal input "") + (beep) + (setq calc-keypad-input (substring input 0 + (or (string-match + "\\*[0-9]+\\.\\^\\'" + input) + -1))))) + ((and (eq cmd 'calc-undo) + input) + (setq calc-keypad-input nil)) + (t + (if input + (let ((val (math-read-number input))) + (setq calc-keypad-input nil) + (if val + (calc-wrapper + (calc-push-list (list (calc-record + (calc-normalize val))))) + (or (equal input "") + (beep)) + (setq cmd nil)) + (if (eq cmd 'calc-enter) (setq cmd nil)))) + (setq prefix-arg current-prefix-arg) + (if cmd + (if (and (consp cmd) (eq (car cmd) 'progn)) + (while (setq cmd (cdr cmd)) + (if (integerp (car cmd)) + (setq prefix-arg (car cmd)) + (command-execute (car cmd)))) + (command-execute cmd))))) + (set-buffer calc-keypad-buffer) + (calc-keypad-show-input))) +) + +(defun calc-keypad-x-left-click (arg) + "Handle a left-button mouse click in Calc Keypad window." + (let (coords) + (if (and calc-keypad-buffer + (buffer-name calc-keypad-buffer) + (get-buffer-window calc-keypad-buffer) + (setq coords (coordinates-in-window-p + arg (get-buffer-window calc-keypad-buffer)))) + (let ((win (selected-window))) + (unwind-protect + (progn + (x-mouse-set-point arg) + (calc-keypad-press)) + (and (window-point win) + (select-window win)))) + (funcall calc-keypad-prev-x-left-click arg))) +) + +(defun calc-keypad-x-right-click (arg) + "Handle a right-button mouse click in Calc Keypad window." + (if (and calc-keypad-buffer + (buffer-name calc-keypad-buffer) + (get-buffer-window calc-keypad-buffer) + (coordinates-in-window-p + arg (get-buffer-window calc-keypad-buffer))) + (save-excursion + (set-buffer calc-keypad-buffer) + (calc-keypad-menu)) + (funcall calc-keypad-prev-x-right-click arg)) +) + +(defun calc-keypad-x-middle-click (arg) + "Handle a middle-button mouse click in Calc Keypad window." + (if (and calc-keypad-buffer + (buffer-name calc-keypad-buffer) + (get-buffer-window calc-keypad-buffer) + (coordinates-in-window-p + arg (get-buffer-window calc-keypad-buffer))) + (save-excursion + (set-buffer calc-keypad-buffer) + (calc-keypad-menu-back)) + (funcall calc-keypad-prev-x-middle-click arg)) +) + +(defun calc-keypad-menu () + (interactive) + (or (eq major-mode 'calc-keypad) + (error "Must be in *Calc Keypad* buffer for this command")) + (while (progn (setq calc-keypad-menu (% (1+ calc-keypad-menu) + (length calc-keypad-menus))) + (not (symbol-value (nth calc-keypad-menu calc-keypad-menus))))) + (calc-keypad-redraw) +) + +(defun calc-keypad-menu-back () + (interactive) + (or (eq major-mode 'calc-keypad) + (error "Must be in *Calc Keypad* buffer for this command")) + (while (progn (setq calc-keypad-menu (% (1- (+ calc-keypad-menu + (length calc-keypad-menus))) + (length calc-keypad-menus))) + (not (symbol-value (nth calc-keypad-menu calc-keypad-menus))))) + (calc-keypad-redraw) +) + +(defun calc-keypad-store () + (interactive) + (setq calc-keypad-input "STO") +) + +(defun calc-keypad-recall () + (interactive) + (setq calc-keypad-input "RCL") +) + +(defun calc-pack-interval (mode) + (interactive "p") + (if (or (< mode 0) (> mode 3)) + (error "Open/close code should be in the range from 0 to 3.")) + (calc-pack (- -6 mode)) +) + +(defun calc-keypad-execute () + (interactive) + (let* ((prompt "Calc keystrokes: ") + (flush 'x-flush-mouse-queue) + (prefix nil) + keys cmd) + (save-excursion + (calc-select-buffer) + (while (progn + (setq keys (read-key-sequence prompt)) + (setq cmd (key-binding keys)) + (if (or (memq cmd '(calc-inverse + calc-hyperbolic + universal-argument + digit-argument + negative-argument)) + (and prefix (string-match "\\`\e?[-0-9]\\'" keys))) + (progn + (setq last-command-char (aref keys (1- (length keys)))) + (command-execute cmd) + (setq flush 'not-any-more + prefix t + prompt (concat prompt (key-description keys) " "))) + (eq cmd flush))))) ; skip mouse-up event + (message "") + (if (commandp cmd) + (command-execute cmd) + (error "Not a Calc command: %s" (key-description keys)))) +) + + +;;; |----+----+----+----+----+----| +;;; | ENTER |+/- |EEX |UNDO| <- | +;;; |-----+---+-+--+--+-+---++----| +;;; | INV | 7 | 8 | 9 | / | +;;; |-----+-----+-----+-----+-----| +;;; | HYP | 4 | 5 | 6 | * | +;;; |-----+-----+-----+-----+-----| +;;; |EXEC | 1 | 2 | 3 | - | +;;; |-----+-----+-----+-----+-----| +;;; | OFF | 0 | . | PI | + | +;;; |-----+-----+-----+-----+-----| + +(defvar calc-keypad-layout + '( ( ( "ENTER" calc-enter calc-roll-down calc-roll-up calc-over ) + ( "ENTER" calc-enter calc-roll-down calc-roll-up calc-over ) + ( "+/-" calc-change-sign calc-inv (progn -4 calc-pack) ) + ( "EEX" ("e") (progn calc-num-prefix calc-pack-interval) + (progn -5 calc-pack) ) + ( "UNDO" calc-undo calc-redo calc-last-args ) + ( "<-" calc-pop (progn 0 calc-pop) + (progn calc-num-prefix calc-pop) ) ) + ( ( "INV" calc-inverse ) + ( "7" ("7") calc-round ) + ( "8" ("8") (progn 2 calc-clean-num) ) + ( "9" ("9") calc-float ) + ( "/" calc-divide (progn calc-inverse calc-power) ) ) + ( ( "HYP" calc-hyperbolic ) + ( "4" ("4") calc-ln calc-log10 ) + ( "5" ("5") calc-exp calc-exp10 ) + ( "6" ("6") calc-abs ) + ( "*" calc-times calc-power ) ) + ( ( "EXEC" calc-keypad-execute ) + ( "1" ("1") calc-arcsin calc-sin ) + ( "2" ("2") calc-arccos calc-cos ) + ( "3" ("3") calc-arctan calc-tan ) + ( "-" calc-minus calc-conj ) ) + ( ( "OFF" calc-keypad-off ) + ( "0" ("0") calc-imaginary ) + ( "." (".") calc-precision ) + ( "PI" calc-pi ) + ( "+" calc-plus calc-sqrt ) ) ) +) + +(defvar calc-keypad-menus '( calc-keypad-math-menu + calc-keypad-funcs-menu + calc-keypad-binary-menu + calc-keypad-vector-menu + calc-keypad-modes-menu + calc-keypad-user-menu ) ) + +;;; |----+----+----+----+----+----| +;;; |FLR |CEIL|RND |TRNC|CLN2|FLT | +;;; |----+----+----+----+----+----| +;;; | LN |EXP | |ABS |IDIV|MOD | +;;; |----+----+----+----+----+----| +;;; |SIN |COS |TAN |SQRT|y^x |1/x | + +(defvar calc-keypad-math-menu + '( ( ( "FLR" calc-floor ) + ( "CEIL" calc-ceiling ) + ( "RND" calc-round ) + ( "TRNC" calc-trunc ) + ( "CLN2" (progn 2 calc-clean-num) ) + ( "FLT" calc-float ) ) + ( ( "LN" calc-ln ) + ( "EXP" calc-exp ) + ( "" nil ) + ( "ABS" calc-abs ) + ( "IDIV" calc-idiv ) + ( "MOD" calc-mod ) ) + ( ( "SIN" calc-sin ) + ( "COS" calc-cos ) + ( "TAN" calc-tan ) + ( "SQRT" calc-sqrt ) + ( "y^x" calc-power ) + ( "1/x" calc-inv ) ) ) +) + +;;; |----+----+----+----+----+----| +;;; |IGAM|BETA|IBET|ERF |BESJ|BESY| +;;; |----+----+----+----+----+----| +;;; |IMAG|CONJ| RE |ATN2|RAND|RAGN| +;;; |----+----+----+----+----+----| +;;; |GCD |FACT|DFCT|BNOM|PERM|NXTP| + +(defvar calc-keypad-funcs-menu + '( ( ( "IGAM" calc-inc-gamma ) + ( "BETA" calc-beta ) + ( "IBET" calc-inc-beta ) + ( "ERF" calc-erf ) + ( "BESJ" calc-bessel-J ) + ( "BESY" calc-bessel-Y ) ) + ( ( "IMAG" calc-imaginary ) + ( "CONJ" calc-conj ) + ( "RE" calc-re calc-im ) + ( "ATN2" calc-arctan2 ) + ( "RAND" calc-random ) + ( "RAGN" calc-random-again ) ) + ( ( "GCD" calc-gcd calc-lcm ) + ( "FACT" calc-factorial calc-gamma ) + ( "DFCT" calc-double-factorial ) + ( "BNOM" calc-choose ) + ( "PERM" calc-perm ) + ( "NXTP" calc-next-prime calc-prev-prime ) ) ) +) + +;;; |----+----+----+----+----+----| +;;; |AND | OR |XOR |NOT |LSH |RSH | +;;; |----+----+----+----+----+----| +;;; |DEC |HEX |OCT |BIN |WSIZ|ARSH| +;;; |----+----+----+----+----+----| +;;; | A | B | C | D | E | F | + +(defvar calc-keypad-binary-menu + '( ( ( "AND" calc-and calc-diff ) + ( "OR" calc-or ) + ( "XOR" calc-xor ) + ( "NOT" calc-not calc-clip ) + ( "LSH" calc-lshift-binary calc-rotate-binary ) + ( "RSH" calc-rshift-binary ) ) + ( ( "DEC" calc-decimal-radix ) + ( "HEX" calc-hex-radix ) + ( "OCT" calc-octal-radix ) + ( "BIN" calc-binary-radix ) + ( "WSIZ" calc-word-size ) + ( "ARSH" calc-rshift-arith ) ) + ( ( "A" ("A") ) + ( "B" ("B") ) + ( "C" ("C") ) + ( "D" ("D") ) + ( "E" ("E") ) + ( "F" ("F") ) ) ) +) + +;;; |----+----+----+----+----+----| +;;; |SUM |PROD|MAX |MAP*|MAP^|MAP$| +;;; |----+----+----+----+----+----| +;;; |INV |DET |TRN |IDNT|CRSS|"x" | +;;; |----+----+----+----+----+----| +;;; |PACK|UNPK|INDX|BLD |LEN |... | + +(defvar calc-keypad-vector-menu + '( ( ( "SUM" calc-vector-sum calc-vector-alt-sum calc-vector-mean ) + ( "PROD" calc-vector-product nil calc-vector-sdev ) + ( "MAX" calc-vector-max calc-vector-min calc-vector-median ) + ( "MAP*" (lambda () (interactive) + (calc-map '(2 calcFunc-mul "*"))) ) + ( "MAP^" (lambda () (interactive) + (calc-map '(2 calcFunc-pow "^"))) ) + ( "MAP$" calc-map-stack ) ) + ( ( "MINV" calc-inv ) + ( "MDET" calc-mdet ) + ( "MTRN" calc-transpose calc-conj-transpose ) + ( "IDNT" (progn calc-num-prefix calc-ident) ) + ( "CRSS" calc-cross ) + ( "\"x\"" "\excalc-algebraic-entry\rx\r" + "\excalc-algebraic-entry\ry\r" + "\excalc-algebraic-entry\rz\r" + "\excalc-algebraic-entry\rt\r") ) + ( ( "PACK" calc-pack ) + ( "UNPK" calc-unpack ) + ( "INDX" (progn calc-num-prefix calc-index) "\C-u\excalc-index\r" ) + ( "BLD" (progn calc-num-prefix calc-build-vector) ) + ( "LEN" calc-vlength ) + ( "..." calc-full-vectors ) ) ) +) + +;;; |----+----+----+----+----+----| +;;; |FLT |FIX |SCI |ENG |GRP | | +;;; |----+----+----+----+----+----| +;;; |RAD |DEG |FRAC|POLR|SYMB|PREC| +;;; |----+----+----+----+----+----| +;;; |SWAP|RLL3|RLL4|OVER|STO |RCL | + +(defvar calc-keypad-modes-menu + '( ( ( "FLT" calc-normal-notation + (progn calc-num-prefix calc-normal-notation) ) + ( "FIX" (progn 2 calc-fix-notation) + (progn calc-num-prefix calc-fix-notation) ) + ( "SCI" calc-sci-notation + (progn calc-num-prefix calc-sci-notation) ) + ( "ENG" calc-eng-notation + (progn calc-num-prefix calc-eng-notation) ) + ( "GRP" calc-group-digits "\C-u-3\excalc-group-digits\r" ) + ( "" nil ) ) + ( ( "RAD" calc-radians-mode ) + ( "DEG" calc-degrees-mode ) + ( "FRAC" calc-frac-mode ) + ( "POLR" calc-polar-mode ) + ( "SYMB" calc-symbolic-mode ) + ( "PREC" calc-precision ) ) + ( ( "SWAP" calc-roll-down ) + ( "RLL3" (progn 3 calc-roll-up) (progn 3 calc-roll-down) ) + ( "RLL4" (progn 4 calc-roll-up) (progn 4 calc-roll-down) ) + ( "OVER" calc-over ) + ( "STO" calc-keypad-store ) + ( "RCL" calc-keypad-recall ) ) ) +) + diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el new file mode 100644 index 0000000000..4b897fa53f --- /dev/null +++ b/lisp/calc/calc-lang.el @@ -0,0 +1,1151 @@ +;; Calculator for GNU Emacs, part II [calc-lang.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-lang () nil) + + +;;; Alternate entry/display languages. + +(defun calc-set-language (lang &optional option no-refresh) + (setq math-expr-opers (or (get lang 'math-oper-table) math-standard-opers) + math-expr-function-mapping (get lang 'math-function-table) + math-expr-variable-mapping (get lang 'math-variable-table) + calc-language-input-filter (get lang 'math-input-filter) + calc-language-output-filter (get lang 'math-output-filter) + calc-vector-brackets (or (get lang 'math-vector-brackets) "[]") + calc-complex-format (get lang 'math-complex-format) + calc-radix-formatter (get lang 'math-radix-formatter) + calc-function-open (or (get lang 'math-function-open) "(") + calc-function-close (or (get lang 'math-function-close) ")")) + (if no-refresh + (setq calc-language lang + calc-language-option option) + (calc-change-mode '(calc-language calc-language-option) + (list lang option) t)) +) + +(defun calc-normal-language () + (interactive) + (calc-wrapper + (calc-set-language nil) + (message "Normal language mode.")) +) + +(defun calc-flat-language () + (interactive) + (calc-wrapper + (calc-set-language 'flat) + (message "Flat language mode (all stack entries shown on one line).")) +) + +(defun calc-big-language () + (interactive) + (calc-wrapper + (calc-set-language 'big) + (message "\"Big\" language mode.")) +) + +(defun calc-unformatted-language () + (interactive) + (calc-wrapper + (calc-set-language 'unform) + (message "Unformatted language mode.")) +) + + +(defun calc-c-language () + (interactive) + (calc-wrapper + (calc-set-language 'c) + (message "`C' language mode.")) +) + +(put 'c 'math-oper-table + '( ( "u+" ident -1 1000 ) + ( "u-" neg -1 1000 ) + ( "u!" calcFunc-lnot -1 1000 ) + ( "~" calcFunc-not -1 1000 ) + ( "*" * 190 191 ) + ( "/" / 190 191 ) + ( "%" % 190 191 ) + ( "+" + 180 181 ) + ( "-" - 180 181 ) + ( "<<" calcFunc-lsh 170 171 ) + ( ">>" calcFunc-rsh 170 171 ) + ( "<" calcFunc-lt 160 161 ) + ( ">" calcFunc-gt 160 161 ) + ( "<=" calcFunc-leq 160 161 ) + ( ">=" calcFunc-geq 160 161 ) + ( "==" calcFunc-eq 150 151 ) + ( "!=" calcFunc-neq 150 151 ) + ( "&" calcFunc-and 140 141 ) + ( "^" calcFunc-xor 131 130 ) + ( "|" calcFunc-or 120 121 ) + ( "&&" calcFunc-land 110 111 ) + ( "||" calcFunc-lor 100 101 ) + ( "?" (math-read-if) 91 90 ) + ( "!!!" calcFunc-pnot -1 88 ) + ( "&&&" calcFunc-pand 85 86 ) + ( "|||" calcFunc-por 75 76 ) + ( "=" calcFunc-assign 51 50 ) + ( ":=" calcFunc-assign 51 50 ) + ( "::" calcFunc-condition 45 46 ) +)) ; should support full assignments + +(put 'c 'math-function-table + '( ( acos . calcFunc-arccos ) + ( acosh . calcFunc-arccosh ) + ( asin . calcFunc-arcsin ) + ( asinh . calcFunc-arcsinh ) + ( atan . calcFunc-arctan ) + ( atan2 . calcFunc-arctan2 ) + ( atanh . calcFunc-arctanh ) +)) + +(put 'c 'math-variable-table + '( ( M_PI . var-pi ) + ( M_E . var-e ) +)) + +(put 'c 'math-vector-brackets "{}") + +(put 'c 'math-radix-formatter + (function (lambda (r s) + (if (= r 16) (format "0x%s" s) + (if (= r 8) (format "0%s" s) + (format "%d#%s" r s)))))) + + +(defun calc-pascal-language (n) + (interactive "P") + (calc-wrapper + (and n (setq n (prefix-numeric-value n))) + (calc-set-language 'pascal n) + (message (if (and n (/= n 0)) + (if (> n 0) + "Pascal language mode (all uppercase)." + "Pascal language mode (all lowercase).") + "Pascal language mode."))) +) + +(put 'pascal 'math-oper-table + '( ( "not" calcFunc-lnot -1 1000 ) + ( "*" * 190 191 ) + ( "/" / 190 191 ) + ( "and" calcFunc-and 190 191 ) + ( "div" calcFunc-idiv 190 191 ) + ( "mod" % 190 191 ) + ( "u+" ident -1 185 ) + ( "u-" neg -1 185 ) + ( "+" + 180 181 ) + ( "-" - 180 181 ) + ( "or" calcFunc-or 180 181 ) + ( "xor" calcFunc-xor 180 181 ) + ( "shl" calcFunc-lsh 180 181 ) + ( "shr" calcFunc-rsh 180 181 ) + ( "in" calcFunc-in 160 161 ) + ( "<" calcFunc-lt 160 161 ) + ( ">" calcFunc-gt 160 161 ) + ( "<=" calcFunc-leq 160 161 ) + ( ">=" calcFunc-geq 160 161 ) + ( "=" calcFunc-eq 160 161 ) + ( "<>" calcFunc-neq 160 161 ) + ( "!!!" calcFunc-pnot -1 85 ) + ( "&&&" calcFunc-pand 80 81 ) + ( "|||" calcFunc-por 75 76 ) + ( ":=" calcFunc-assign 51 50 ) + ( "::" calcFunc-condition 45 46 ) +)) + +(put 'pascal 'math-input-filter 'calc-input-case-filter) +(put 'pascal 'math-output-filter 'calc-output-case-filter) + +(put 'pascal 'math-radix-formatter + (function (lambda (r s) + (if (= r 16) (format "$%s" s) + (format "%d#%s" r s))))) + +(defun calc-input-case-filter (str) + (cond ((or (null calc-language-option) (= calc-language-option 0)) + str) + (t + (downcase str))) +) + +(defun calc-output-case-filter (str) + (cond ((or (null calc-language-option) (= calc-language-option 0)) + str) + ((> calc-language-option 0) + (upcase str)) + (t + (downcase str))) +) + + +(defun calc-fortran-language (n) + (interactive "P") + (calc-wrapper + (and n (setq n (prefix-numeric-value n))) + (calc-set-language 'fortran n) + (message (if (and n (/= n 0)) + (if (> n 0) + "FORTRAN language mode (all uppercase)." + "FORTRAN language mode (all lowercase).") + "FORTRAN language mode."))) +) + +(put 'fortran 'math-oper-table + '( ( "u/" (math-parse-fortran-vector) -1 1 ) + ( "/" (math-parse-fortran-vector-end) 1 -1 ) + ( "**" ^ 201 200 ) + ( "u+" ident -1 191 ) + ( "u-" neg -1 191 ) + ( "*" * 190 191 ) + ( "/" / 190 191 ) + ( "+" + 180 181 ) + ( "-" - 180 181 ) + ( ".LT." calcFunc-lt 160 161 ) + ( ".GT." calcFunc-gt 160 161 ) + ( ".LE." calcFunc-leq 160 161 ) + ( ".GE." calcFunc-geq 160 161 ) + ( ".EQ." calcFunc-eq 160 161 ) + ( ".NE." calcFunc-neq 160 161 ) + ( ".NOT." calcFunc-lnot -1 121 ) + ( ".AND." calcFunc-land 110 111 ) + ( ".OR." calcFunc-lor 100 101 ) + ( "!!!" calcFunc-pnot -1 85 ) + ( "&&&" calcFunc-pand 80 81 ) + ( "|||" calcFunc-por 75 76 ) + ( "=" calcFunc-assign 51 50 ) + ( ":=" calcFunc-assign 51 50 ) + ( "::" calcFunc-condition 45 46 ) +)) + +(put 'fortran 'math-vector-brackets "//") + +(put 'fortran 'math-function-table + '( ( acos . calcFunc-arccos ) + ( acosh . calcFunc-arccosh ) + ( aimag . calcFunc-im ) + ( aint . calcFunc-ftrunc ) + ( asin . calcFunc-arcsin ) + ( asinh . calcFunc-arcsinh ) + ( atan . calcFunc-arctan ) + ( atan2 . calcFunc-arctan2 ) + ( atanh . calcFunc-arctanh ) + ( conjg . calcFunc-conj ) + ( log . calcFunc-ln ) + ( nint . calcFunc-round ) + ( real . calcFunc-re ) +)) + +(put 'fortran 'math-input-filter 'calc-input-case-filter) +(put 'fortran 'math-output-filter 'calc-output-case-filter) + +(defun math-parse-fortran-vector (op) + (let ((math-parsing-fortran-vector '(end . "\000"))) + (prog1 + (math-read-brackets t "]") + (setq exp-token (car math-parsing-fortran-vector) + exp-data (cdr math-parsing-fortran-vector)))) +) + +(defun math-parse-fortran-vector-end (x op) + (if math-parsing-fortran-vector + (progn + (setq math-parsing-fortran-vector (cons exp-token exp-data) + exp-token 'end + exp-data "\000") + x) + (throw 'syntax "Unmatched closing `/'")) +) +(setq math-parsing-fortran-vector nil) + +(defun math-parse-fortran-subscr (sym args) + (setq sym (math-build-var-name sym)) + (while args + (setq sym (list 'calcFunc-subscr sym (car args)) + args (cdr args))) + sym +) + + +(defun calc-tex-language (n) + (interactive "P") + (calc-wrapper + (and n (setq n (prefix-numeric-value n))) + (calc-set-language 'tex n) + (message (if (and n (/= n 0)) + (if (> n 0) + "TeX language mode with \\hbox{func}(\\hbox{var})." + "TeX language mode with \\func{\\hbox{var}}.") + "TeX language mode."))) +) + +(put 'tex 'math-oper-table + '( ( "u+" ident -1 1000 ) + ( "u-" neg -1 1000 ) + ( "\\hat" calcFunc-hat -1 950 ) + ( "\\check" calcFunc-check -1 950 ) + ( "\\tilde" calcFunc-tilde -1 950 ) + ( "\\acute" calcFunc-acute -1 950 ) + ( "\\grave" calcFunc-grave -1 950 ) + ( "\\dot" calcFunc-dot -1 950 ) + ( "\\ddot" calcFunc-dotdot -1 950 ) + ( "\\breve" calcFunc-breve -1 950 ) + ( "\\bar" calcFunc-bar -1 950 ) + ( "\\vec" calcFunc-Vec -1 950 ) + ( "\\underline" calcFunc-under -1 950 ) + ( "u|" calcFunc-abs -1 0 ) + ( "|" closing 0 -1 ) + ( "\\lfloor" calcFunc-floor -1 0 ) + ( "\\rfloor" closing 0 -1 ) + ( "\\lceil" calcFunc-ceil -1 0 ) + ( "\\rceil" closing 0 -1 ) + ( "\\pm" sdev 300 300 ) + ( "!" calcFunc-fact 210 -1 ) + ( "^" ^ 201 200 ) + ( "_" calcFunc-subscr 201 200 ) + ( "\\times" * 191 190 ) + ( "*" * 191 190 ) + ( "2x" * 191 190 ) + ( "+" + 180 181 ) + ( "-" - 180 181 ) + ( "\\over" / 170 171 ) + ( "/" / 170 171 ) + ( "\\choose" calcFunc-choose 170 171 ) + ( "\\mod" % 170 171 ) + ( "<" calcFunc-lt 160 161 ) + ( ">" calcFunc-gt 160 161 ) + ( "\\leq" calcFunc-leq 160 161 ) + ( "\\geq" calcFunc-geq 160 161 ) + ( "=" calcFunc-eq 160 161 ) + ( "\\neq" calcFunc-neq 160 161 ) + ( "\\ne" calcFunc-neq 160 161 ) + ( "\\lnot" calcFunc-lnot -1 121 ) + ( "\\land" calcFunc-land 110 111 ) + ( "\\lor" calcFunc-lor 100 101 ) + ( "?" (math-read-if) 91 90 ) + ( "!!!" calcFunc-pnot -1 85 ) + ( "&&&" calcFunc-pand 80 81 ) + ( "|||" calcFunc-por 75 76 ) + ( "\\gets" calcFunc-assign 51 50 ) + ( ":=" calcFunc-assign 51 50 ) + ( "::" calcFunc-condition 45 46 ) + ( "\\to" calcFunc-evalto 40 41 ) + ( "\\to" calcFunc-evalto 40 -1 ) + ( "=>" calcFunc-evalto 40 41 ) + ( "=>" calcFunc-evalto 40 -1 ) +)) + +(put 'tex 'math-function-table + '( ( \\arccos . calcFunc-arccos ) + ( \\arcsin . calcFunc-arcsin ) + ( \\arctan . calcFunc-arctan ) + ( \\arg . calcFunc-arg ) + ( \\cos . calcFunc-cos ) + ( \\cosh . calcFunc-cosh ) + ( \\det . calcFunc-det ) + ( \\exp . calcFunc-exp ) + ( \\gcd . calcFunc-gcd ) + ( \\ln . calcFunc-ln ) + ( \\log . calcFunc-log10 ) + ( \\max . calcFunc-max ) + ( \\min . calcFunc-min ) + ( \\tan . calcFunc-tan ) + ( \\sin . calcFunc-sin ) + ( \\sinh . calcFunc-sinh ) + ( \\sqrt . calcFunc-sqrt ) + ( \\tanh . calcFunc-tanh ) + ( \\phi . calcFunc-totient ) + ( \\mu . calcFunc-moebius ) +)) + +(put 'tex 'math-variable-table + '( ( \\pi . var-pi ) + ( \\infty . var-inf ) + ( \\infty . var-uinf ) + ( \\phi . var-phi ) + ( \\gamma . var-gamma ) + ( \\sum . (math-parse-tex-sum calcFunc-sum) ) + ( \\prod . (math-parse-tex-sum calcFunc-prod) ) +)) + +(put 'tex 'math-complex-format 'i) + +(defun math-parse-tex-sum (f val) + (let (low high save) + (or (equal exp-data "_") (throw 'syntax "Expected `_'")) + (math-read-token) + (setq save exp-old-pos) + (setq low (math-read-factor)) + (or (eq (car-safe low) 'calcFunc-eq) + (progn + (setq exp-old-pos (1+ save)) + (throw 'syntax "Expected equation"))) + (or (equal exp-data "^") (throw 'syntax "Expected `^'")) + (math-read-token) + (setq high (math-read-factor)) + (list (nth 2 f) (math-read-factor) (nth 1 low) (nth 2 low) high)) +) + +(defun math-tex-input-filter (str) ; allow parsing of 123\,456\,789. + (while (string-match "[0-9]\\\\,[0-9]" str) + (setq str (concat (substring str 0 (1+ (match-beginning 0))) + (substring str (1- (match-end 0)))))) + str +) +(put 'tex 'math-input-filter 'math-tex-input-filter) + + +(defun calc-eqn-language (n) + (interactive "P") + (calc-wrapper + (calc-set-language 'eqn) + (message "Eqn language mode.")) +) + +(put 'eqn 'math-oper-table + '( ( "u+" ident -1 1000 ) + ( "u-" neg -1 1000 ) + ( "prime" (math-parse-eqn-prime) 950 -1 ) + ( "prime" calcFunc-Prime 950 -1 ) + ( "dot" calcFunc-dot 950 -1 ) + ( "dotdot" calcFunc-dotdot 950 -1 ) + ( "hat" calcFunc-hat 950 -1 ) + ( "tilde" calcFunc-tilde 950 -1 ) + ( "vec" calcFunc-Vec 950 -1 ) + ( "dyad" calcFunc-dyad 950 -1 ) + ( "bar" calcFunc-bar 950 -1 ) + ( "under" calcFunc-under 950 -1 ) + ( "sub" calcFunc-subscr 931 930 ) + ( "sup" ^ 921 920 ) + ( "sqrt" calcFunc-sqrt -1 910 ) + ( "over" / 900 901 ) + ( "u|" calcFunc-abs -1 0 ) + ( "|" closing 0 -1 ) + ( "left floor" calcFunc-floor -1 0 ) + ( "right floor" closing 0 -1 ) + ( "left ceil" calcFunc-ceil -1 0 ) + ( "right ceil" closing 0 -1 ) + ( "+-" sdev 300 300 ) + ( "!" calcFunc-fact 210 -1 ) + ( "times" * 191 190 ) + ( "*" * 191 190 ) + ( "2x" * 191 190 ) + ( "/" / 180 181 ) + ( "%" % 180 181 ) + ( "+" + 170 171 ) + ( "-" - 170 171 ) + ( "<" calcFunc-lt 160 161 ) + ( ">" calcFunc-gt 160 161 ) + ( "<=" calcFunc-leq 160 161 ) + ( ">=" calcFunc-geq 160 161 ) + ( "=" calcFunc-eq 160 161 ) + ( "==" calcFunc-eq 160 161 ) + ( "!=" calcFunc-neq 160 161 ) + ( "u!" calcFunc-lnot -1 121 ) + ( "&&" calcFunc-land 110 111 ) + ( "||" calcFunc-lor 100 101 ) + ( "?" (math-read-if) 91 90 ) + ( "!!!" calcFunc-pnot -1 85 ) + ( "&&&" calcFunc-pand 80 81 ) + ( "|||" calcFunc-por 75 76 ) + ( "<-" calcFunc-assign 51 50 ) + ( ":=" calcFunc-assign 51 50 ) + ( "::" calcFunc-condition 45 46 ) + ( "->" calcFunc-evalto 40 41 ) + ( "->" calcFunc-evalto 40 -1 ) + ( "=>" calcFunc-evalto 40 41 ) + ( "=>" calcFunc-evalto 40 -1 ) +)) + +(put 'eqn 'math-function-table + '( ( arc\ cos . calcFunc-arccos ) + ( arc\ cosh . calcFunc-arccosh ) + ( arc\ sin . calcFunc-arcsin ) + ( arc\ sinh . calcFunc-arcsinh ) + ( arc\ tan . calcFunc-arctan ) + ( arc\ tanh . calcFunc-arctanh ) + ( GAMMA . calcFunc-gamma ) + ( phi . calcFunc-totient ) + ( mu . calcFunc-moebius ) + ( matrix . (math-parse-eqn-matrix) ) +)) + +(put 'eqn 'math-variable-table + '( ( inf . var-uinf ) +)) + +(put 'eqn 'math-complex-format 'i) + +(defun math-parse-eqn-matrix (f sym) + (let ((vec nil)) + (while (assoc exp-data '(("ccol") ("lcol") ("rcol"))) + (math-read-token) + (or (equal exp-data calc-function-open) + (throw 'syntax "Expected `{'")) + (math-read-token) + (setq vec (cons (cons 'vec (math-read-expr-list)) vec)) + (or (equal exp-data calc-function-close) + (throw 'syntax "Expected `}'")) + (math-read-token)) + (or (equal exp-data calc-function-close) + (throw 'syntax "Expected `}'")) + (math-read-token) + (math-transpose (cons 'vec (nreverse vec)))) +) + +(defun math-parse-eqn-prime (x sym) + (if (eq (car-safe x) 'var) + (if (equal exp-data calc-function-open) + (progn + (math-read-token) + (let ((args (if (or (equal exp-data calc-function-close) + (eq exp-token 'end)) + nil + (math-read-expr-list)))) + (if (not (or (equal exp-data calc-function-close) + (eq exp-token 'end))) + (throw 'syntax "Expected `)'")) + (math-read-token) + (cons (intern (format "calcFunc-%s'" (nth 1 x))) args))) + (list 'var + (intern (concat (symbol-name (nth 1 x)) "'")) + (intern (concat (symbol-name (nth 2 x)) "'")))) + (list 'calcFunc-Prime x)) +) + + +(defun calc-mathematica-language () + (interactive) + (calc-wrapper + (calc-set-language 'math) + (message "Mathematica language mode.")) +) + +(put 'math 'math-oper-table + '( ( "[[" (math-read-math-subscr) 250 -1 ) + ( "!" calcFunc-fact 210 -1 ) + ( "!!" calcFunc-dfact 210 -1 ) + ( "^" ^ 201 200 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) + ( "/" / 195 196 ) + ( "*" * 190 191 ) + ( "2x" * 190 191 ) + ( "+" + 180 181 ) + ( "-" - 180 181 ) + ( "<" calcFunc-lt 160 161 ) + ( ">" calcFunc-gt 160 161 ) + ( "<=" calcFunc-leq 160 161 ) + ( ">=" calcFunc-geq 160 161 ) + ( "==" calcFunc-eq 150 151 ) + ( "!=" calcFunc-neq 150 151 ) + ( "u!" calcFunc-lnot -1 121 ) + ( "&&" calcFunc-land 110 111 ) + ( "||" calcFunc-lor 100 101 ) + ( "!!!" calcFunc-pnot -1 85 ) + ( "&&&" calcFunc-pand 80 81 ) + ( "|||" calcFunc-por 75 76 ) + ( ":=" calcFunc-assign 51 50 ) + ( "=" calcFunc-assign 51 50 ) + ( "->" calcFunc-assign 51 50 ) + ( ":>" calcFunc-assign 51 50 ) + ( "::" calcFunc-condition 45 46 ) +)) + +(put 'math 'math-function-table + '( ( Abs . calcFunc-abs ) + ( ArcCos . calcFunc-arccos ) + ( ArcCosh . calcFunc-arccosh ) + ( ArcSin . calcFunc-arcsin ) + ( ArcSinh . calcFunc-arcsinh ) + ( ArcTan . calcFunc-arctan ) + ( ArcTanh . calcFunc-arctanh ) + ( Arg . calcFunc-arg ) + ( Binomial . calcFunc-choose ) + ( Ceiling . calcFunc-ceil ) + ( Conjugate . calcFunc-conj ) + ( Cos . calcFunc-cos ) + ( Cosh . calcFunc-cosh ) + ( D . calcFunc-deriv ) + ( Dt . calcFunc-tderiv ) + ( Det . calcFunc-det ) + ( Exp . calcFunc-exp ) + ( EulerPhi . calcFunc-totient ) + ( Floor . calcFunc-floor ) + ( Gamma . calcFunc-gamma ) + ( GCD . calcFunc-gcd ) + ( If . calcFunc-if ) + ( Im . calcFunc-im ) + ( Inverse . calcFunc-inv ) + ( Integrate . calcFunc-integ ) + ( Join . calcFunc-vconcat ) + ( LCM . calcFunc-lcm ) + ( Log . calcFunc-ln ) + ( Max . calcFunc-max ) + ( Min . calcFunc-min ) + ( Mod . calcFunc-mod ) + ( MoebiusMu . calcFunc-moebius ) + ( Random . calcFunc-random ) + ( Round . calcFunc-round ) + ( Re . calcFunc-re ) + ( Sign . calcFunc-sign ) + ( Sin . calcFunc-sin ) + ( Sinh . calcFunc-sinh ) + ( Sqrt . calcFunc-sqrt ) + ( Tan . calcFunc-tan ) + ( Tanh . calcFunc-tanh ) + ( Transpose . calcFunc-trn ) + ( Length . calcFunc-vlen ) +)) + +(put 'math 'math-variable-table + '( ( I . var-i ) + ( Pi . var-pi ) + ( E . var-e ) + ( GoldenRatio . var-phi ) + ( EulerGamma . var-gamma ) + ( Infinity . var-inf ) + ( ComplexInfinity . var-uinf ) + ( Indeterminate . var-nan ) +)) + +(put 'math 'math-vector-brackets "{}") +(put 'math 'math-complex-format 'I) +(put 'math 'math-function-open "[") +(put 'math 'math-function-close "]") + +(put 'math 'math-radix-formatter + (function (lambda (r s) (format "%d^^%s" r s)))) + +(defun math-read-math-subscr (x op) + (let ((idx (math-read-expr-level 0))) + (or (and (equal exp-data "]") + (progn + (math-read-token) + (equal exp-data "]"))) + (throw 'syntax "Expected ']]'")) + (math-read-token) + (list 'calcFunc-subscr x idx)) +) + + +(defun calc-maple-language () + (interactive) + (calc-wrapper + (calc-set-language 'maple) + (message "Maple language mode.")) +) + +(put 'maple 'math-oper-table + '( ( "matrix" ident -1 300 ) + ( "MATRIX" ident -1 300 ) + ( "!" calcFunc-fact 210 -1 ) + ( "^" ^ 201 200 ) + ( "**" ^ 201 200 ) + ( "u+" ident -1 197 ) + ( "u-" neg -1 197 ) + ( "/" / 191 192 ) + ( "*" * 191 192 ) + ( "intersect" calcFunc-vint 191 192 ) + ( "+" + 180 181 ) + ( "-" - 180 181 ) + ( "union" calcFunc-vunion 180 181 ) + ( "minus" calcFunc-vdiff 180 181 ) + ( "mod" % 170 170 ) + ( ".." (math-read-maple-dots) 165 165 ) + ( "\\dots" (math-read-maple-dots) 165 165 ) + ( "<" calcFunc-lt 160 160 ) + ( ">" calcFunc-gt 160 160 ) + ( "<=" calcFunc-leq 160 160 ) + ( ">=" calcFunc-geq 160 160 ) + ( "=" calcFunc-eq 160 160 ) + ( "<>" calcFunc-neq 160 160 ) + ( "not" calcFunc-lnot -1 121 ) + ( "and" calcFunc-land 110 111 ) + ( "or" calcFunc-lor 100 101 ) + ( "!!!" calcFunc-pnot -1 85 ) + ( "&&&" calcFunc-pand 80 81 ) + ( "|||" calcFunc-por 75 76 ) + ( ":=" calcFunc-assign 51 50 ) + ( "::" calcFunc-condition 45 46 ) +)) + +(put 'maple 'math-function-table + '( ( bernoulli . calcFunc-bern ) + ( binomial . calcFunc-choose ) + ( diff . calcFunc-deriv ) + ( GAMMA . calcFunc-gamma ) + ( ifactor . calcFunc-prfac ) + ( igcd . calcFunc-gcd ) + ( ilcm . calcFunc-lcm ) + ( int . calcFunc-integ ) + ( modp . % ) + ( irem . % ) + ( iquo . calcFunc-idiv ) + ( isprime . calcFunc-prime ) + ( length . calcFunc-vlen ) + ( member . calcFunc-in ) + ( crossprod . calcFunc-cross ) + ( inverse . calcFunc-inv ) + ( trace . calcFunc-tr ) + ( transpose . calcFunc-trn ) + ( vectdim . calcFunc-vlen ) +)) + +(put 'maple 'math-variable-table + '( ( I . var-i ) + ( Pi . var-pi ) + ( E . var-e ) + ( infinity . var-inf ) + ( infinity . var-uinf ) + ( infinity . var-nan ) +)) + +(put 'maple 'math-complex-format 'I) + +(defun math-read-maple-dots (x op) + (list 'intv 3 x (math-read-expr-level (nth 3 op))) +) + + + + + +(defun math-read-big-rec (h1 v1 h2 v2 &optional baseline prec short) + (or prec (setq prec 0)) + + ;; Clip whitespace above or below. + (while (and (< v1 v2) (math-read-big-emptyp h1 v1 h2 (1+ v1))) + (setq v1 (1+ v1))) + (while (and (< v1 v2) (math-read-big-emptyp h1 (1- v2) h2 v2)) + (setq v2 (1- v2))) + + ;; If formula is a single line high, normal parser can handle it. + (if (<= v2 (1+ v1)) + (if (or (<= v2 v1) + (> h1 (length (setq v2 (nth v1 lines))))) + (math-read-big-error h1 v1) + (setq the-baseline v1 + the-h2 h2 + v2 (nth v1 lines) + h2 (math-read-expr (substring v2 h1 (min h2 (length v2))))) + (if (eq (car-safe h2) 'error) + (math-read-big-error (+ h1 (nth 1 h2)) v1 (nth 2 h2)) + h2)) + + ;; Clip whitespace at left or right. + (while (and (< h1 h2) (math-read-big-emptyp h1 v1 (1+ h1) v2)) + (setq h1 (1+ h1))) + (while (and (< h1 h2) (math-read-big-emptyp (1- h2) v1 h2 v2)) + (setq h2 (1- h2))) + + ;; Scan to find widest left-justified "----" in the region. + (let* ((widest nil) + (widest-h2 0) + (lines-v1 (nthcdr v1 lines)) + (p lines-v1) + (v v1) + (other-v nil) + other-char line len h) + (while (< v v2) + (setq line (car p) + len (min h2 (length line))) + (and (< h1 len) + (/= (aref line h1) ?\ ) + (if (and (= (aref line h1) ?\-) + ;; Make sure it's not a minus sign. + (or (and (< (1+ h1) len) (= (aref line (1+ h1)) ?\-)) + (/= (math-read-big-char h1 (1- v)) ?\ ) + (/= (math-read-big-char h1 (1+ v)) ?\ ))) + (progn + (setq h h1) + (while (and (< (setq h (1+ h)) len) + (= (aref line h) ?\-))) + (if (> h widest-h2) + (setq widest v + widest-h2 h))) + (or other-v (setq other-v v other-char (aref line h1))))) + (setq v (1+ v) + p (cdr p))) + + (cond ((not (setq v other-v)) + (math-read-big-error h1 v1)) ; Should never happen! + + ;; Quotient. + (widest + (setq h widest-h2 + v widest) + (let ((num (math-read-big-rec h1 v1 h v)) + (den (math-read-big-rec h1 (1+ v) h v2))) + (setq p (if (and (math-integerp num) (math-integerp den)) + (math-make-frac num den) + (list '/ num den))))) + + ;; Big radical sign. + ((= other-char ?\\) + (or (= (math-read-big-char (1+ h1) v) ?\|) + (math-read-big-error (1+ h1) v "Malformed root sign")) + (math-read-big-emptyp h1 v1 (1+ h1) v nil t) + (while (= (math-read-big-char (1+ h1) (setq v (1- v))) ?\|)) + (or (= (math-read-big-char (setq h (+ h1 2)) v) ?\_) + (math-read-big-error h v "Malformed root sign")) + (while (= (math-read-big-char (setq h (1+ h)) v) ?\_)) + (math-read-big-emptyp h1 v1 (1+ h1) v nil t) + (math-read-big-emptyp h1 (1+ other-v) h v2 nil t) + (setq p (list 'calcFunc-sqrt (math-read-big-rec + (+ h1 2) (1+ v) + h (1+ other-v) baseline)) + v the-baseline)) + + ;; Small radical sign. + ((and (= other-char ?V) + (= (math-read-big-char (1+ h1) (1- v)) ?\_)) + (setq h (1+ h1)) + (math-read-big-emptyp h1 v1 h (1- v) nil t) + (math-read-big-emptyp h1 (1+ v) h v2 nil t) + (math-read-big-emptyp h1 v1 (1+ h1) v nil t) + (while (= (math-read-big-char (setq h (1+ h)) (1- v)) ?\_)) + (setq p (list 'calcFunc-sqrt (math-read-big-rec + (1+ h1) v h (1+ v) t)) + v the-baseline)) + + ;; Binomial coefficient. + ((and (= other-char ?\() + (= (math-read-big-char (1+ h1) v) ?\ ) + (= (string-match "( *)" (nth v lines) h1) h1)) + (setq h (match-end 0)) + (math-read-big-emptyp h1 v1 (1+ h1) v nil t) + (math-read-big-emptyp h1 (1+ v) (1+ h1) v2 nil t) + (math-read-big-emptyp (1- h) v1 h v nil t) + (math-read-big-emptyp (1- h) (1+ v) h v2 nil t) + (setq p (list 'calcFunc-choose + (math-read-big-rec (1+ h1) v1 (1- h) v) + (math-read-big-rec (1+ h1) (1+ v) + (1- h) v2)))) + + ;; Minus sign. + ((= other-char ?\-) + (setq p (list 'neg (math-read-big-rec (1+ h1) v1 h2 v2 v 250 t)) + v the-baseline + h the-h2)) + + ;; Parentheses. + ((= other-char ?\() + (math-read-big-emptyp h1 v1 (1+ h1) v nil t) + (math-read-big-emptyp h1 (1+ v) (1+ h1) v2 nil t) + (setq h (math-read-big-balance (1+ h1) v "(" t)) + (math-read-big-emptyp (1- h) v1 h v nil t) + (math-read-big-emptyp (1- h) (1+ v) h v2 nil t) + (let ((sep (math-read-big-char (1- h) v)) + hmid) + (if (= sep ?\.) + (setq h (1+ h))) + (if (= sep ?\]) + (math-read-big-error (1- h) v "Expected `)'")) + (if (= sep ?\)) + (setq p (math-read-big-rec (1+ h1) v1 (1- h) v2 v)) + (setq hmid (math-read-big-balance h v "(") + p (list p (math-read-big-rec h v1 (1- hmid) v2 v)) + h hmid) + (cond ((= sep ?\.) + (setq p (cons 'intv (cons (if (= (math-read-big-char + (1- h) v) + ?\)) + 0 1) + p)))) + ((= (math-read-big-char (1- h) v) ?\]) + (math-read-big-error (1- h) v "Expected `)'")) + ((= sep ?\,) + (or (and (math-realp (car p)) (math-realp (nth 1 p))) + (math-read-big-error + h1 v "Complex components must be real")) + (setq p (cons 'cplx p))) + ((= sep ?\;) + (or (and (math-realp (car p)) (math-anglep (nth 1 p))) + (math-read-big-error + h1 v "Complex components must be real")) + (setq p (cons 'polar p))))))) + + ;; Matrix. + ((and (= other-char ?\[) + (or (= (math-read-big-char (setq h h1) (1+ v)) ?\[) + (= (math-read-big-char (setq h (1+ h)) v) ?\[) + (and (= (math-read-big-char h v) ?\ ) + (= (math-read-big-char (setq h (1+ h)) v) ?\[))) + (= (math-read-big-char h (1+ v)) ?\[)) + (math-read-big-emptyp h1 v1 h v nil t) + (let ((vtop v) + (hleft h) + (hright nil)) + (setq p nil) + (while (progn + (setq h (math-read-big-balance (1+ hleft) v "[")) + (if hright + (or (= h hright) + (math-read-big-error hright v "Expected `]'")) + (setq hright h)) + (setq p (cons (math-read-big-rec + hleft v h (1+ v)) p)) + (and (memq (math-read-big-char h v) '(?\ ?\,)) + (= (math-read-big-char hleft (1+ v)) ?\[))) + (setq v (1+ v))) + (or (= hleft h1) + (progn + (if (= (math-read-big-char h v) ?\ ) + (setq h (1+ h))) + (and (= (math-read-big-char h v) ?\]) + (setq h (1+ h)))) + (math-read-big-error (1- h) v "Expected `]'")) + (if (= (math-read-big-char h vtop) ?\,) + (setq h (1+ h))) + (math-read-big-emptyp h1 (1+ v) (1- h) v2 nil t) + (setq v (+ vtop (/ (- v vtop) 2)) + p (cons 'vec (nreverse p))))) + + ;; Square brackets. + ((= other-char ?\[) + (math-read-big-emptyp h1 v1 (1+ h1) v nil t) + (math-read-big-emptyp h1 (1+ v) (1+ h1) v2 nil t) + (setq p nil + h (1+ h1)) + (while (progn + (setq widest (math-read-big-balance h v "[" t)) + (math-read-big-emptyp (1- h) v1 h v nil t) + (math-read-big-emptyp (1- h) (1+ v) h v2 nil t) + (setq p (cons (math-read-big-rec + h v1 (1- widest) v2 v) p) + h widest) + (= (math-read-big-char (1- h) v) ?\,))) + (setq widest (math-read-big-char (1- h) v)) + (if (or (memq widest '(?\; ?\))) + (and (eq widest ?\.) (cdr p))) + (math-read-big-error (1- h) v "Expected `]'")) + (if (= widest ?\.) + (setq h (1+ h) + widest (math-read-big-balance h v "[") + p (nconc p (list (math-read-big-big-rec + h v1 (1- widest) v2 v))) + h widest + p (cons 'intv (cons (if (= (math-read-big-char (1- h) v) + ?\]) + 3 2) + p))) + (setq p (cons 'vec (nreverse p))))) + + ;; Date form. + ((= other-char ?\<) + (setq line (nth v lines)) + (string-match ">" line h1) + (setq h (match-end 0)) + (math-read-big-emptyp h1 v1 h v nil t) + (math-read-big-emptyp h1 (1+ v) h v2 nil t) + (setq p (math-read-big-rec h1 v h (1+ v) v))) + + ;; Variable name or function call. + ((or (and (>= other-char ?a) (<= other-char ?z)) + (and (>= other-char ?A) (<= other-char ?Z))) + (setq line (nth v lines)) + (string-match "\\([a-zA-Z'_]+\\) *" line h1) + (setq h (match-end 1) + widest (match-end 0) + p (math-match-substring line 1)) + (math-read-big-emptyp h1 v1 h v nil t) + (math-read-big-emptyp h1 (1+ v) h v2 nil t) + (if (= (math-read-big-char widest v) ?\() + (progn + (setq line (if (string-match "-" p) + (intern p) + (intern (concat "calcFunc-" p))) + h (1+ widest) + p nil) + (math-read-big-emptyp widest v1 h v nil t) + (math-read-big-emptyp widest (1+ v) h v2 nil t) + (while (progn + (setq widest (math-read-big-balance h v "(" t)) + (math-read-big-emptyp (1- h) v1 h v nil t) + (math-read-big-emptyp (1- h) (1+ v) h v2 nil t) + (setq p (cons (math-read-big-rec + h v1 (1- widest) v2 v) p) + h widest) + (= (math-read-big-char (1- h) v) ?\,))) + (or (= (math-read-big-char (1- h) v) ?\)) + (math-read-big-error (1- h) v "Expected `)'")) + (setq p (cons line (nreverse p)))) + (setq p (list 'var + (intern (math-remove-dashes p)) + (if (string-match "-" p) + (intern p) + (intern (concat "var-" p))))))) + + ;; Number. + (t + (setq line (nth v lines)) + (or (= (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\([0-9]+\\(#\\|\\^\\^\\)[0-9a-zA-Z:]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?" line h1) h1) + (math-read-big-error h v "Expected a number")) + (setq h (match-end 0) + p (math-read-number (math-match-substring line 0))) + (math-read-big-emptyp h1 v1 h v nil t) + (math-read-big-emptyp h1 (1+ v) h v2 nil t))) + + ;; Now left term is bounded by h1, v1, h, v2; baseline = v. + (if baseline + (or (= v baseline) + (math-read-big-error h1 v "Inconsistent baseline in formula")) + (setq baseline v)) + + ;; Look for superscripts or subscripts. + (setq line (nth baseline lines) + len (min h2 (length line)) + widest h) + (while (and (< widest len) + (= (aref line widest) ?\ )) + (setq widest (1+ widest))) + (and (>= widest len) (setq widest h2)) + (if (math-read-big-emptyp h v widest v2) + (if (math-read-big-emptyp h v1 widest v) + (setq h widest) + (setq p (list '^ p (math-read-big-rec h v1 widest v)) + h widest)) + (if (math-read-big-emptyp h v1 widest v) + (setq p (list 'calcFunc-subscr p + (math-read-big-rec h v widest v2)) + h widest))) + + ;; Look for an operator name and grab additional terms. + (while (and (< h len) + (if (setq widest (and (math-read-big-emptyp + h v1 (1+ h) v) + (math-read-big-emptyp + h (1+ v) (1+ h) v2) + (string-match "<=\\|>=\\|\\+/-\\|!=\\|&&\\|||\\|:=\\|=>\\|." line h) + (assoc (math-match-substring line 0) + math-standard-opers))) + (and (>= (nth 2 widest) prec) + (setq h (match-end 0))) + (and (not (eq (string-match ",\\|;\\|\\.\\.\\|)\\|\\]\\|:" line h) + h)) + (setq widest '("2x" * 196 195))))) + (cond ((eq (nth 3 widest) -1) + (setq p (list (nth 1 widest) p))) + ((equal (car widest) "?") + (let ((y (math-read-big-rec h v1 h2 v2 baseline nil t))) + (or (= (math-read-big-char the-h2 baseline) ?\:) + (math-read-big-error the-h2 baseline "Expected `:'")) + (setq p (list (nth 1 widest) p y + (math-read-big-rec (1+ the-h2) v1 h2 v2 + baseline (nth 3 widest) t)) + h the-h2))) + (t + (setq p (list (nth 1 widest) p + (math-read-big-rec h v1 h2 v2 + baseline (nth 3 widest) t)) + h the-h2)))) + + ;; Return all relevant information to caller. + (setq the-baseline baseline + the-h2 h) + (or short (= the-h2 h2) + (math-read-big-error h baseline)) + p)) +) + +(defun math-read-big-char (h v) + (or (and (>= h h1) + (< h h2) + (>= v v1) + (< v v2) + (let ((line (nth v lines))) + (and line + (< h (length line)) + (aref line h)))) + ?\ ) +) + +(defun math-read-big-emptyp (eh1 ev1 eh2 ev2 &optional what error) + (and (< ev1 v1) (setq ev1 v1)) + (and (< eh1 h1) (setq eh1 h1)) + (and (> ev2 v2) (setq ev2 v2)) + (and (> eh2 h2) (setq eh2 h2)) + (or what (setq what ?\ )) + (let ((p (nthcdr ev1 lines)) + h) + (while (and (< ev1 ev2) + (progn + (setq h (min eh2 (length (car p)))) + (while (and (>= (setq h (1- h)) eh1) + (= (aref (car p) h) what))) + (and error (>= h eh1) + (math-read-big-error h ev1 (if (stringp error) + error + "Whitespace expected"))) + (< h eh1))) + (setq ev1 (1+ ev1) + p (cdr p))) + (>= ev1 ev2)) +) + +(defun math-read-big-error (h v &optional msg) + (let ((pos 0) + (p lines)) + (while (> v 0) + (setq pos (+ pos 1 (length (car p))) + p (cdr p) + v (1- v))) + (setq h (+ pos (min h (length (car p)))) + err-msg (list 'error h (or msg "Syntax error"))) + (throw 'syntax nil)) +) + +(defun math-read-big-balance (h v what &optional commas) + (let* ((line (nth v lines)) + (len (min h2 (length line))) + (count 1)) + (while (> count 0) + (if (>= h len) + (if what + (math-read-big-error h1 v (format "Unmatched `%s'" what)) + (setq count 0)) + (if (memq (aref line h) '(?\( ?\[)) + (setq count (1+ count)) + (if (if (and commas (= count 1)) + (or (memq (aref line h) '(?\) ?\] ?\, ?\;)) + (and (eq (aref line h) ?\.) + (< (1+ h) len) + (eq (aref line (1+ h)) ?\.))) + (memq (aref line h) '(?\) ?\]))) + (setq count (1- count)))) + (setq h (1+ h)))) + h) +) + + + + diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el new file mode 100644 index 0000000000..1b3ab18e9b --- /dev/null +++ b/lisp/calc/calc-macs.el @@ -0,0 +1,262 @@ +;; Calculator for GNU Emacs, part I [calc-macs.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + +(provide 'calc-macs) + +(defun calc-need-macros () nil) + + +(defmacro calc-record-compilation-date-macro () + (` (setq calc-installed-date (, (concat (current-time-string) + " by " + (user-full-name))))) +) + + +(defmacro calc-wrapper (&rest body) + (list 'calc-do (list 'function (append (list 'lambda ()) body))) +) + +;; We use "point" here to generate slightly smaller byte-code than "t". +(defmacro calc-slow-wrapper (&rest body) + (list 'calc-do (list 'function (append (list 'lambda ()) body)) (point)) +) + + +(defmacro math-showing-full-precision (body) + (list 'let + '((calc-float-format calc-full-float-format)) + body) +) + + +(defmacro math-with-extra-prec (delta &rest body) + (` (math-normalize + (let ((calc-internal-prec (+ calc-internal-prec (, delta)))) + (,@ body)))) +) + + +;;; Faster in-line version zerop, normalized values only. +(defmacro Math-zerop (a) ; [P N] + (` (if (consp (, a)) + (and (not (memq (car (, a)) '(bigpos bigneg))) + (if (eq (car (, a)) 'float) + (eq (nth 1 (, a)) 0) + (math-zerop (, a)))) + (eq (, a) 0))) +) + +(defmacro Math-integer-negp (a) + (` (if (consp (, a)) + (eq (car (, a)) 'bigneg) + (< (, a) 0))) +) + +(defmacro Math-integer-posp (a) + (` (if (consp (, a)) + (eq (car (, a)) 'bigpos) + (> (, a) 0))) +) + + +(defmacro Math-negp (a) + (` (if (consp (, a)) + (or (eq (car (, a)) 'bigneg) + (and (not (eq (car (, a)) 'bigpos)) + (if (memq (car (, a)) '(frac float)) + (Math-integer-negp (nth 1 (, a))) + (math-negp (, a))))) + (< (, a) 0))) +) + + +(defmacro Math-looks-negp (a) ; [P x] [Public] + (` (or (Math-negp (, a)) + (and (consp (, a)) (or (eq (car (, a)) 'neg) + (and (memq (car (, a)) '(* /)) + (or (math-looks-negp (nth 1 (, a))) + (math-looks-negp (nth 2 (, a))))))))) +) + + +(defmacro Math-posp (a) + (` (if (consp (, a)) + (or (eq (car (, a)) 'bigpos) + (and (not (eq (car (, a)) 'bigneg)) + (if (memq (car (, a)) '(frac float)) + (Math-integer-posp (nth 1 (, a))) + (math-posp (, a))))) + (> (, a) 0))) +) + + +(defmacro Math-integerp (a) + (` (or (not (consp (, a))) + (memq (car (, a)) '(bigpos bigneg)))) +) + + +(defmacro Math-natnump (a) + (` (if (consp (, a)) + (eq (car (, a)) 'bigpos) + (>= (, a) 0))) +) + +(defmacro Math-ratp (a) + (` (or (not (consp (, a))) + (memq (car (, a)) '(bigpos bigneg frac)))) +) + +(defmacro Math-realp (a) + (` (or (not (consp (, a))) + (memq (car (, a)) '(bigpos bigneg frac float)))) +) + +(defmacro Math-anglep (a) + (` (or (not (consp (, a))) + (memq (car (, a)) '(bigpos bigneg frac float hms)))) +) + +(defmacro Math-numberp (a) + (` (or (not (consp (, a))) + (memq (car (, a)) '(bigpos bigneg frac float cplx polar)))) +) + +(defmacro Math-scalarp (a) + (` (or (not (consp (, a))) + (memq (car (, a)) '(bigpos bigneg frac float cplx polar hms)))) +) + +(defmacro Math-vectorp (a) + (` (and (consp (, a)) (eq (car (, a)) 'vec))) +) + +(defmacro Math-messy-integerp (a) + (` (and (consp (, a)) + (eq (car (, a)) 'float) + (>= (nth 2 (, a)) 0))) +) + +(defmacro Math-objectp (a) ; [Public] + (` (or (not (consp (, a))) + (memq (car (, a)) + '(bigpos bigneg frac float cplx polar hms date sdev intv mod)))) +) + +(defmacro Math-objvecp (a) ; [Public] + (` (or (not (consp (, a))) + (memq (car (, a)) + '(bigpos bigneg frac float cplx polar hms date + sdev intv mod vec)))) +) + + +;;; Compute the negative of A. [O O; o o] [Public] +(defmacro Math-integer-neg (a) + (` (if (consp (, a)) + (if (eq (car (, a)) 'bigpos) + (cons 'bigneg (cdr (, a))) + (cons 'bigpos (cdr (, a)))) + (- (, a)))) +) + + +(defmacro Math-equal (a b) + (` (= (math-compare (, a) (, b)) 0)) +) + +(defmacro Math-lessp (a b) + (` (= (math-compare (, a) (, b)) -1)) +) + + +(defmacro math-working (msg arg) ; [Public] + (` (if (eq calc-display-working-message 'lots) + (math-do-working (, msg) (, arg)))) +) + + +(defmacro calc-with-default-simplification (body) + (list 'let + '((calc-simplify-mode (and (not (memq calc-simplify-mode '(none num))) + calc-simplify-mode))) + body) +) + + +(defmacro Math-primp (a) + (` (or (not (consp (, a))) + (memq (car (, a)) '(bigpos bigneg frac float cplx polar + hms date mod var)))) +) + + +(defmacro calc-with-trail-buffer (&rest body) + (` (let ((save-buf (current-buffer)) + (calc-command-flags nil)) + (unwind-protect + (, (append '(progn + (set-buffer (calc-trail-display t)) + (goto-char calc-trail-pointer)) + body)) + (set-buffer save-buf)))) +) + + +(defmacro Math-num-integerp (a) + (` (or (not (consp (, a))) + (memq (car (, a)) '(bigpos bigneg)) + (and (eq (car (, a)) 'float) + (>= (nth 2 (, a)) 0)))) +) + + +(defmacro Math-bignum-test (a) ; [B N; B s; b b] + (` (if (consp (, a)) + (, a) + (math-bignum (, a)))) +) + + +(defmacro Math-equal-int (a b) + (` (or (eq (, a) (, b)) + (and (consp (, a)) + (eq (car (, a)) 'float) + (eq (nth 1 (, a)) (, b)) + (= (nth 2 (, a)) 0)))) +) + +(defmacro Math-natnum-lessp (a b) + (` (if (consp (, a)) + (and (consp (, b)) + (= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1)) + (or (consp (, b)) + (< (, a) (, b))))) +) + + +(defmacro math-format-radix-digit (a) ; [X D] + (` (aref math-radix-digits (, a))) +) + + diff --git a/lisp/calc/calc-maint.el b/lisp/calc/calc-maint.el new file mode 100644 index 0000000000..7bf4748169 --- /dev/null +++ b/lisp/calc/calc-maint.el @@ -0,0 +1,466 @@ +;; Calculator for GNU Emacs, maintenance routines +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + + +(defun calc-compile () + "Compile all parts of Calc. +Unix usage: + emacs -batch -l calc-maint -f calc-compile" + (interactive) + (if (equal (user-full-name) "David Gillespie") + (load "~/lisp/newbytecomp")) + (setq byte-compile-verbose t) + (if noninteractive + (let ((old-message (symbol-function 'message)) + (old-write-region (symbol-function 'write-region)) + (comp-was-func nil) + (comp-len 0)) + (unwind-protect + (progn + (fset 'message (symbol-function 'calc-compile-message)) + (fset 'write-region (symbol-function 'calc-compile-write-region)) + (calc-do-compile)) + (fset 'message old-message) + (fset 'write-region old-write-region))) + (calc-do-compile)) +) + +(defun calc-do-compile () + (let ((make-backup-files nil) + (changed-rules nil) + (changed-units nil) + (message-bug (string-match "^18.\\([0-4][0-9]\\|5[0-6]\\)" + emacs-version))) + (setq max-lisp-eval-depth (max 400 max-lisp-eval-depth)) + ;; Enable some irrelevant warnings to avoid compiler bug in 19.29: + (setq byte-compile-warnings (and (string-match "^19.29" emacs-version) + '(obsolete))) + + ;; Make sure we're in the right directory. + (find-file "calc.el") + (if (= (buffer-size) 0) + (error "This command must be used in the Calc source directory.")) + + ;; Make sure current directory is in load-path. + (setq load-path (cons default-directory load-path)) + (load "calc-macs.el" nil t t) + (provide 'calc) + (provide 'calc-ext) + + ;; Compile all the source files. + (let ((files (append + '("calc.el" "calc-ext.el") + (sort (directory-files + default-directory nil + "\\`calc-.[^x].*\\.el\\'") + 'string<)))) + (while files + (if (file-newer-than-file-p (car files) (concat (car files) "c")) + (progn + (if (string-match "calc-rules" (car files)) + (setq changed-rules t)) + (if (string-match "calc-units" (car files)) + (setq changed-units t)) + (or message-bug (message "")) + (byte-compile-file (car files))) + (message "File %s is up to date." (car files))) + (if (string-match "calc\\(-ext\\)?.el" (car files)) + (load (concat (car files) "c") nil t t)) + (setq files (cdr files)))) + + (if (or changed-units changed-rules) + (condition-case err + (progn + + ;; Pre-build the units table. + (if (and changed-units + (not (string-match "Lucid" emacs-version))) + (progn + (or message-bug (message "")) + (save-excursion + (calc-create-buffer) + (math-build-units-table)) + (find-file "calc-units.elc") + (goto-char (point-max)) + (insert "\n(setq math-units-table '" + (prin1-to-string math-units-table) + ")\n") + (save-buffer))) + + ;; Pre-build rewrite rules for j D, j M, etc. + (if (and changed-rules (not (string-match "^19" emacs-version))) + (let ((rules nil)) + (or message-bug (message "")) + (find-file "calc-rules.elc") + (goto-char (point-min)) + (while (re-search-forward "defun calc-\\([A-Za-z]*Rules\\)" + nil t) + (setq rules (cons (buffer-substring (match-beginning 1) + (match-end 1)) + rules))) + (goto-char (point-min)) + (re-search-forward "\n(defun calc-[A-Za-z]*Rules") + (beginning-of-line) + (delete-region (point) (point-max)) + (mapcar (function + (lambda (v) + (let* ((vv (intern (concat "var-" v))) + (val (save-excursion + (calc-create-buffer) + (calc-var-value vv)))) + (insert "\n(defun calc-" v " () '" + (prin1-to-string val) ")\n")))) + (sort rules 'string<)) + (save-buffer)))) + (error (message "Unable to pre-build tables %s" err)))) + (message "Done. Don't forget to install with \"make public\" or \"make private\".")) +) + +(defun calc-compile-message (fmt &rest args) + (cond ((and (= (length args) 2) + (stringp (car args)) + (string-match ".elc?\\'" (car args)) + (symbolp (nth 1 args))) + (let ((name (symbol-name (nth 1 args)))) + (princ (if comp-was-func ", " " ")) + (if (and comp-was-func (eq (string-match comp-was-func name) 0)) + (setq name (substring name (1- (length comp-was-func)))) + (setq comp-was-func (if (string-match "\\`[a-zA-Z]+-" name) + (substring name 0 (match-end 0)) + " "))) + (if (> (+ comp-len (length name)) 75) + (progn + (princ "\n ") + (setq comp-len 0))) + (princ name) + (send-string-to-terminal "") ; cause an fflush(stdout) + (setq comp-len (+ comp-len 2 (length name))))) + ((and (setq comp-was-func nil + comp-len 0) + (= (length args) 1) + (stringp (car args)) + (string-match ".elc?\\'" (car args))) + (or (string-match "Saving file %s..." fmt) + (funcall old-message fmt (file-name-nondirectory (car args))))) + ((string-match "\\(Preparing\\|Building\\).*\\.\\.\\.$" fmt) + (send-string-to-terminal (apply 'format fmt args))) + ((string-match "\\(Preparing\\|Building\\).*\\.\\.\\. *done$" fmt) + (send-string-to-terminal "done\n")) + (t (apply old-message fmt args))) +) + +(defun calc-compile-write-region (start end filename &optional append visit &rest rest) + (if (eq visit t) + (set-buffer-auto-saved)) + (if (and (string-match "\\.elc" filename) + (= start (point-min)) + (= end (point-max))) + (save-excursion + (goto-char (point-min)) + (if (search-forward "\n(require (quote calc-macs))\n" nil t) + (replace-match "")) + (setq end (point-max)))) + (apply old-write-region start end filename append 'quietly rest) + (message "Wrote %s" filename) + nil +) + + + +(defun calc-split-tutorial (&optional force) + (interactive "P") + (calc-split-manual force 1)) + + +(defun calc-split-reference (&optional force) + (interactive "P") + (calc-split-manual force 2)) + + +(defun calc-split-manual (&optional force part) + "Split the Calc manual into separate Tutorial and Reference manuals. +Use this if your TeX installation is too small-minded to handle +calc.texinfo all at once. +Usage: C-x C-f calc.texinfo RET + M-x calc-split-manual RET" + (interactive "P") + (or (let ((case-fold-search t)) + (string-match "calc\\.texinfo" (buffer-name))) + force + (error "This command should be used in the calc.texinfo buffer.")) + (let ((srcbuf (current-buffer)) + tutpos refpos endpos (maxpos (point-max))) + (goto-char 1) + (search-forward "@c [tutorial]") + (beginning-of-line) + (setq tutpos (point)) + (search-forward "@c [reference]") + (beginning-of-line) + (setq refpos (point)) + (search-forward "@c [end]") + (beginning-of-line) + (setq endpos (point)) + (or (eq part 2) + (progn + (find-file "calctut.tex") + (erase-buffer) + (insert-buffer-substring srcbuf 1 refpos) + (insert-buffer-substring srcbuf endpos maxpos) + (calc-split-volume "I" "ref" "Tutorial" "Reference") + (save-buffer))) + (or (eq part 1) + (progn + (find-file "calcref.tex") + (erase-buffer) + (insert-buffer-substring srcbuf 1 tutpos) + (insert "\n@tex\n\\global\\advance\\chapno by 1\n@end tex\n") + (insert-buffer-substring srcbuf refpos maxpos) + (calc-split-volume "II" "tut" "Reference" "Tutorial") + (save-buffer))) + (switch-to-buffer srcbuf) + (goto-char 1)) + (message (cond ((eq part 1) "Wrote file calctut.tex") + ((eq part 2) "Wrote file calcref.tex") + (t "Wrote files calctut.tex and calcref.tex"))) +) + +(defun calc-split-volume (number fix name other-name) + (goto-char 1) + (search-forward "@c [title]\n") + (search-forward "Manual") + (delete-backward-char 6) + (insert name) + (search-forward "@c [volume]\n") + (insert "@sp 1\n@center Volume " number ": " name "\n") + (let ((pat (format "@c \\[fix-%s \\(.*\\)\\]\n" fix))) + (while (re-search-forward pat nil t) + (let ((topic (buffer-substring (match-beginning 1) (match-end 1)))) + (re-search-forward "@\\(p?xref\\){[^}]*}") + (let ((cmd (buffer-substring (match-beginning 1) (match-end 1)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert (if (equal cmd "pxref") "see" "See") + " ``" topic "'' in @emph{the Calc " + other-name "}"))))) + (goto-char 1) + (while (search-forward "@c [when-split]\n" nil t) + (while (looking-at "@c ") + (delete-char 3) + (forward-line 1))) + (goto-char 1) + (while (search-forward "@c [not-split]\n" nil t) + (while (not (looking-at "@c")) + (insert "@c ") + (forward-line 1))) +) + + +(defun calc-inline-summary () + "Make a special \"calcsum.tex\" file to be used with main manual." + (calc-split-summary nil t) +) + +(defun calc-split-summary (&optional force in-line) + "Make a special \"calcsum.tex\" file with just the Calc summary." + (interactive "P") + (or (let ((case-fold-search t)) + (string-match "calc\\.texinfo" (buffer-name))) + force + (error "This command should be used in the calc.texinfo buffer.")) + (let ((srcbuf (current-buffer)) + begpos sumpos endpos midpos) + (goto-char 1) + (search-forward "{Calc Manual}") + (backward-char 1) + (delete-backward-char 6) + (insert "Summary") + (search-forward "@c [begin]") + (beginning-of-line) + (setq begpos (point)) + (search-forward "@c [summary]") + (beginning-of-line) + (setq sumpos (point)) + (search-forward "@c [end-summary]") + (beginning-of-line) + (setq endpos (point)) + (find-file "calcsum.tex") + (erase-buffer) + (insert-buffer-substring srcbuf 1 begpos) + (insert "@tex\n" + "\\global\\advance\\appendixno2\n" + "\\gdef\\xref#1.{See ``#1.''}\n") + (setq midpos (point)) + (insert "@end tex\n") + (insert-buffer-substring srcbuf sumpos endpos) + (insert "@bye\n") + (goto-char 1) + (if (search-forward "{. a b c" nil t) + (replace-match "{... a b c")) + (goto-char 1) + (if in-line + (let ((buf (current-buffer)) + (page nil)) + (find-file "calc.aux") + (if (> (buffer-size) 0) + (progn + (goto-char 1) + (re-search-forward "{Summary-pg}{\\([0-9]+\\)}") + (setq page (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))))) + (switch-to-buffer buf) + (if page + (progn + (message "Adjusting starting page number to %d" page) + (goto-char midpos) + (insert (format "\\global\\pageno=%d\n" page))) + (message "Unable to find page number from calc.aux"))) + (if (search-forward "@c smallbook" nil t) + (progn ; activate "smallbook" format for compactness + (beginning-of-line) + (forward-char 1) + (delete-char 2)))) + (let ((buf (current-buffer))) + (find-file "calc.ky") + (if (> (buffer-size) 0) + (let ((ibuf (current-buffer))) + (message "Mixing in page numbers from Key Index (calc.ky)") + (switch-to-buffer buf) + (goto-char 1) + (search-forward "notes at the end") + (insert "; the number in italics is\n" + "the page number where the command is described") + (while (re-search-forward + "@r{.*@: *\\([^ ]\\(.*[^ ]\\)?\\) *@:.*@:.*@:\\(.*\\)@:.*}" + nil t) + (let ((key (buffer-substring (match-beginning 1) (match-end 1))) + (pos (match-beginning 3)) + num) + (set-buffer ibuf) + (goto-char 1) + (let ((p '( ( "I H " . "H I " ) ; oops! + ( "@@ ' \"" . "@@" ) ( "h m s" . "@@" ) + ( "\\\\" . "{\\tt\\indexbackslash }" ) + ( "_" . "{\\_}" ) + ( "\\^" . "{\\tt\\hat}" ) + ( "<" . "{\\tt\\less}" ) + ( ">" . "{\\tt\\gtr}" ) + ( "\"" ) ( "@{" ) ( "@}" ) + ( "~" ) ( "|" ) ( "@@" ) + ( "\\+" . "{\\tt\\char43}" ) + ( "# l" . "# L" ) + ( "I f I" . "f I" ) ( "I f Q" . "f Q" ) + ( "V &" . "&" ) ( "C-u " . "" ) )) + (case-fold-search nil)) + (while p + (if (string-match (car (car p)) key) + (setq key (concat (substring key 0 (match-beginning 0)) + (or (cdr (car p)) + (format "{\\tt\\char'%03o}" + (aref key (1- (match-end + 0))))) + (substring key (match-end 0))))) + (setq p (cdr p))) + (setq num (and (search-forward (format "\\entry {%s}{" key) + nil t) + (looking-at "[0-9]+") + (buffer-substring (point) (match-end 0))))) + (set-buffer buf) + (goto-char pos) + (insert "@pgref{" (or num "") "}"))) + (goto-char midpos) + (insert "\\gdef\\pgref#1{\\hbox to 2em{\\indsl\\hss#1}\\ \\ }\n")) + (message + "Unable to find Key Index (calc.ky); no page numbers inserted")) + (switch-to-buffer buf)) + (save-buffer)) + (message "Wrote file calcsum.tex") +) + + + +(defun calc-public-autoloads () + "Modify the public \"default\" file to contain the necessary autoload and +global-set-key commands for Calc." + (interactive) + (let ((home default-directory) + (p load-path) + instbuf name) + (while (and p + (not (file-exists-p + (setq name (expand-file-name "default" (car p))))) + (not (file-exists-p + (setq name (expand-file-name "default.el" (car p)))))) + (setq p (cdr p))) + (or p (error "Unable to find \"default\" file. Create one and try again.")) + (find-file name) + (if buffer-read-only (error "No write permission for \"%s\"" buffer-file-name)) + (goto-char (point-max)) + (calc-add-autoloads home "calc-public-autoloads")) +) + +(defun calc-private-autoloads () + "Modify the user's \".emacs\" file to contain the necessary autoload and +global-set-key commands for Calc." + (interactive) + (let ((home default-directory)) + (find-file "~/.emacs") + (goto-char (point-max)) + (calc-add-autoloads home "calc-private-autoloads")) +) + +(defun calc-add-autoloads (home cmd) + (barf-if-buffer-read-only) + (let (top) + (if (and (re-search-backward ";;; Commands added by calc-.*-autoloads" + nil t) + (setq top (point)) + (search-forward ";;; End of Calc autoloads" nil t)) + (progn + (forward-line 1) + (message "(Removing previous autoloads)") + (delete-region top (point))) + (insert "\n\n") + (backward-char 1))) + (insert ";;; Commands added by " cmd " on " + (current-time-string) ". +\(autoload 'calc-dispatch \"calc\" \"Calculator Options\" t) +\(autoload 'full-calc \"calc\" \"Full-screen Calculator\" t) +\(autoload 'full-calc-keypad \"calc\" \"Full-screen X Calculator\" t) +\(autoload 'calc-eval \"calc\" \"Use Calculator from Lisp\") +\(autoload 'defmath \"calc\" nil t t) +\(autoload 'calc \"calc\" \"Calculator Mode\" t) +\(autoload 'quick-calc \"calc\" \"Quick Calculator\" t) +\(autoload 'calc-keypad \"calc\" \"X windows Calculator\" t) +\(autoload 'calc-embedded \"calc\" \"Use Calc inside any buffer\" t) +\(autoload 'calc-embedded-activate \"calc\" \"Activate =>'s in buffer\" t) +\(autoload 'calc-grab-region \"calc\" \"Grab region of Calc data\" t) +\(autoload 'calc-grab-rectangle \"calc\" \"Grab rectangle of data\" t) +\(setq load-path (nconc load-path (list \"" (directory-file-name home) "\"))) +\(global-set-key \"\\e#\" 'calc-dispatch) +;;; End of Calc autoloads.\n") + (let ((trim-versions-without-asking t)) + (save-buffer)) +) + + + +;;; End. diff --git a/lisp/calc/calc-map.el b/lisp/calc/calc-map.el new file mode 100644 index 0000000000..7265be641c --- /dev/null +++ b/lisp/calc/calc-map.el @@ -0,0 +1,1305 @@ +;; Calculator for GNU Emacs, part II [calc-map.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-map () nil) + + +(defun calc-apply (&optional oper) + (interactive) + (calc-wrapper + (let* ((sel-mode nil) + (calc-dollar-values (mapcar 'calc-get-stack-element + (nthcdr calc-stack-top calc-stack))) + (calc-dollar-used 0) + (oper (or oper (calc-get-operator "Apply" + (if (math-vectorp (calc-top 1)) + (1- (length (calc-top 1))) + -1)))) + (expr (calc-top-n (1+ calc-dollar-used)))) + (message "Working...") + (calc-set-command-flag 'clear-message) + (calc-enter-result (1+ calc-dollar-used) + (concat (substring "apl" 0 (- 4 (length (nth 2 oper)))) + (nth 2 oper)) + (list 'calcFunc-apply + (math-calcFunc-to-var (nth 1 oper)) + expr)))) +) + +(defun calc-reduce (&optional oper accum) + (interactive) + (calc-wrapper + (let* ((sel-mode nil) + (nest (calc-is-hyperbolic)) + (rev (calc-is-inverse)) + (nargs (if (and nest (not rev)) 2 1)) + (calc-dollar-values (mapcar 'calc-get-stack-element + (nthcdr calc-stack-top calc-stack))) + (calc-dollar-used 0) + (calc-mapping-dir (and (not accum) (not nest) "")) + (oper (or oper (calc-get-operator + (if nest + (concat (if accum "Accumulate " "") + (if rev "Fixed Point" "Nest")) + (concat (if rev "Inv " "") + (if accum "Accumulate" "Reduce"))) + (if nest 1 2))))) + (message "Working...") + (calc-set-command-flag 'clear-message) + (calc-enter-result (+ calc-dollar-used nargs) + (concat (substring (if nest + (if rev "fxp" "nst") + (if accum "acc" "red")) + 0 (- 4 (length (nth 2 oper)))) + (nth 2 oper)) + (if nest + (cons (if rev + (if accum 'calcFunc-afixp 'calcFunc-fixp) + (if accum 'calcFunc-anest 'calcFunc-nest)) + (cons (math-calcFunc-to-var (nth 1 oper)) + (calc-top-list-n + nargs (1+ calc-dollar-used)))) + (list (if accum + (if rev 'calcFunc-raccum 'calcFunc-accum) + (intern (concat "calcFunc-" + (if rev "r" "") + "reduce" + calc-mapping-dir))) + (math-calcFunc-to-var (nth 1 oper)) + (calc-top-n (1+ calc-dollar-used))))))) +) + +(defun calc-accumulate (&optional oper) + (interactive) + (calc-reduce oper t) +) + +(defun calc-map (&optional oper) + (interactive) + (calc-wrapper + (let* ((sel-mode nil) + (calc-dollar-values (mapcar 'calc-get-stack-element + (nthcdr calc-stack-top calc-stack))) + (calc-dollar-used 0) + (calc-mapping-dir "") + (oper (or oper (calc-get-operator "Map"))) + (nargs (car oper))) + (message "Working...") + (calc-set-command-flag 'clear-message) + (calc-enter-result (+ nargs calc-dollar-used) + (concat (substring "map" 0 (- 4 (length (nth 2 oper)))) + (nth 2 oper)) + (cons (intern (concat "calcFunc-map" calc-mapping-dir)) + (cons (math-calcFunc-to-var (nth 1 oper)) + (calc-top-list-n + nargs + (1+ calc-dollar-used))))))) +) + +(defun calc-map-equation (&optional oper) + (interactive) + (calc-wrapper + (let* ((sel-mode nil) + (calc-dollar-values (mapcar 'calc-get-stack-element + (nthcdr calc-stack-top calc-stack))) + (calc-dollar-used 0) + (oper (or oper (calc-get-operator "Map-equation"))) + (nargs (car oper))) + (message "Working...") + (calc-set-command-flag 'clear-message) + (calc-enter-result (+ nargs calc-dollar-used) + (concat (substring "map" 0 (- 4 (length (nth 2 oper)))) + (nth 2 oper)) + (cons (if (calc-is-inverse) + 'calcFunc-mapeqr + (if (calc-is-hyperbolic) + 'calcFunc-mapeqp 'calcFunc-mapeq)) + (cons (math-calcFunc-to-var (nth 1 oper)) + (calc-top-list-n + nargs + (1+ calc-dollar-used))))))) +) + +(defun calc-map-stack () + "This is meant to be called by calc-keypad mode." + (interactive) + (let ((calc-verify-arglist nil)) + (calc-unread-command ?\$) + (calc-map)) +) + +(defun calc-outer-product (&optional oper) + (interactive) + (calc-wrapper + (let* ((sel-mode nil) + (calc-dollar-values (mapcar 'calc-get-stack-element + (nthcdr calc-stack-top calc-stack))) + (calc-dollar-used 0) + (oper (or oper (calc-get-operator "Outer" 2)))) + (message "Working...") + (calc-set-command-flag 'clear-message) + (calc-enter-result (+ 2 calc-dollar-used) + (concat (substring "out" 0 (- 4 (length (nth 2 oper)))) + (nth 2 oper)) + (cons 'calcFunc-outer + (cons (math-calcFunc-to-var (nth 1 oper)) + (calc-top-list-n + 2 (1+ calc-dollar-used))))))) +) + +(defun calc-inner-product (&optional mul-oper add-oper) + (interactive) + (calc-wrapper + (let* ((sel-mode nil) + (calc-dollar-values (mapcar 'calc-get-stack-element + (nthcdr calc-stack-top calc-stack))) + (calc-dollar-used 0) + (mul-oper (or mul-oper (calc-get-operator "Inner (Mult)" 2))) + (mul-used calc-dollar-used) + (calc-dollar-values (if (> mul-used 0) + (cdr calc-dollar-values) + calc-dollar-values)) + (calc-dollar-used 0) + (add-oper (or add-oper (calc-get-operator "Inner (Add)" 2)))) + (message "Working...") + (calc-set-command-flag 'clear-message) + (calc-enter-result (+ 2 mul-used calc-dollar-used) + (concat "in" + (substring (nth 2 mul-oper) 0 1) + (substring (nth 2 add-oper) 0 1)) + (nconc (list 'calcFunc-inner + (math-calcFunc-to-var (nth 1 mul-oper)) + (math-calcFunc-to-var (nth 1 add-oper))) + (calc-top-list-n + 2 (+ 1 mul-used calc-dollar-used)))))) +) + +;;; Return a list of the form (nargs func name) +(defun calc-get-operator (msg &optional nargs) + (setq calc-aborted-prefix nil) + (let ((inv nil) (hyp nil) (prefix nil) (forcenargs nil) + done key oper (which 0) + (msgs '( "(Press ? for help)" + "+, -, *, /, ^, %, \\, :, &, !, |, Neg" + "SHIFT + Abs, conJ, arG; maX, miN; Floor, Round; sQrt" + "SHIFT + Inv, Hyp; Sin, Cos, Tan; Exp, Ln, logB" + "Algebra + Simp, Esimp, Deriv, Integ, !, =, etc." + "Binary + And, Or, Xor, Diff; l/r/t/L/R shifts; Not, Clip" + "Conversions + Deg, Rad, HMS; Float; SHIFT + Fraction" + "Functions + Re, Im; Hypot; Mant, Expon, Scale; etc." + "Kombinatorics + Dfact, Lcm, Gcd, Choose; Random; etc." + "Time/date + newYear, Incmonth, etc." + "Vectors + Length, Row, Col, Diag, Mask, etc." + "_ = mapr/reducea, : = mapc/reduced, = = reducer" + "X or Z = any function by name; ' = alg entry; $ = stack"))) + (while (not done) + (message "%s%s: %s: %s%s%s" + msg + (cond ((equal calc-mapping-dir "r") " rows") + ((equal calc-mapping-dir "c") " columns") + ((equal calc-mapping-dir "a") " across") + ((equal calc-mapping-dir "d") " down") + (t "")) + (if forcenargs + (format "(%d arg%s)" + forcenargs (if (= forcenargs 1) "" "s")) + (nth which msgs)) + (if inv "Inv " "") (if hyp "Hyp " "") + (if prefix (concat (char-to-string prefix) "-") "")) + (setq key (read-char)) + (if (>= key 128) (setq key (- key 128))) + (cond ((memq key '(?\C-g ?q)) + (keyboard-quit)) + ((memq key '(?\C-u ?\e))) + ((= key ??) + (setq which (% (1+ which) (length msgs)))) + ((and (= key ?I) (null prefix)) + (setq inv (not inv))) + ((and (= key ?H) (null prefix)) + (setq hyp (not hyp))) + ((and (eq key prefix) (not (eq key ?v))) + (setq prefix nil)) + ((and (memq key '(?a ?b ?c ?f ?k ?s ?t ?u ?v ?V)) + (null prefix)) + (setq prefix (downcase key))) + ((and (eq key ?\=) (null prefix)) + (if calc-mapping-dir + (setq calc-mapping-dir (if (equal calc-mapping-dir "r") + "" "r")) + (beep))) + ((and (eq key ?\_) (null prefix)) + (if calc-mapping-dir + (if (string-match "map$" msg) + (setq calc-mapping-dir (if (equal calc-mapping-dir "r") + "" "r")) + (setq calc-mapping-dir (if (equal calc-mapping-dir "a") + "" "a"))) + (beep))) + ((and (eq key ?\:) (null prefix)) + (if calc-mapping-dir + (if (string-match "map$" msg) + (setq calc-mapping-dir (if (equal calc-mapping-dir "c") + "" "c")) + (setq calc-mapping-dir (if (equal calc-mapping-dir "d") + "" "d"))) + (beep))) + ((and (>= key ?0) (<= key ?9) (null prefix)) + (setq forcenargs (if (eq forcenargs (- key ?0)) nil (- key ?0))) + (and nargs forcenargs (/= nargs forcenargs) (>= nargs 0) + (error "Must be a %d-argument operator" nargs))) + ((memq key '(?\$ ?\')) + (let* ((arglist nil) + (has-args nil) + (record-entry nil) + (expr (if (eq key ?\$) + (progn + (setq calc-dollar-used 1) + (if calc-dollar-values + (car calc-dollar-values) + (error "Stack underflow"))) + (let* ((calc-dollar-values calc-arg-values) + (calc-dollar-used 0) + (calc-hashes-used 0) + (func (calc-do-alg-entry "" "Function: "))) + (setq record-entry t) + (or (= (length func) 1) + (error "Bad format")) + (if (> calc-dollar-used 0) + (progn + (setq has-args calc-dollar-used + arglist (calc-invent-args has-args)) + (math-multi-subst (car func) + (reverse arglist) + arglist)) + (if (> calc-hashes-used 0) + (setq has-args calc-hashes-used + arglist (calc-invent-args has-args))) + (car func)))))) + (if (eq (car-safe expr) 'calcFunc-lambda) + (setq oper (list "$" (- (length expr) 2) expr) + done t) + (or has-args + (progn + (calc-default-formula-arglist expr) + (setq record-entry t + arglist (sort arglist 'string-lessp)) + (if calc-verify-arglist + (setq arglist (read-from-minibuffer + "Function argument list: " + (if arglist + (prin1-to-string arglist) + "()") + minibuffer-local-map + t))) + (setq arglist (mapcar (function + (lambda (x) + (list 'var + x + (intern + (concat + "var-" + (symbol-name x)))))) + arglist)))) + (setq oper (list "$" + (length arglist) + (append '(calcFunc-lambda) arglist + (list expr))) + done t)) + (if record-entry + (calc-record (nth 2 oper) "oper")))) + ((setq oper (assq key (nth (if inv (if hyp 3 1) (if hyp 2 0)) + (if prefix + (symbol-value + (intern (format "calc-%c-oper-keys" + prefix))) + calc-oper-keys)))) + (if (eq (nth 1 oper) 'user) + (let ((func (intern + (completing-read "Function name: " + obarray 'fboundp + nil "calcFunc-")))) + (if (or forcenargs nargs) + (setq oper (list "z" (or forcenargs nargs) func) + done t) + (if (fboundp func) + (let* ((defn (symbol-function func))) + (and (symbolp defn) + (setq defn (symbol-function defn))) + (if (eq (car-safe defn) 'lambda) + (let ((args (nth 1 defn)) + (nargs 0)) + (while (not (memq (car args) '(&optional + &rest nil))) + (setq nargs (1+ nargs) + args (cdr args))) + (setq oper (list "z" nargs func) + done t)) + (error + "Function is not suitable for this operation"))) + (message "Number of arguments: ") + (let ((nargs (read-char))) + (if (and (>= nargs ?0) (<= nargs ?9)) + (setq oper (list "z" (- nargs ?0) func) + done t) + (beep)))))) + (if (or (and (eq prefix ?v) (memq key '(?A ?I ?M ?O ?R ?U))) + (and (eq prefix ?a) (eq key ?M))) + (let* ((dir (cond ((and (equal calc-mapping-dir "") + (string-match "map$" msg)) + (setq calc-mapping-dir "r") + " rows") + ((equal calc-mapping-dir "r") " rows") + ((equal calc-mapping-dir "c") " columns") + ((equal calc-mapping-dir "a") " across") + ((equal calc-mapping-dir "d") " down") + (t ""))) + (calc-mapping-dir (and (memq (nth 2 oper) + '(calcFunc-map + calcFunc-reduce + calcFunc-rreduce)) + "")) + (oper2 (calc-get-operator + (format "%s%s, %s%s" msg dir + (substring (symbol-name (nth 2 oper)) + 9) + (if (eq key ?I) " (mult)" "")) + (cdr (assq (nth 2 oper) + '((calcFunc-reduce . 2) + (calcFunc-rreduce . 2) + (calcFunc-accum . 2) + (calcFunc-raccum . 2) + (calcFunc-nest . 2) + (calcFunc-anest . 2) + (calcFunc-fixp . 2) + (calcFunc-afixp . 2)))))) + (oper3 (if (eq (nth 2 oper) 'calcFunc-inner) + (calc-get-operator + (format "%s%s, inner (add)" msg dir + (substring + (symbol-name (nth 2 oper)) + 9))) + '(0 0 0))) + (args nil) + (nargs (if (> (nth 1 oper) 0) + (nth 1 oper) + (car oper2))) + (n nargs) + (p calc-arg-values)) + (while (and p (> n 0)) + (or (math-expr-contains (nth 1 oper2) (car p)) + (math-expr-contains (nth 1 oper3) (car p)) + (setq args (nconc args (list (car p))) + n (1- n))) + (setq p (cdr p))) + (setq oper (list "" nargs + (append + '(calcFunc-lambda) + args + (list (math-build-call + (intern + (concat + (symbol-name (nth 2 oper)) + calc-mapping-dir)) + (cons (math-calcFunc-to-var + (nth 1 oper2)) + (if (eq key ?I) + (cons + (math-calcFunc-to-var + (nth 1 oper3)) + args) + args)))))) + done t)) + (setq done t)))) + (t (beep)))) + (and nargs (>= nargs 0) + (/= nargs (nth 1 oper)) + (error "Must be a %d-argument operator" nargs)) + (append (if forcenargs + (cons forcenargs (cdr (cdr oper))) + (cdr oper)) + (list + (let ((name (concat (if inv "I" "") (if hyp "H" "") + (if prefix (char-to-string prefix) "") + (char-to-string key)))) + (if (> (length name) 3) + (substring name 0 3) + name))))) +) +(setq calc-verify-arglist t) +(setq calc-mapping-dir nil) + +(defconst calc-oper-keys '( ( ( ?+ 2 calcFunc-add ) + ( ?- 2 calcFunc-sub ) + ( ?* 2 calcFunc-mul ) + ( ?/ 2 calcFunc-div ) + ( ?^ 2 calcFunc-pow ) + ( ?| 2 calcFunc-vconcat ) + ( ?% 2 calcFunc-mod ) + ( ?\\ 2 calcFunc-idiv ) + ( ?! 1 calcFunc-fact ) + ( ?& 1 calcFunc-inv ) + ( ?n 1 calcFunc-neg ) + ( ?x user ) + ( ?z user ) + ( ?A 1 calcFunc-abs ) + ( ?J 1 calcFunc-conj ) + ( ?G 1 calcFunc-arg ) + ( ?Q 1 calcFunc-sqrt ) + ( ?N 2 calcFunc-min ) + ( ?X 2 calcFunc-max ) + ( ?F 1 calcFunc-floor ) + ( ?R 1 calcFunc-round ) + ( ?S 1 calcFunc-sin ) + ( ?C 1 calcFunc-cos ) + ( ?T 1 calcFunc-tan ) + ( ?L 1 calcFunc-ln ) + ( ?E 1 calcFunc-exp ) + ( ?B 2 calcFunc-log ) ) + ( ( ?F 1 calcFunc-ceil ) ; inverse + ( ?R 1 calcFunc-trunc ) + ( ?Q 1 calcFunc-sqr ) + ( ?S 1 calcFunc-arcsin ) + ( ?C 1 calcFunc-arccos ) + ( ?T 1 calcFunc-arctan ) + ( ?L 1 calcFunc-exp ) + ( ?E 1 calcFunc-ln ) + ( ?B 2 calcFunc-alog ) + ( ?^ 2 calcFunc-nroot ) + ( ?| 2 calcFunc-vconcatrev ) ) + ( ( ?F 1 calcFunc-ffloor ) ; hyperbolic + ( ?R 1 calcFunc-fround ) + ( ?S 1 calcFunc-sinh ) + ( ?C 1 calcFunc-cosh ) + ( ?T 1 calcFunc-tanh ) + ( ?L 1 calcFunc-log10 ) + ( ?E 1 calcFunc-exp10 ) + ( ?| 2 calcFunc-append ) ) + ( ( ?F 1 calcFunc-fceil ) ; inverse-hyperbolic + ( ?R 1 calcFunc-ftrunc ) + ( ?S 1 calcFunc-arcsinh ) + ( ?C 1 calcFunc-arccosh ) + ( ?T 1 calcFunc-arctanh ) + ( ?L 1 calcFunc-exp10 ) + ( ?E 1 calcFunc-log10 ) + ( ?| 2 calcFunc-appendrev ) ) +)) +(defconst calc-a-oper-keys '( ( ( ?a 3 calcFunc-apart ) + ( ?b 3 calcFunc-subst ) + ( ?c 2 calcFunc-collect ) + ( ?d 2 calcFunc-deriv ) + ( ?e 1 calcFunc-esimplify ) + ( ?f 2 calcFunc-factor ) + ( ?g 2 calcFunc-pgcd ) + ( ?i 2 calcFunc-integ ) + ( ?m 2 calcFunc-match ) + ( ?n 1 calcFunc-nrat ) + ( ?r 2 calcFunc-rewrite ) + ( ?s 1 calcFunc-simplify ) + ( ?t 3 calcFunc-taylor ) + ( ?x 1 calcFunc-expand ) + ( ?M 2 calcFunc-mapeq ) + ( ?N 3 calcFunc-minimize ) + ( ?P 2 calcFunc-roots ) + ( ?R 3 calcFunc-root ) + ( ?S 2 calcFunc-solve ) + ( ?T 4 calcFunc-table ) + ( ?X 3 calcFunc-maximize ) + ( ?= 2 calcFunc-eq ) + ( ?\# 2 calcFunc-neq ) + ( ?< 2 calcFunc-lt ) + ( ?> 2 calcFunc-gt ) + ( ?\[ 2 calcFunc-leq ) + ( ?\] 2 calcFunc-geq ) + ( ?{ 2 calcFunc-in ) + ( ?! 1 calcFunc-lnot ) + ( ?& 2 calcFunc-land ) + ( ?\| 2 calcFunc-lor ) + ( ?: 3 calcFunc-if ) + ( ?. 2 calcFunc-rmeq ) + ( ?+ 4 calcFunc-sum ) + ( ?- 4 calcFunc-asum ) + ( ?* 4 calcFunc-prod ) + ( ?_ 2 calcFunc-subscr ) + ( ?\\ 2 calcFunc-pdiv ) + ( ?% 2 calcFunc-prem ) + ( ?/ 2 calcFunc-pdivrem ) ) + ( ( ?m 2 calcFunc-matchnot ) + ( ?M 2 calcFunc-mapeqr ) + ( ?S 2 calcFunc-finv ) ) + ( ( ?d 2 calcFunc-tderiv ) + ( ?f 2 calcFunc-factors ) + ( ?M 2 calcFunc-mapeqp ) + ( ?N 3 calcFunc-wminimize ) + ( ?R 3 calcFunc-wroot ) + ( ?S 2 calcFunc-fsolve ) + ( ?X 3 calcFunc-wmaximize ) + ( ?/ 2 calcFunc-pdivide ) ) + ( ( ?S 2 calcFunc-ffinv ) ) +)) +(defconst calc-b-oper-keys '( ( ( ?a 2 calcFunc-and ) + ( ?o 2 calcFunc-or ) + ( ?x 2 calcFunc-xor ) + ( ?d 2 calcFunc-diff ) + ( ?n 1 calcFunc-not ) + ( ?c 1 calcFunc-clip ) + ( ?l 2 calcFunc-lsh ) + ( ?r 2 calcFunc-rsh ) + ( ?L 2 calcFunc-ash ) + ( ?R 2 calcFunc-rash ) + ( ?t 2 calcFunc-rot ) + ( ?p 1 calcFunc-vpack ) + ( ?u 1 calcFunc-vunpack ) + ( ?D 4 calcFunc-ddb ) + ( ?F 3 calcFunc-fv ) + ( ?I 1 calcFunc-irr ) + ( ?M 3 calcFunc-pmt ) + ( ?N 2 calcFunc-npv ) + ( ?P 3 calcFunc-pv ) + ( ?S 3 calcFunc-sln ) + ( ?T 3 calcFunc-rate ) + ( ?Y 4 calcFunc-syd ) + ( ?\# 3 calcFunc-nper ) + ( ?\% 2 calcFunc-relch ) ) + ( ( ?F 3 calcFunc-fvb ) + ( ?I 1 calcFunc-irrb ) + ( ?M 3 calcFunc-pmtb ) + ( ?N 2 calcFunc-npvb ) + ( ?P 3 calcFunc-pvb ) + ( ?T 3 calcFunc-rateb ) + ( ?\# 3 calcFunc-nperb ) ) + ( ( ?F 3 calcFunc-fvl ) + ( ?M 3 calcFunc-pmtl ) + ( ?P 3 calcFunc-pvl ) + ( ?T 3 calcFunc-ratel ) + ( ?\# 3 calcFunc-nperl ) ) +)) +(defconst calc-c-oper-keys '( ( ( ?d 1 calcFunc-deg ) + ( ?r 1 calcFunc-rad ) + ( ?h 1 calcFunc-hms ) + ( ?f 1 calcFunc-float ) + ( ?F 1 calcFunc-frac ) ) +)) +(defconst calc-f-oper-keys '( ( ( ?b 2 calcFunc-beta ) + ( ?e 1 calcFunc-erf ) + ( ?g 1 calcFunc-gamma ) + ( ?h 2 calcFunc-hypot ) + ( ?i 1 calcFunc-im ) + ( ?j 2 calcFunc-besJ ) + ( ?n 2 calcFunc-min ) + ( ?r 1 calcFunc-re ) + ( ?s 1 calcFunc-sign ) + ( ?x 2 calcFunc-max ) + ( ?y 2 calcFunc-besY ) + ( ?A 1 calcFunc-abssqr ) + ( ?B 3 calcFunc-betaI ) + ( ?E 1 calcFunc-expm1 ) + ( ?G 2 calcFunc-gammaP ) + ( ?I 2 calcFunc-ilog ) + ( ?L 1 calcFunc-lnp1 ) + ( ?M 1 calcFunc-mant ) + ( ?Q 1 calcFunc-isqrt ) + ( ?S 1 calcFunc-scf ) + ( ?T 2 calcFunc-arctan2 ) + ( ?X 1 calcFunc-xpon ) + ( ?\[ 2 calcFunc-decr ) + ( ?\] 2 calcFunc-incr ) ) + ( ( ?e 1 calcFunc-erfc ) + ( ?E 1 calcFunc-lnp1 ) + ( ?G 2 calcFunc-gammaQ ) + ( ?L 1 calcFunc-expm1 ) ) + ( ( ?B 3 calcFunc-betaB ) + ( ?G 2 calcFunc-gammag) ) + ( ( ?G 2 calcFunc-gammaG ) ) +)) +(defconst calc-k-oper-keys '( ( ( ?b 1 calcFunc-bern ) + ( ?c 2 calcFunc-choose ) + ( ?d 1 calcFunc-dfact ) + ( ?e 1 calcFunc-euler ) + ( ?f 1 calcFunc-prfac ) + ( ?g 2 calcFunc-gcd ) + ( ?h 2 calcFunc-shuffle ) + ( ?l 2 calcFunc-lcm ) + ( ?m 1 calcFunc-moebius ) + ( ?n 1 calcFunc-nextprime ) + ( ?r 1 calcFunc-random ) + ( ?s 2 calcFunc-stir1 ) + ( ?t 1 calcFunc-totient ) + ( ?B 3 calcFunc-utpb ) + ( ?C 2 calcFunc-utpc ) + ( ?F 3 calcFunc-utpf ) + ( ?N 3 calcFunc-utpn ) + ( ?P 2 calcFunc-utpp ) + ( ?T 2 calcFunc-utpt ) ) + ( ( ?n 1 calcFunc-prevprime ) + ( ?B 3 calcFunc-ltpb ) + ( ?C 2 calcFunc-ltpc ) + ( ?F 3 calcFunc-ltpf ) + ( ?N 3 calcFunc-ltpn ) + ( ?P 2 calcFunc-ltpp ) + ( ?T 2 calcFunc-ltpt ) ) + ( ( ?b 2 calcFunc-bern ) + ( ?c 2 calcFunc-perm ) + ( ?e 2 calcFunc-euler ) + ( ?s 2 calcFunc-stir2 ) ) +)) +(defconst calc-s-oper-keys '( ( ( ?: 2 calcFunc-assign ) + ( ?= 1 calcFunc-evalto ) ) +)) +(defconst calc-t-oper-keys '( ( ( ?C 3 calcFunc-tzconv ) + ( ?D 1 calcFunc-date ) + ( ?I 2 calcFunc-incmonth ) + ( ?J 1 calcFunc-julian ) + ( ?M 1 calcFunc-newmonth ) + ( ?W 1 calcFunc-newweek ) + ( ?U 1 calcFunc-unixtime ) + ( ?Y 1 calcFunc-newyear ) ) +)) +(defconst calc-u-oper-keys '( ( ( ?C 2 calcFunc-vcov ) + ( ?G 1 calcFunc-vgmean ) + ( ?M 1 calcFunc-vmean ) + ( ?N 1 calcFunc-vmin ) + ( ?S 1 calcFunc-vsdev ) + ( ?X 1 calcFunc-vmax ) ) + ( ( ?C 2 calcFunc-vpcov ) + ( ?M 1 calcFunc-vmeane ) + ( ?S 1 calcFunc-vpsdev ) ) + ( ( ?C 2 calcFunc-vcorr ) + ( ?G 1 calcFunc-agmean ) + ( ?M 1 calcFunc-vmedian ) + ( ?S 1 calcFunc-vvar ) ) + ( ( ?M 1 calcFunc-vhmean ) + ( ?S 1 calcFunc-vpvar ) ) +)) +(defconst calc-v-oper-keys '( ( ( ?a 2 calcFunc-arrange ) + ( ?b 2 calcFunc-cvec ) + ( ?c 2 calcFunc-mcol ) + ( ?d 2 calcFunc-diag ) + ( ?e 2 calcFunc-vexp ) + ( ?f 2 calcFunc-find ) + ( ?h 1 calcFunc-head ) + ( ?k 2 calcFunc-cons ) + ( ?l 1 calcFunc-vlen ) + ( ?m 2 calcFunc-vmask ) + ( ?n 1 calcFunc-rnorm ) + ( ?p 2 calcFunc-pack ) + ( ?r 2 calcFunc-mrow ) + ( ?s 3 calcFunc-subvec ) + ( ?t 1 calcFunc-trn ) + ( ?u 1 calcFunc-unpack ) + ( ?v 1 calcFunc-rev ) + ( ?x 1 calcFunc-index ) + ( ?A 1 calcFunc-apply ) + ( ?C 1 calcFunc-cross ) + ( ?D 1 calcFunc-det ) + ( ?E 1 calcFunc-venum ) + ( ?F 1 calcFunc-vfloor ) + ( ?G 1 calcFunc-grade ) + ( ?H 2 calcFunc-histogram ) + ( ?I 2 calcFunc-inner ) + ( ?L 1 calcFunc-lud ) + ( ?M 0 calcFunc-map ) + ( ?N 1 calcFunc-cnorm ) + ( ?O 2 calcFunc-outer ) + ( ?R 1 calcFunc-reduce ) + ( ?S 1 calcFunc-sort ) + ( ?T 1 calcFunc-tr ) + ( ?U 1 calcFunc-accum ) + ( ?V 2 calcFunc-vunion ) + ( ?X 2 calcFunc-vxor ) + ( ?- 2 calcFunc-vdiff ) + ( ?^ 2 calcFunc-vint ) + ( ?~ 1 calcFunc-vcompl ) + ( ?# 1 calcFunc-vcard ) + ( ?: 1 calcFunc-vspan ) + ( ?+ 1 calcFunc-rdup ) ) + ( ( ?h 1 calcFunc-tail ) + ( ?s 3 calcFunc-rsubvec ) + ( ?G 1 calcFunc-rgrade ) + ( ?R 1 calcFunc-rreduce ) + ( ?S 1 calcFunc-rsort ) + ( ?U 1 calcFunc-raccum ) ) + ( ( ?e 3 calcFunc-vexp ) + ( ?h 1 calcFunc-rhead ) + ( ?k 2 calcFunc-rcons ) + ( ?H 3 calcFunc-histogram ) + ( ?R 2 calcFunc-nest ) + ( ?U 2 calcFunc-anest ) ) + ( ( ?h 1 calcFunc-rtail ) + ( ?R 1 calcFunc-fixp ) + ( ?U 1 calcFunc-afixp ) ) +)) + + +;;; Convert a variable name (as a formula) into a like-looking function name. +(defun math-var-to-calcFunc (f) + (if (eq (car-safe f) 'var) + (if (fboundp (nth 2 f)) + (nth 2 f) + (intern (concat "calcFunc-" (symbol-name (nth 1 f))))) + (if (memq (car-safe f) '(lambda calcFunc-lambda)) + f + (math-reject-arg f "*Expected a function name"))) +) + +;;; Convert a function name into a like-looking variable name formula. +(defun math-calcFunc-to-var (f) + (if (symbolp f) + (let* ((func (or (cdr (assq f '( ( + . calcFunc-add ) + ( - . calcFunc-sub ) + ( * . calcFunc-mul ) + ( / . calcFunc-div ) + ( ^ . calcFunc-pow ) + ( % . calcFunc-mod ) + ( neg . calcFunc-neg ) + ( | . calcFunc-vconcat ) ))) + f)) + (base (if (string-match "\\`calcFunc-\\(.+\\)\\'" + (symbol-name func)) + (math-match-substring (symbol-name func) 1) + (symbol-name func)))) + (list 'var + (intern base) + (intern (concat "var-" base)))) + f) +) + +;;; Expand a function call using "lambda" notation. +(defun math-build-call (f args) + (if (eq (car-safe f) 'calcFunc-lambda) + (if (= (length args) (- (length f) 2)) + (math-multi-subst (nth (1- (length f)) f) (cdr f) args) + (calc-record-why "*Wrong number of arguments" f) + (cons 'calcFunc-call (cons (math-calcFunc-to-var f) args))) + (if (and (eq f 'calcFunc-neg) + (= (length args) 1)) + (list 'neg (car args)) + (let ((func (assq f '( ( calcFunc-add . + ) + ( calcFunc-sub . - ) + ( calcFunc-mul . * ) + ( calcFunc-div . / ) + ( calcFunc-pow . ^ ) + ( calcFunc-mod . % ) + ( calcFunc-vconcat . | ) )))) + (if (and func (= (length args) 2)) + (cons (cdr func) args) + (cons f args))))) +) + +;;; Do substitutions in parallel to avoid crosstalk. +(defun math-multi-subst (expr olds news) + (let ((args nil) + temp) + (while (and olds news) + (setq args (cons (cons (car olds) (car news)) args) + olds (cdr olds) + news (cdr news))) + (math-multi-subst-rec expr)) +) + +(defun math-multi-subst-rec (expr) + (cond ((setq temp (assoc expr args)) (cdr temp)) + ((Math-primp expr) expr) + ((and (eq (car expr) 'calcFunc-lambda) (> (length expr) 2)) + (let ((new (list (car expr))) + (args args)) + (while (cdr (setq expr (cdr expr))) + (setq new (cons (car expr) new)) + (if (assoc (car expr) args) + (setq args (cons (cons (car expr) (car expr)) args)))) + (nreverse (cons (math-multi-subst-rec (car expr)) new)))) + (t + (cons (car expr) + (mapcar 'math-multi-subst-rec (cdr expr))))) +) + +(defun calcFunc-call (f &rest args) + (setq args (math-build-call (math-var-to-calcFunc f) args)) + (if (eq (car-safe args) 'calcFunc-call) + args + (math-normalize args)) +) + +(defun calcFunc-apply (f args) + (or (Math-vectorp args) + (math-reject-arg args 'vectorp)) + (apply 'calcFunc-call (cons f (cdr args))) +) + + + + +;;; Map a function over a vector symbolically. [Public] +(defun math-symb-map (f mode args) + (let* ((func (math-var-to-calcFunc f)) + (nargs (length args)) + (ptrs (vconcat args)) + (vflags (make-vector nargs nil)) + (heads '(vec)) + (head nil) + (vec nil) + (i -1) + (math-working-step 0) + (math-working-step-2 nil) + len cols obj expr) + (if (eq mode 'eqn) + (setq mode 'elems + heads '(calcFunc-eq calcFunc-neq calcFunc-lt calcFunc-gt + calcFunc-leq calcFunc-geq)) + (while (and (< (setq i (1+ i)) nargs) + (not (math-matrixp (aref ptrs i))))) + (if (< i nargs) + (if (eq mode 'elems) + (setq func (list 'lambda '(&rest x) + (list 'math-symb-map + (list 'quote f) '(quote elems) 'x)) + mode 'rows) + (if (eq mode 'cols) + (while (< i nargs) + (if (math-matrixp (aref ptrs i)) + (aset ptrs i (math-transpose (aref ptrs i)))) + (setq i (1+ i))))) + (setq mode 'elems)) + (setq i -1)) + (while (< (setq i (1+ i)) nargs) + (setq obj (aref ptrs i)) + (if (and (memq (car-safe obj) heads) + (or (eq mode 'elems) + (math-matrixp obj))) + (progn + (aset vflags i t) + (if head + (if (cdr heads) + (setq head (nth + (aref (aref [ [0 1 2 3 4 5] + [1 1 2 3 2 3] + [2 2 2 1 2 1] + [3 3 1 3 1 3] + [4 2 2 1 4 1] + [5 3 1 3 1 5] ] + (- 6 (length (memq head heads)))) + (- 6 (length (memq (car obj) heads)))) + heads))) + (setq head (car obj))) + (if len + (or (= (length obj) len) + (math-dimension-error)) + (setq len (length obj)))))) + (or len + (if (= nargs 1) + (math-reject-arg (aref ptrs 0) 'vectorp) + (math-reject-arg nil "At least one argument must be a vector"))) + (setq math-working-step-2 (1- len)) + (while (> (setq len (1- len)) 0) + (setq expr nil + i -1) + (while (< (setq i (1+ i)) nargs) + (if (aref vflags i) + (progn + (aset ptrs i (cdr (aref ptrs i))) + (setq expr (nconc expr (list (car (aref ptrs i)))))) + (setq expr (nconc expr (list (aref ptrs i)))))) + (setq math-working-step (1+ math-working-step) + vec (cons (math-normalize (math-build-call func expr)) vec))) + (setq vec (cons head (nreverse vec))) + (if (and (eq mode 'cols) (math-matrixp vec)) + (math-transpose vec) + vec)) +) + +(defun calcFunc-map (func &rest args) + (math-symb-map func 'elems args) +) + +(defun calcFunc-mapr (func &rest args) + (math-symb-map func 'rows args) +) + +(defun calcFunc-mapc (func &rest args) + (math-symb-map func 'cols args) +) + +(defun calcFunc-mapa (func arg) + (if (math-matrixp arg) + (math-symb-map func 'elems (cdr (math-transpose arg))) + (math-symb-map func 'elems arg)) +) + +(defun calcFunc-mapd (func arg) + (if (math-matrixp arg) + (math-symb-map func 'elems (cdr arg)) + (math-symb-map func 'elems arg)) +) + +(defun calcFunc-mapeq (func &rest args) + (if (and (or (equal func '(var mul var-mul)) + (equal func '(var div var-div))) + (= (length args) 2)) + (if (math-negp (car args)) + (let ((func (nth 1 (assq (car-safe (nth 1 args)) + calc-tweak-eqn-table)))) + (and func (setq args (list (car args) + (cons func (cdr (nth 1 args))))))) + (if (math-negp (nth 1 args)) + (let ((func (nth 1 (assq (car-safe (car args)) + calc-tweak-eqn-table)))) + (and func (setq args (list (cons func (cdr (car args))) + (nth 1 args)))))))) + (if (or (and (equal func '(var div var-div)) + (assq (car-safe (nth 1 args)) calc-tweak-eqn-table)) + (equal func '(var neg var-neg)) + (equal func '(var inv var-inv))) + (apply 'calcFunc-mapeqr func args) + (apply 'calcFunc-mapeqp func args)) +) + +(defun calcFunc-mapeqr (func &rest args) + (setq args (mapcar (function (lambda (x) + (let ((func (assq (car-safe x) + calc-tweak-eqn-table))) + (if func + (cons (nth 1 func) (cdr x)) + x)))) + args)) + (apply 'calcFunc-mapeqp func args) +) + +(defun calcFunc-mapeqp (func &rest args) + (if (or (and (memq (car-safe (car args)) '(calcFunc-lt calcFunc-leq)) + (memq (car-safe (nth 1 args)) '(calcFunc-gt calcFunc-geq))) + (and (memq (car-safe (car args)) '(calcFunc-gt calcFunc-geq)) + (memq (car-safe (nth 1 args)) '(calcFunc-lt calcFunc-leq)))) + (setq args (cons (car args) + (cons (list (nth 1 (assq (car (nth 1 args)) + calc-tweak-eqn-table)) + (nth 2 (nth 1 args)) + (nth 1 (nth 1 args))) + (cdr (cdr args)))))) + (math-symb-map func 'eqn args) +) + + + +;;; Reduce a function over a vector symbolically. [Public] +(defun calcFunc-reduce (func vec) + (if (math-matrixp vec) + (let (expr row) + (setq func (math-var-to-calcFunc func)) + (while (setq vec (cdr vec)) + (setq row (car vec)) + (while (setq row (cdr row)) + (setq expr (if expr + (if (Math-numberp expr) + (math-normalize + (math-build-call func (list expr (car row)))) + (math-build-call func (list expr (car row)))) + (car row))))) + (math-normalize expr)) + (calcFunc-reducer func vec)) +) + +(defun calcFunc-rreduce (func vec) + (if (math-matrixp vec) + (let (expr row) + (setq func (math-var-to-calcFunc func) + vec (reverse (cdr vec))) + (while vec + (setq row (reverse (cdr (car vec)))) + (while row + (setq expr (if expr + (math-build-call func (list (car row) expr)) + (car row)) + row (cdr row))) + (setq vec (cdr vec))) + (math-normalize expr)) + (calcFunc-rreducer func vec)) +) + +(defun calcFunc-reducer (func vec) + (setq func (math-var-to-calcFunc func)) + (or (math-vectorp vec) + (math-reject-arg vec 'vectorp)) + (let ((expr (car (setq vec (cdr vec))))) + (if expr + (progn + (condition-case err + (and (symbolp func) + (let ((lfunc (or (cdr (assq func + '( (calcFunc-add . math-add) + (calcFunc-sub . math-sub) + (calcFunc-mul . math-mul) + (calcFunc-div . math-div) + (calcFunc-pow . math-pow) + (calcFunc-mod . math-mod) + (calcFunc-vconcat . + math-concat) ))) + lfunc))) + (while (cdr vec) + (setq expr (funcall lfunc expr (nth 1 vec)) + vec (cdr vec))))) + (error nil)) + (while (setq vec (cdr vec)) + (setq expr (math-build-call func (list expr (car vec))))) + (math-normalize expr)) + (or (math-identity-value func) + (math-reject-arg vec "*Vector is empty")))) +) + +(defun math-identity-value (func) + (cdr (assq func '( (calcFunc-add . 0) (calcFunc-sub . 0) + (calcFunc-mul . 1) (calcFunc-div . 1) + (calcFunc-idiv . 1) (calcFunc-fdiv . 1) + (calcFunc-min . (var inf var-inf)) + (calcFunc-max . (neg (var inf var-inf))) + (calcFunc-vconcat . (vec)) + (calcFunc-append . (vec)) ))) +) + +(defun calcFunc-rreducer (func vec) + (setq func (math-var-to-calcFunc func)) + (or (math-vectorp vec) + (math-reject-arg vec 'vectorp)) + (if (eq func 'calcFunc-sub) ; do this in a way that looks nicer + (let ((expr (car (setq vec (cdr vec))))) + (if expr + (progn + (while (setq vec (cdr vec)) + (setq expr (math-build-call func (list expr (car vec))) + func (if (eq func 'calcFunc-sub) + 'calcFunc-add 'calcFunc-sub))) + (math-normalize expr)) + 0)) + (let ((expr (car (setq vec (reverse (cdr vec)))))) + (if expr + (progn + (while (setq vec (cdr vec)) + (setq expr (math-build-call func (list (car vec) expr)))) + (math-normalize expr)) + (or (math-identity-value func) + (math-reject-arg vec "*Vector is empty"))))) +) + +(defun calcFunc-reducec (func vec) + (if (math-matrixp vec) + (calcFunc-reducer func (math-transpose vec)) + (calcFunc-reducer func vec)) +) + +(defun calcFunc-rreducec (func vec) + (if (math-matrixp vec) + (calcFunc-rreducer func (math-transpose vec)) + (calcFunc-rreducer func vec)) +) + +(defun calcFunc-reducea (func vec) + (if (math-matrixp vec) + (cons 'vec + (mapcar (function (lambda (x) (calcFunc-reducer func x))) + (cdr vec))) + (calcFunc-reducer func vec)) +) + +(defun calcFunc-rreducea (func vec) + (if (math-matrixp vec) + (cons 'vec + (mapcar (function (lambda (x) (calcFunc-rreducer func x))) + (cdr vec))) + (calcFunc-rreducer func vec)) +) + +(defun calcFunc-reduced (func vec) + (if (math-matrixp vec) + (cons 'vec + (mapcar (function (lambda (x) (calcFunc-reducer func x))) + (cdr (math-transpose vec)))) + (calcFunc-reducer func vec)) +) + +(defun calcFunc-rreduced (func vec) + (if (math-matrixp vec) + (cons 'vec + (mapcar (function (lambda (x) (calcFunc-rreducer func x))) + (cdr (math-transpose vec)))) + (calcFunc-rreducer func vec)) +) + +(defun calcFunc-accum (func vec) + (setq func (math-var-to-calcFunc func)) + (or (math-vectorp vec) + (math-reject-arg vec 'vectorp)) + (let* ((expr (car (setq vec (cdr vec)))) + (res (list 'vec expr))) + (or expr + (math-reject-arg vec "*Vector is empty")) + (while (setq vec (cdr vec)) + (setq expr (math-build-call func (list expr (car vec))) + res (nconc res (list expr)))) + (math-normalize res)) +) + +(defun calcFunc-raccum (func vec) + (setq func (math-var-to-calcFunc func)) + (or (math-vectorp vec) + (math-reject-arg vec 'vectorp)) + (let* ((expr (car (setq vec (reverse (cdr vec))))) + (res (list expr))) + (or expr + (math-reject-arg vec "*Vector is empty")) + (while (setq vec (cdr vec)) + (setq expr (math-build-call func (list (car vec) expr)) + res (cons (list expr) res))) + (math-normalize (cons 'vec res))) +) + + +(defun math-nest-calls (func base iters accum tol) + (or (symbolp tol) + (if (math-realp tol) + (or (math-numberp base) (math-reject-arg base 'numberp)) + (math-reject-arg tol 'realp))) + (setq func (math-var-to-calcFunc func)) + (or (null iters) + (if (equal iters '(var inf var-inf)) + (setq iters nil) + (progn + (if (math-messy-integerp iters) + (setq iters (math-trunc iters))) + (or (integerp iters) (math-reject-arg iters 'fixnump)) + (or (not tol) (natnump iters) (math-reject-arg iters 'fixnatnump)) + (if (< iters 0) + (let* ((dummy '(var DummyArg var-DummyArg)) + (dummy2 '(var DummyArg2 var-DummyArg2)) + (finv (math-solve-for (math-build-call func (list dummy2)) + dummy dummy2 nil))) + (or finv (math-reject-arg nil "*Unable to find an inverse")) + (if (and (= (length finv) 2) + (equal (nth 1 finv) dummy)) + (setq func (car finv)) + (setq func (list 'calcFunc-lambda dummy finv))) + (setq iters (- iters))))))) + (math-with-extra-prec 1 + (let ((value base) + (ovalue nil) + (avalues (list base)) + (math-working-step 0) + (math-working-step-2 iters)) + (while (and (or (null iters) + (>= (setq iters (1- iters)) 0)) + (or (null tol) + (null ovalue) + (if (eq tol t) + (not (if (and (Math-numberp value) + (Math-numberp ovalue)) + (math-nearly-equal value ovalue) + (Math-equal value ovalue))) + (if (math-numberp value) + (Math-lessp tol (math-abs (math-sub value ovalue))) + (math-reject-arg value 'numberp))))) + (setq ovalue value + math-working-step (1+ math-working-step) + value (math-normalize (math-build-call func (list value)))) + (if accum + (setq avalues (cons value avalues)))) + (if accum + (cons 'vec (nreverse avalues)) + value))) +) + +(defun calcFunc-nest (func base iters) + (math-nest-calls func base iters nil nil) +) + +(defun calcFunc-anest (func base iters) + (math-nest-calls func base iters t nil) +) + +(defun calcFunc-fixp (func base &optional iters tol) + (math-nest-calls func base iters nil (or tol t)) +) + +(defun calcFunc-afixp (func base &optional iters tol) + (math-nest-calls func base iters t (or tol t)) +) + + +(defun calcFunc-outer (func a b) + (or (math-vectorp a) (math-reject-arg a 'vectorp)) + (or (math-vectorp b) (math-reject-arg b 'vectorp)) + (setq func (math-var-to-calcFunc func)) + (let ((mat nil)) + (while (setq a (cdr a)) + (setq mat (cons (cons 'vec + (mapcar (function (lambda (x) + (math-build-call func + (list (car a) + x)))) + (cdr b))) + mat))) + (math-normalize (cons 'vec (nreverse mat)))) +) + + +(defun calcFunc-inner (mul-func add-func a b) + (or (math-vectorp a) (math-reject-arg a 'vectorp)) + (or (math-vectorp b) (math-reject-arg b 'vectorp)) + (if (math-matrixp a) + (if (math-matrixp b) + (if (= (length (nth 1 a)) (length b)) + (math-inner-mats a b) + (math-dimension-error)) + (if (= (length (nth 1 a)) 2) + (if (= (length a) (length b)) + (math-inner-mats a (list 'vec b)) + (math-dimension-error)) + (if (= (length (nth 1 a)) (length b)) + (math-mat-col (math-inner-mats a (math-col-matrix b)) + 1) + (math-dimension-error)))) + (if (math-matrixp b) + (nth 1 (math-inner-mats (list 'vec a) b)) + (calcFunc-reduce add-func (calcFunc-map mul-func a b)))) +) + +(defun math-inner-mats (a b) + (let ((mat nil) + (cols (length (nth 1 b))) + row col ap bp accum) + (while (setq a (cdr a)) + (setq col cols + row nil) + (while (> (setq col (1- col)) 0) + (setq row (cons (calcFunc-reduce add-func + (calcFunc-map mul-func + (car a) + (math-mat-col b col))) + row))) + (setq mat (cons (cons 'vec row) mat))) + (cons 'vec (nreverse mat))) +) + + + diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el new file mode 100644 index 0000000000..c7b841851e --- /dev/null +++ b/lisp/calc/calc-math.el @@ -0,0 +1,1783 @@ +;; Calculator for GNU Emacs, part II [calc-math.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-math () nil) + + +(defun calc-sqrt (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-unary-op "^2" 'calcFunc-sqr arg) + (calc-unary-op "sqrt" 'calcFunc-sqrt arg))) +) + +(defun calc-isqrt (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-unary-op "^2" 'calcFunc-sqr arg) + (calc-unary-op "isqt" 'calcFunc-isqrt arg))) +) + + +(defun calc-hypot (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "hypt" 'calcFunc-hypot arg)) +) + +(defun calc-ln (arg) + (interactive "P") + (calc-invert-func) + (calc-exp arg) +) + +(defun calc-log10 (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-ln arg) +) + +(defun calc-log (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-binary-op "alog" 'calcFunc-alog arg) + (calc-binary-op "log" 'calcFunc-log arg))) +) + +(defun calc-ilog (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-binary-op "alog" 'calcFunc-alog arg) + (calc-binary-op "ilog" 'calcFunc-ilog arg))) +) + +(defun calc-lnp1 (arg) + (interactive "P") + (calc-invert-func) + (calc-expm1 arg) +) + +(defun calc-exp (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (if (calc-is-inverse) + (calc-unary-op "lg10" 'calcFunc-log10 arg) + (calc-unary-op "10^" 'calcFunc-exp10 arg)) + (if (calc-is-inverse) + (calc-unary-op "ln" 'calcFunc-ln arg) + (calc-unary-op "exp" 'calcFunc-exp arg)))) +) + +(defun calc-expm1 (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-unary-op "ln+1" 'calcFunc-lnp1 arg) + (calc-unary-op "ex-1" 'calcFunc-expm1 arg))) +) + +(defun calc-pi () + (interactive) + (calc-slow-wrapper + (if (calc-is-inverse) + (if (calc-is-hyperbolic) + (if calc-symbolic-mode + (calc-pop-push-record 0 "phi" '(var phi var-phi)) + (calc-pop-push-record 0 "phi" (math-phi))) + (if calc-symbolic-mode + (calc-pop-push-record 0 "gmma" '(var gamma var-gamma)) + (calc-pop-push-record 0 "gmma" (math-gamma-const)))) + (if (calc-is-hyperbolic) + (if calc-symbolic-mode + (calc-pop-push-record 0 "e" '(var e var-e)) + (calc-pop-push-record 0 "e" (math-e))) + (if calc-symbolic-mode + (calc-pop-push-record 0 "pi" '(var pi var-pi)) + (calc-pop-push-record 0 "pi" (math-pi)))))) +) + +(defun calc-sin (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (if (calc-is-inverse) + (calc-unary-op "asnh" 'calcFunc-arcsinh arg) + (calc-unary-op "sinh" 'calcFunc-sinh arg)) + (if (calc-is-inverse) + (calc-unary-op "asin" 'calcFunc-arcsin arg) + (calc-unary-op "sin" 'calcFunc-sin arg)))) +) + +(defun calc-arcsin (arg) + (interactive "P") + (calc-invert-func) + (calc-sin arg) +) + +(defun calc-sinh (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-sin arg) +) + +(defun calc-arcsinh (arg) + (interactive "P") + (calc-invert-func) + (calc-hyperbolic-func) + (calc-sin arg) +) + +(defun calc-cos (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (if (calc-is-inverse) + (calc-unary-op "acsh" 'calcFunc-arccosh arg) + (calc-unary-op "cosh" 'calcFunc-cosh arg)) + (if (calc-is-inverse) + (calc-unary-op "acos" 'calcFunc-arccos arg) + (calc-unary-op "cos" 'calcFunc-cos arg)))) +) + +(defun calc-arccos (arg) + (interactive "P") + (calc-invert-func) + (calc-cos arg) +) + +(defun calc-cosh (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-cos arg) +) + +(defun calc-arccosh (arg) + (interactive "P") + (calc-invert-func) + (calc-hyperbolic-func) + (calc-cos arg) +) + +(defun calc-sincos () + (interactive) + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-enter-result 1 "asnc" (list 'calcFunc-arcsincos (calc-top-n 1))) + (calc-enter-result 1 "sncs" (list 'calcFunc-sincos (calc-top-n 1))))) +) + +(defun calc-tan (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (if (calc-is-inverse) + (calc-unary-op "atnh" 'calcFunc-arctanh arg) + (calc-unary-op "tanh" 'calcFunc-tanh arg)) + (if (calc-is-inverse) + (calc-unary-op "atan" 'calcFunc-arctan arg) + (calc-unary-op "tan" 'calcFunc-tan arg)))) +) + +(defun calc-arctan (arg) + (interactive "P") + (calc-invert-func) + (calc-tan arg) +) + +(defun calc-tanh (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-tan arg) +) + +(defun calc-arctanh (arg) + (interactive "P") + (calc-invert-func) + (calc-hyperbolic-func) + (calc-tan arg) +) + +(defun calc-arctan2 () + (interactive) + (calc-slow-wrapper + (calc-enter-result 2 "atn2" (cons 'calcFunc-arctan2 (calc-top-list-n 2)))) +) + +(defun calc-conj (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "conj" 'calcFunc-conj arg)) +) + +(defun calc-imaginary () + (interactive) + (calc-slow-wrapper + (calc-pop-push-record 1 "i*" (math-imaginary (calc-top-n 1)))) +) + + + +(defun calc-to-degrees (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op ">deg" 'calcFunc-deg arg)) +) + +(defun calc-to-radians (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op ">rad" 'calcFunc-rad arg)) +) + + +(defun calc-degrees-mode (arg) + (interactive "p") + (cond ((= arg 1) + (calc-wrapper + (calc-change-mode 'calc-angle-mode 'deg) + (message "Angles measured in degrees."))) + ((= arg 2) (calc-radians-mode)) + ((= arg 3) (calc-hms-mode)) + (t (error "Prefix argument out of range"))) +) + +(defun calc-radians-mode () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-angle-mode 'rad) + (message "Angles measured in radians.")) +) + + +;;; Compute the integer square-root floor(sqrt(A)). A > 0. [I I] [Public] +;;; This method takes advantage of the fact that Newton's method starting +;;; with an overestimate always works, even using truncating integer division! +(defun math-isqrt (a) + (cond ((Math-zerop a) a) + ((not (math-natnump a)) + (math-reject-arg a 'natnump)) + ((integerp a) + (math-isqrt-small a)) + (t + (math-normalize (cons 'bigpos (cdr (math-isqrt-bignum (cdr a))))))) +) + +(defun calcFunc-isqrt (a) + (if (math-realp a) + (math-isqrt (math-floor a)) + (math-floor (math-sqrt a))) +) + + +;;; This returns (flag . result) where the flag is T if A is a perfect square. +(defun math-isqrt-bignum (a) ; [P.l L] + (let ((len (length a))) + (if (= (% len 2) 0) + (let* ((top (nthcdr (- len 2) a))) + (math-isqrt-bignum-iter + a + (math-scale-bignum-3 + (math-bignum-big + (1+ (math-isqrt-small + (+ (* (nth 1 top) 1000) (car top))))) + (1- (/ len 2))))) + (let* ((top (nth (1- len) a))) + (math-isqrt-bignum-iter + a + (math-scale-bignum-3 + (list (1+ (math-isqrt-small top))) + (/ len 2)))))) +) + +(defun math-isqrt-bignum-iter (a guess) ; [l L l] + (math-working "isqrt" (cons 'bigpos guess)) + (let* ((q (math-div-bignum a guess)) + (s (math-add-bignum (car q) guess)) + (g2 (math-div2-bignum s)) + (comp (math-compare-bignum g2 guess))) + (if (< comp 0) + (math-isqrt-bignum-iter a g2) + (cons (and (= comp 0) + (math-zerop-bignum (cdr q)) + (= (% (car s) 2) 0)) + guess))) +) + +(defun math-zerop-bignum (a) + (and (eq (car a) 0) + (progn + (while (eq (car (setq a (cdr a))) 0)) + (null a))) +) + +(defun math-scale-bignum-3 (a n) ; [L L S] + (while (> n 0) + (setq a (cons 0 a) + n (1- n))) + a +) + +(defun math-isqrt-small (a) ; A > 0. [S S] + (let ((g (cond ((>= a 10000) 1000) + ((>= a 100) 100) + (t 10))) + g2) + (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) + (setq g g2)) + g) +) + + + + +;;; Compute the square root of a number. +;;; [T N] if possible, else [F N] if possible, else [C N]. [Public] +(defun math-sqrt (a) + (or + (and (Math-zerop a) a) + (and (math-known-nonposp a) + (math-imaginary (math-sqrt (math-neg a)))) + (and (integerp a) + (let ((sqrt (math-isqrt-small a))) + (if (= (* sqrt sqrt) a) + sqrt + (if calc-symbolic-mode + (list 'calcFunc-sqrt a) + (math-sqrt-float (math-float a) (math-float sqrt)))))) + (and (eq (car-safe a) 'bigpos) + (let* ((res (math-isqrt-bignum (cdr a))) + (sqrt (math-normalize (cons 'bigpos (cdr res))))) + (if (car res) + sqrt + (if calc-symbolic-mode + (list 'calcFunc-sqrt a) + (math-sqrt-float (math-float a) (math-float sqrt)))))) + (and (eq (car-safe a) 'frac) + (let* ((num-res (math-isqrt-bignum (cdr (Math-bignum-test (nth 1 a))))) + (num-sqrt (math-normalize (cons 'bigpos (cdr num-res)))) + (den-res (math-isqrt-bignum (cdr (Math-bignum-test (nth 2 a))))) + (den-sqrt (math-normalize (cons 'bigpos (cdr den-res))))) + (if (and (car num-res) (car den-res)) + (list 'frac num-sqrt den-sqrt) + (if calc-symbolic-mode + (if (or (car num-res) (car den-res)) + (math-div (if (car num-res) + num-sqrt (list 'calcFunc-sqrt (nth 1 a))) + (if (car den-res) + den-sqrt (list 'calcFunc-sqrt (nth 2 a)))) + (list 'calcFunc-sqrt a)) + (math-sqrt-float (math-float a) + (math-div (math-float num-sqrt) den-sqrt)))))) + (and (eq (car-safe a) 'float) + (if calc-symbolic-mode + (if (= (% (nth 2 a) 2) 0) + (let ((res (math-isqrt-bignum + (cdr (Math-bignum-test (nth 1 a)))))) + (if (car res) + (math-make-float (math-normalize + (cons 'bigpos (cdr res))) + (/ (nth 2 a) 2)) + (signal 'inexact-result nil))) + (signal 'inexact-result nil)) + (math-sqrt-float a))) + (and (eq (car-safe a) 'cplx) + (math-with-extra-prec 2 + (let* ((d (math-abs a)) + (imag (math-sqrt (math-mul (math-sub d (nth 1 a)) + '(float 5 -1))))) + (list 'cplx + (math-sqrt (math-mul (math-add d (nth 1 a)) '(float 5 -1))) + (if (math-negp (nth 2 a)) (math-neg imag) imag))))) + (and (eq (car-safe a) 'polar) + (list 'polar + (math-sqrt (nth 1 a)) + (math-mul (nth 2 a) '(float 5 -1)))) + (and (eq (car-safe a) 'sdev) + (let ((sqrt (math-sqrt (nth 1 a)))) + (math-make-sdev sqrt + (math-div (nth 2 a) (math-mul sqrt 2))))) + (and (eq (car-safe a) 'intv) + (not (math-negp (nth 2 a))) + (math-make-intv (nth 1 a) (math-sqrt (nth 2 a)) (math-sqrt (nth 3 a)))) + (and (eq (car-safe a) '*) + (or (math-known-nonnegp (nth 1 a)) + (math-known-nonnegp (nth 2 a))) + (math-mul (math-sqrt (nth 1 a)) (math-sqrt (nth 2 a)))) + (and (eq (car-safe a) '/) + (or (and (math-known-nonnegp (nth 2 a)) + (math-div (math-sqrt (nth 1 a)) (math-sqrt (nth 2 a)))) + (and (math-known-nonnegp (nth 1 a)) + (not (math-equal-int (nth 1 a) 1)) + (math-mul (math-sqrt (nth 1 a)) + (math-sqrt (math-div 1 (nth 2 a))))))) + (and (eq (car-safe a) '^) + (math-known-evenp (nth 2 a)) + (math-known-realp (nth 1 a)) + (math-abs (math-pow (nth 1 a) (math-div (nth 2 a) 2)))) + (let ((inf (math-infinitep a))) + (and inf + (math-mul (math-sqrt (math-infinite-dir a inf)) inf))) + (progn + (calc-record-why 'numberp a) + (list 'calcFunc-sqrt a))) +) +(fset 'calcFunc-sqrt (symbol-function 'math-sqrt)) + +(defun math-infinite-dir (a &optional inf) + (or inf (setq inf (math-infinitep a))) + (math-normalize (math-expr-subst a inf 1)) +) + +(defun math-sqrt-float (a &optional guess) ; [F F F] + (if calc-symbolic-mode + (signal 'inexact-result nil) + (math-with-extra-prec 1 (math-sqrt-raw a guess))) +) + +(defun math-sqrt-raw (a &optional guess) ; [F F F] + (if (not (Math-posp a)) + (math-sqrt a) + (if (null guess) + (let ((ldiff (- (math-numdigs (nth 1 a)) 6))) + (or (= (% (+ (nth 2 a) ldiff) 2) 0) (setq ldiff (1+ ldiff))) + (setq guess (math-make-float (math-isqrt-small + (math-scale-int (nth 1 a) (- ldiff))) + (/ (+ (nth 2 a) ldiff) 2))))) + (math-sqrt-float-iter a guess)) +) + +(defun math-sqrt-float-iter (a guess) ; [F F F] + (math-working "sqrt" guess) + (let ((g2 (math-mul-float (math-add-float guess (math-div-float a guess)) + '(float 5 -1)))) + (if (math-nearly-equal-float g2 guess) + g2 + (math-sqrt-float-iter a g2))) +) + +;;; True if A and B differ only in the last digit of precision. [P F F] +(defun math-nearly-equal-float (a b) + (let ((ediff (- (nth 2 a) (nth 2 b)))) + (cond ((= ediff 0) ;; Expanded out for speed + (setq ediff (math-add (Math-integer-neg (nth 1 a)) (nth 1 b))) + (or (eq ediff 0) + (and (not (consp ediff)) + (< ediff 10) + (> ediff -10) + (= (math-numdigs (nth 1 a)) calc-internal-prec)))) + ((= ediff 1) + (setq ediff (math-add (Math-integer-neg (nth 1 b)) + (math-scale-int (nth 1 a) 1))) + (and (not (consp ediff)) + (< ediff 10) + (> ediff -10) + (= (math-numdigs (nth 1 b)) calc-internal-prec))) + ((= ediff -1) + (setq ediff (math-add (Math-integer-neg (nth 1 a)) + (math-scale-int (nth 1 b) 1))) + (and (not (consp ediff)) + (< ediff 10) + (> ediff -10) + (= (math-numdigs (nth 1 a)) calc-internal-prec))))) +) + +(defun math-nearly-equal (a b) ; [P N N] [Public] + (setq a (math-float a)) + (setq b (math-float b)) + (if (eq (car a) 'polar) (setq a (math-complex a))) + (if (eq (car b) 'polar) (setq b (math-complex b))) + (if (eq (car a) 'cplx) + (if (eq (car b) 'cplx) + (and (or (math-nearly-equal-float (nth 1 a) (nth 1 b)) + (and (math-nearly-zerop-float (nth 1 a) (nth 2 a)) + (math-nearly-zerop-float (nth 1 b) (nth 2 b)))) + (or (math-nearly-equal-float (nth 2 a) (nth 2 b)) + (and (math-nearly-zerop-float (nth 2 a) (nth 1 a)) + (math-nearly-zerop-float (nth 2 b) (nth 1 b))))) + (and (math-nearly-equal-float (nth 1 a) b) + (math-nearly-zerop-float (nth 2 a) b))) + (if (eq (car b) 'cplx) + (and (math-nearly-equal-float a (nth 1 b)) + (math-nearly-zerop-float a (nth 2 b))) + (math-nearly-equal-float a b))) +) + +;;; True if A is nearly zero compared to B. [P F F] +(defun math-nearly-zerop-float (a b) + (or (eq (nth 1 a) 0) + (<= (+ (math-numdigs (nth 1 a)) (nth 2 a)) + (1+ (- (+ (math-numdigs (nth 1 b)) (nth 2 b)) calc-internal-prec)))) +) + +(defun math-nearly-zerop (a b) ; [P N R] [Public] + (setq a (math-float a)) + (setq b (math-float b)) + (if (eq (car a) 'cplx) + (and (math-nearly-zerop-float (nth 1 a) b) + (math-nearly-zerop-float (nth 2 a) b)) + (if (eq (car a) 'polar) + (math-nearly-zerop-float (nth 1 a) b) + (math-nearly-zerop-float a b))) +) + +;;; This implementation could be improved, accuracy-wise. +(defun math-hypot (a b) + (cond ((Math-zerop a) (math-abs b)) + ((Math-zerop b) (math-abs a)) + ((not (Math-scalarp a)) + (if (math-infinitep a) + (if (math-infinitep b) + (if (equal a b) + a + '(var nan var-nan)) + a) + (calc-record-why 'scalarp a) + (list 'calcFunc-hypot a b))) + ((not (Math-scalarp b)) + (if (math-infinitep b) + b + (calc-record-why 'scalarp b) + (list 'calcFunc-hypot a b))) + ((and (Math-numberp a) (Math-numberp b)) + (math-with-extra-prec 1 + (math-sqrt (math-add (calcFunc-abssqr a) (calcFunc-abssqr b))))) + ((eq (car-safe a) 'hms) + (if (eq (car-safe b) 'hms) ; this helps sdev's of hms forms + (math-to-hms (math-hypot (math-from-hms a 'deg) + (math-from-hms b 'deg))) + (math-to-hms (math-hypot (math-from-hms a 'deg) b)))) + ((eq (car-safe b) 'hms) + (math-to-hms (math-hypot a (math-from-hms b 'deg)))) + (t nil)) +) +(fset 'calcFunc-hypot (symbol-function 'math-hypot)) + +(defun calcFunc-sqr (x) + (math-pow x 2) +) + + + +(defun math-nth-root (a n) + (cond ((= n 2) (math-sqrt a)) + ((Math-zerop a) a) + ((Math-negp a) nil) + ((Math-integerp a) + (let ((root (math-nth-root-integer a n))) + (if (car root) + (cdr root) + (and (not calc-symbolic-mode) + (math-nth-root-float (math-float a) n + (math-float (cdr root))))))) + ((eq (car-safe a) 'frac) + (let* ((num-root (math-nth-root-integer (nth 1 a) n)) + (den-root (math-nth-root-integer (nth 2 a) n))) + (if (and (car num-root) (car den-root)) + (list 'frac (cdr num-root) (cdr den-root)) + (and (not calc-symbolic-mode) + (math-nth-root-float + (math-float a) n + (math-div-float (math-float (cdr num-root)) + (math-float (cdr den-root)))))))) + ((eq (car-safe a) 'float) + (and (not calc-symbolic-mode) + (math-nth-root-float a n))) + ((eq (car-safe a) 'polar) + (let ((root (math-nth-root (nth 1 a) n))) + (and root (list 'polar root (math-div (nth 2 a) n))))) + (t nil)) +) + +(defun math-nth-root-float (a n &optional guess) + (math-inexact-result) + (math-with-extra-prec 1 + (let ((nf (math-float n)) + (nfm1 (math-float (1- n)))) + (math-nth-root-float-iter a (or guess + (math-make-float + 1 (/ (+ (math-numdigs (nth 1 a)) + (nth 2 a) + (/ n 2)) + n)))))) +) + +(defun math-nth-root-float-iter (a guess) ; uses "n", "nf", "nfm1" + (math-working "root" guess) + (let ((g2 (math-div-float (math-add-float (math-mul nfm1 guess) + (math-div-float + a (math-ipow guess (1- n)))) + nf))) + (if (math-nearly-equal-float g2 guess) + g2 + (math-nth-root-float-iter a g2))) +) + +(defun math-nth-root-integer (a n &optional guess) ; [I I S] + (math-nth-root-int-iter a (or guess + (math-scale-int 1 (/ (+ (math-numdigs a) + (1- n)) + n)))) +) + +(defun math-nth-root-int-iter (a guess) ; uses "n" + (math-working "root" guess) + (let* ((q (math-idivmod a (math-ipow guess (1- n)))) + (s (math-add (car q) (math-mul (1- n) guess))) + (g2 (math-idivmod s n))) + (if (Math-natnum-lessp (car g2) guess) + (math-nth-root-int-iter a (car g2)) + (cons (and (equal (car g2) guess) + (eq (cdr q) 0) + (eq (cdr g2) 0)) + guess))) +) + +(defun calcFunc-nroot (x n) + (calcFunc-pow x (if (integerp n) + (math-make-frac 1 n) + (math-div 1 n))) +) + + + + +;;;; Transcendental functions. + +;;; All of these functions are defined on the complex plane. +;;; (Branch cuts, etc. follow Steele's Common Lisp book.) + +;;; Most functions increase calc-internal-prec by 2 digits, then round +;;; down afterward. "-raw" functions use the current precision, require +;;; their arguments to be in float (or complex float) format, and always +;;; work in radians (where applicable). + +(defun math-to-radians (a) ; [N N] + (cond ((eq (car-safe a) 'hms) + (math-from-hms a 'rad)) + ((memq calc-angle-mode '(deg hms)) + (math-mul a (math-pi-over-180))) + (t a)) +) + +(defun math-from-radians (a) ; [N N] + (cond ((eq calc-angle-mode 'deg) + (if (math-constp a) + (math-div a (math-pi-over-180)) + (list 'calcFunc-deg a))) + ((eq calc-angle-mode 'hms) + (math-to-hms a 'rad)) + (t a)) +) + +(defun math-to-radians-2 (a) ; [N N] + (cond ((eq (car-safe a) 'hms) + (math-from-hms a 'rad)) + ((memq calc-angle-mode '(deg hms)) + (if calc-symbolic-mode + (math-div (math-mul a '(var pi var-pi)) 180) + (math-mul a (math-pi-over-180)))) + (t a)) +) + +(defun math-from-radians-2 (a) ; [N N] + (cond ((memq calc-angle-mode '(deg hms)) + (if calc-symbolic-mode + (math-div (math-mul 180 a) '(var pi var-pi)) + (math-div a (math-pi-over-180)))) + (t a)) +) + + + +;;; Sine, cosine, and tangent. + +(defun calcFunc-sin (x) ; [N N] [Public] + (cond ((and (integerp x) + (if (eq calc-angle-mode 'deg) + (= (% x 90) 0) + (= x 0))) + (aref [0 1 0 -1] (math-mod (/ x 90) 4))) + ((Math-scalarp x) + (math-with-extra-prec 2 + (math-sin-raw (math-to-radians (math-float x))))) + ((eq (car x) 'sdev) + (if (math-constp x) + (math-with-extra-prec 2 + (let* ((xx (math-to-radians (math-float (nth 1 x)))) + (xs (math-to-radians (math-float (nth 2 x)))) + (sc (math-sin-cos-raw xx))) + (math-make-sdev (car sc) (math-mul xs (cdr sc))))) + (math-make-sdev (calcFunc-sin (nth 1 x)) + (math-mul (nth 2 x) (calcFunc-cos (nth 1 x)))))) + ((and (eq (car x) 'intv) (math-intv-constp x)) + (calcFunc-cos (math-sub x (math-quarter-circle nil)))) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'scalarp x) + (list 'calcFunc-sin x))) +) + +(defun calcFunc-cos (x) ; [N N] [Public] + (cond ((and (integerp x) + (if (eq calc-angle-mode 'deg) + (= (% x 90) 0) + (= x 0))) + (aref [1 0 -1 0] (math-mod (/ x 90) 4))) + ((Math-scalarp x) + (math-with-extra-prec 2 + (math-cos-raw (math-to-radians (math-float x))))) + ((eq (car x) 'sdev) + (if (math-constp x) + (math-with-extra-prec 2 + (let* ((xx (math-to-radians (math-float (nth 1 x)))) + (xs (math-to-radians (math-float (nth 2 x)))) + (sc (math-sin-cos-raw xx))) + (math-make-sdev (cdr sc) (math-mul xs (car sc))))) + (math-make-sdev (calcFunc-cos (nth 1 x)) + (math-mul (nth 2 x) (calcFunc-sin (nth 1 x)))))) + ((and (eq (car x) 'intv) (math-intv-constp x)) + (math-with-extra-prec 2 + (let* ((xx (math-to-radians (math-float x))) + (na (math-floor (math-div (nth 2 xx) (math-pi)))) + (nb (math-floor (math-div (nth 3 xx) (math-pi)))) + (span (math-sub nb na))) + (if (memq span '(0 1)) + (let ((int (math-sort-intv (nth 1 x) + (math-cos-raw (nth 2 xx)) + (math-cos-raw (nth 3 xx))))) + (if (eq span 1) + (if (math-evenp na) + (math-make-intv (logior (nth 1 x) 2) + -1 + (nth 3 int)) + (math-make-intv (logior (nth 1 x) 1) + (nth 2 int) + 1)) + int)) + (list 'intv 3 -1 1))))) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'scalarp x) + (list 'calcFunc-cos x))) +) + +(defun calcFunc-sincos (x) ; [V N] [Public] + (if (Math-scalarp x) + (math-with-extra-prec 2 + (let ((sc (math-sin-cos-raw (math-to-radians (math-float x))))) + (list 'vec (cdr sc) (car sc)))) ; the vector [cos, sin] + (list 'vec (calcFunc-sin x) (calcFunc-cos x))) +) + +(defun calcFunc-tan (x) ; [N N] [Public] + (cond ((and (integerp x) + (if (eq calc-angle-mode 'deg) + (= (% x 180) 0) + (= x 0))) + 0) + ((Math-scalarp x) + (math-with-extra-prec 2 + (math-tan-raw (math-to-radians (math-float x))))) + ((eq (car x) 'sdev) + (if (math-constp x) + (math-with-extra-prec 2 + (let* ((xx (math-to-radians (math-float (nth 1 x)))) + (xs (math-to-radians (math-float (nth 2 x)))) + (sc (math-sin-cos-raw xx))) + (if (and (math-zerop (cdr sc)) (not calc-infinite-mode)) + (progn + (calc-record-why "*Division by zero") + (list 'calcFunc-tan x)) + (math-make-sdev (math-div-float (car sc) (cdr sc)) + (math-div-float xs (math-sqr (cdr sc))))))) + (math-make-sdev (calcFunc-tan (nth 1 x)) + (math-div (nth 2 x) + (math-sqr (calcFunc-cos (nth 1 x))))))) + ((and (eq (car x) 'intv) (math-intv-constp x)) + (or (math-with-extra-prec 2 + (let* ((xx (math-to-radians (math-float x))) + (na (math-floor (math-div (math-sub (nth 2 xx) + (math-pi-over-2)) + (math-pi)))) + (nb (math-floor (math-div (math-sub (nth 3 xx) + (math-pi-over-2)) + (math-pi))))) + (and (equal na nb) + (math-sort-intv (nth 1 x) + (math-tan-raw (nth 2 xx)) + (math-tan-raw (nth 3 xx)))))) + '(intv 3 (neg (var inf var-inf)) (var inf var-inf)))) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'scalarp x) + (list 'calcFunc-tan x))) +) + +(defun math-sin-raw (x) ; [N N] + (cond ((eq (car x) 'cplx) + (let* ((expx (math-exp-raw (nth 2 x))) + (expmx (math-div-float '(float 1 0) expx)) + (sc (math-sin-cos-raw (nth 1 x)))) + (list 'cplx + (math-mul-float (car sc) + (math-mul-float (math-add-float expx expmx) + '(float 5 -1))) + (math-mul-float (cdr sc) + (math-mul-float (math-sub-float expx expmx) + '(float 5 -1)))))) + ((eq (car x) 'polar) + (math-polar (math-sin-raw (math-complex x)))) + ((Math-integer-negp (nth 1 x)) + (math-neg-float (math-sin-raw (math-neg-float x)))) + ((math-lessp-float '(float 7 0) x) ; avoid inf loops due to roundoff + (math-sin-raw (math-mod x (math-two-pi)))) + (t (math-sin-raw-2 x x))) +) + +(defun math-cos-raw (x) ; [N N] + (if (eq (car-safe x) 'polar) + (math-polar (math-cos-raw (math-complex x))) + (math-sin-raw (math-sub (math-pi-over-2) x))) +) + +;;; This could use a smarter method: Reduce x as in math-sin-raw, then +;;; compute either sin(x) or cos(x), whichever is smaller, and compute +;;; the other using the identity sin(x)^2 + cos(x)^2 = 1. +(defun math-sin-cos-raw (x) ; [F.F F] (result is (sin x . cos x)) + (cons (math-sin-raw x) (math-cos-raw x)) +) + +(defun math-tan-raw (x) ; [N N] + (cond ((eq (car x) 'cplx) + (let* ((x (math-mul x '(float 2 0))) + (expx (math-exp-raw (nth 2 x))) + (expmx (math-div-float '(float 1 0) expx)) + (sc (math-sin-cos-raw (nth 1 x))) + (d (math-add-float (cdr sc) + (math-mul-float (math-add-float expx expmx) + '(float 5 -1))))) + (and (not (eq (nth 1 d) 0)) + (list 'cplx + (math-div-float (car sc) d) + (math-div-float (math-mul-float (math-sub-float expx + expmx) + '(float 5 -1)) d))))) + ((eq (car x) 'polar) + (math-polar (math-tan-raw (math-complex x)))) + (t + (let ((sc (math-sin-cos-raw x))) + (if (eq (nth 1 (cdr sc)) 0) + (math-div (car sc) 0) + (math-div-float (car sc) (cdr sc)))))) +) + +(defun math-sin-raw-2 (x orgx) ; This avoids poss of inf recursion. [F F] + (let ((xmpo2 (math-sub-float (math-pi-over-2) x))) + (cond ((Math-integer-negp (nth 1 xmpo2)) + (math-neg-float (math-sin-raw-2 (math-sub-float x (math-pi)) + orgx))) + ((math-lessp-float (math-pi-over-4) x) + (math-cos-raw-2 xmpo2 orgx)) + ((math-lessp-float x (math-neg (math-pi-over-4))) + (math-neg (math-cos-raw-2 (math-add (math-pi-over-2) x) orgx))) + ((math-nearly-zerop-float x orgx) '(float 0 0)) + (calc-symbolic-mode (signal 'inexact-result nil)) + (t (math-sin-series x 6 4 x (math-neg-float (math-sqr-float x)))))) +) + +(defun math-cos-raw-2 (x orgx) ; [F F] + (cond ((math-nearly-zerop-float x orgx) '(float 1 0)) + (calc-symbolic-mode (signal 'inexact-result nil)) + (t (let ((xnegsqr (math-neg-float (math-sqr-float x)))) + (math-sin-series + (math-add-float '(float 1 0) + (math-mul-float xnegsqr '(float 5 -1))) + 24 5 xnegsqr xnegsqr)))) +) + +(defun math-sin-series (sum nfac n x xnegsqr) + (math-working "sin" sum) + (let* ((nextx (math-mul-float x xnegsqr)) + (nextsum (math-add-float sum (math-div-float nextx + (math-float nfac))))) + (if (math-nearly-equal-float sum nextsum) + sum + (math-sin-series nextsum (math-mul nfac (* n (1+ n))) + (+ n 2) nextx xnegsqr))) +) + + +;;; Inverse sine, cosine, tangent. + +(defun calcFunc-arcsin (x) ; [N N] [Public] + (cond ((eq x 0) 0) + ((and (eq x 1) (eq calc-angle-mode 'deg)) 90) + ((and (eq x -1) (eq calc-angle-mode 'deg)) -90) + (calc-symbolic-mode (signal 'inexact-result nil)) + ((Math-numberp x) + (math-with-extra-prec 2 + (math-from-radians (math-arcsin-raw (math-float x))))) + ((eq (car x) 'sdev) + (math-make-sdev (calcFunc-arcsin (nth 1 x)) + (math-from-radians + (math-div (nth 2 x) + (math-sqrt + (math-sub 1 (math-sqr (nth 1 x)))))))) + ((eq (car x) 'intv) + (math-sort-intv (nth 1 x) + (calcFunc-arcsin (nth 2 x)) + (calcFunc-arcsin (nth 3 x)))) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-arcsin x))) +) + +(defun calcFunc-arccos (x) ; [N N] [Public] + (cond ((eq x 1) 0) + ((and (eq x 0) (eq calc-angle-mode 'deg)) 90) + ((and (eq x -1) (eq calc-angle-mode 'deg)) 180) + (calc-symbolic-mode (signal 'inexact-result nil)) + ((Math-numberp x) + (math-with-extra-prec 2 + (math-from-radians (math-arccos-raw (math-float x))))) + ((eq (car x) 'sdev) + (math-make-sdev (calcFunc-arccos (nth 1 x)) + (math-from-radians + (math-div (nth 2 x) + (math-sqrt + (math-sub 1 (math-sqr (nth 1 x)))))))) + ((eq (car x) 'intv) + (math-sort-intv (nth 1 x) + (calcFunc-arccos (nth 2 x)) + (calcFunc-arccos (nth 3 x)))) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-arccos x))) +) + +(defun calcFunc-arctan (x) ; [N N] [Public] + (cond ((eq x 0) 0) + ((and (eq x 1) (eq calc-angle-mode 'deg)) 45) + ((and (eq x -1) (eq calc-angle-mode 'deg)) -45) + ((Math-numberp x) + (math-with-extra-prec 2 + (math-from-radians (math-arctan-raw (math-float x))))) + ((eq (car x) 'sdev) + (math-make-sdev (calcFunc-arctan (nth 1 x)) + (math-from-radians + (math-div (nth 2 x) + (math-add 1 (math-sqr (nth 1 x))))))) + ((eq (car x) 'intv) + (math-sort-intv (nth 1 x) + (calcFunc-arctan (nth 2 x)) + (calcFunc-arctan (nth 3 x)))) + ((equal x '(var inf var-inf)) + (math-quarter-circle t)) + ((equal x '(neg (var inf var-inf))) + (math-neg (math-quarter-circle t))) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-arctan x))) +) + +(defun math-arcsin-raw (x) ; [N N] + (let ((a (math-sqrt-raw (math-sub '(float 1 0) (math-sqr x))))) + (if (or (memq (car x) '(cplx polar)) + (memq (car a) '(cplx polar))) + (math-with-extra-prec 2 ; use extra precision for difficult case + (math-mul '(cplx 0 -1) + (math-ln-raw (math-add (math-mul '(cplx 0 1) x) a)))) + (math-arctan2-raw x a))) +) + +(defun math-arccos-raw (x) ; [N N] + (math-sub (math-pi-over-2) (math-arcsin-raw x)) +) + +(defun math-arctan-raw (x) ; [N N] + (cond ((memq (car x) '(cplx polar)) + (math-with-extra-prec 2 ; extra-extra + (math-div (math-sub + (math-ln-raw (math-add 1 (math-mul '(cplx 0 1) x))) + (math-ln-raw (math-add 1 (math-mul '(cplx 0 -1) x)))) + '(cplx 0 2)))) + ((Math-integer-negp (nth 1 x)) + (math-neg-float (math-arctan-raw (math-neg-float x)))) + ((math-zerop x) x) + (calc-symbolic-mode (signal 'inexact-result nil)) + ((math-equal-int x 1) (math-pi-over-4)) + ((math-equal-int x -1) (math-neg (math-pi-over-4))) + ((math-lessp-float '(float 414214 -6) x) ; if x > sqrt(2) - 1, reduce + (if (math-lessp-float '(float 1 0) x) + (math-sub-float (math-mul-float (math-pi) '(float 5 -1)) + (math-arctan-raw (math-div-float '(float 1 0) x))) + (math-sub-float (math-mul-float (math-pi) '(float 25 -2)) + (math-arctan-raw (math-div-float + (math-sub-float '(float 1 0) x) + (math-add-float '(float 1 0) + x)))))) + (t (math-arctan-series x 3 x (math-neg-float (math-sqr-float x))))) +) + +(defun math-arctan-series (sum n x xnegsqr) + (math-working "arctan" sum) + (let* ((nextx (math-mul-float x xnegsqr)) + (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) + (if (math-nearly-equal-float sum nextsum) + sum + (math-arctan-series nextsum (+ n 2) nextx xnegsqr))) +) + +(defun calcFunc-arctan2 (y x) ; [F R R] [Public] + (if (Math-anglep y) + (if (Math-anglep x) + (math-with-extra-prec 2 + (math-from-radians (math-arctan2-raw (math-float y) + (math-float x)))) + (calc-record-why 'anglep x) + (list 'calcFunc-arctan2 y x)) + (if (and (or (math-infinitep x) (math-anglep x)) + (or (math-infinitep y) (math-anglep y))) + (progn + (if (math-posp x) + (setq x 1) + (if (math-negp x) + (setq x -1) + (or (math-zerop x) + (setq x nil)))) + (if (math-posp y) + (setq y 1) + (if (math-negp y) + (setq y -1) + (or (math-zerop y) + (setq y nil)))) + (if (and y x) + (calcFunc-arctan2 y x) + '(var nan var-nan))) + (calc-record-why 'anglep y) + (list 'calcFunc-arctan2 y x))) +) + +(defun math-arctan2-raw (y x) ; [F R R] + (cond ((math-zerop y) + (if (math-negp x) (math-pi) + (if (or (math-floatp x) (math-floatp y)) '(float 0 0) 0))) + ((math-zerop x) + (if (math-posp y) + (math-pi-over-2) + (math-neg (math-pi-over-2)))) + ((math-posp x) + (math-arctan-raw (math-div-float y x))) + ((math-posp y) + (math-add-float (math-arctan-raw (math-div-float y x)) + (math-pi))) + (t + (math-sub-float (math-arctan-raw (math-div-float y x)) + (math-pi)))) +) + +(defun calcFunc-arcsincos (x) ; [V N] [Public] + (if (and (Math-vectorp x) + (= (length x) 3)) + (calcFunc-arctan2 (nth 2 x) (nth 1 x)) + (math-reject-arg x "*Two-element vector expected")) +) + + + +;;; Exponential function. + +(defun calcFunc-exp (x) ; [N N] [Public] + (cond ((eq x 0) 1) + ((and (memq x '(1 -1)) calc-symbolic-mode) + (if (eq x 1) '(var e var-e) (math-div 1 '(var e var-e)))) + ((Math-numberp x) + (math-with-extra-prec 2 (math-exp-raw (math-float x)))) + ((eq (car-safe x) 'sdev) + (let ((ex (calcFunc-exp (nth 1 x)))) + (math-make-sdev ex (math-mul (nth 2 x) ex)))) + ((eq (car-safe x) 'intv) + (math-make-intv (nth 1 x) (calcFunc-exp (nth 2 x)) + (calcFunc-exp (nth 3 x)))) + ((equal x '(var inf var-inf)) + x) + ((equal x '(neg (var inf var-inf))) + 0) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-exp x))) +) + +(defun calcFunc-expm1 (x) ; [N N] [Public] + (cond ((eq x 0) 0) + ((math-zerop x) '(float 0 0)) + (calc-symbolic-mode (signal 'inexact-result nil)) + ((Math-numberp x) + (math-with-extra-prec 2 + (let ((x (math-float x))) + (if (and (eq (car x) 'float) + (math-lessp-float x '(float 1 0)) + (math-lessp-float '(float -1 0) x)) + (math-exp-minus-1-raw x) + (math-add (math-exp-raw x) -1))))) + ((eq (car-safe x) 'sdev) + (if (math-constp x) + (let ((ex (calcFunc-expm1 (nth 1 x)))) + (math-make-sdev ex (math-mul (nth 2 x) (math-add ex 1)))) + (math-make-sdev (calcFunc-expm1 (nth 1 x)) + (math-mul (nth 2 x) (calcFunc-exp (nth 1 x)))))) + ((eq (car-safe x) 'intv) + (math-make-intv (nth 1 x) + (calcFunc-expm1 (nth 2 x)) + (calcFunc-expm1 (nth 3 x)))) + ((equal x '(var inf var-inf)) + x) + ((equal x '(neg (var inf var-inf))) + -1) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-expm1 x))) +) + +(defun calcFunc-exp10 (x) ; [N N] [Public] + (if (eq x 0) + 1 + (math-pow '(float 1 1) x)) +) + +(defun math-exp-raw (x) ; [N N] + (cond ((math-zerop x) '(float 1 0)) + (calc-symbolic-mode (signal 'inexact-result nil)) + ((eq (car x) 'cplx) + (let ((expx (math-exp-raw (nth 1 x))) + (sc (math-sin-cos-raw (nth 2 x)))) + (list 'cplx + (math-mul-float expx (cdr sc)) + (math-mul-float expx (car sc))))) + ((eq (car x) 'polar) + (let ((xc (math-complex x))) + (list 'polar + (math-exp-raw (nth 1 xc)) + (math-from-radians (nth 2 xc))))) + ((or (math-lessp-float '(float 5 -1) x) + (math-lessp-float x '(float -5 -1))) + (if (math-lessp-float '(float 921035 1) x) + (math-overflow) + (if (math-lessp-float x '(float -921035 1)) + (math-underflow))) + (let* ((two-x (math-mul-float x '(float 2 0))) + (hint (math-scale-int (nth 1 two-x) (nth 2 two-x))) + (hfrac (math-sub-float x (math-mul-float (math-float hint) + '(float 5 -1))))) + (math-mul-float (math-ipow (math-sqrt-e) hint) + (math-add-float '(float 1 0) + (math-exp-minus-1-raw hfrac))))) + (t (math-add-float '(float 1 0) (math-exp-minus-1-raw x)))) +) + +(defun math-exp-minus-1-raw (x) ; [F F] + (math-exp-series x 2 3 x x) +) + +(defun math-exp-series (sum nfac n xpow x) + (math-working "exp" sum) + (let* ((nextx (math-mul-float xpow x)) + (nextsum (math-add-float sum (math-div-float nextx + (math-float nfac))))) + (if (math-nearly-equal-float sum nextsum) + sum + (math-exp-series nextsum (math-mul nfac n) (1+ n) nextx x))) +) + + + +;;; Logarithms. + +(defun calcFunc-ln (x) ; [N N] [Public] + (cond ((math-zerop x) + (if calc-infinite-mode + '(neg (var inf var-inf)) + (math-reject-arg x "*Logarithm of zero"))) + ((eq x 1) 0) + ((Math-numberp x) + (math-with-extra-prec 2 (math-ln-raw (math-float x)))) + ((eq (car-safe x) 'sdev) + (math-make-sdev (calcFunc-ln (nth 1 x)) + (math-div (nth 2 x) (nth 1 x)))) + ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) + (Math-zerop (nth 2 x)) + (not (math-intv-constp x)))) + (let ((calc-infinite-mode t)) + (math-make-intv (nth 1 x) (calcFunc-ln (nth 2 x)) + (calcFunc-ln (nth 3 x))))) + ((equal x '(var e var-e)) + 1) + ((and (eq (car-safe x) '^) + (equal (nth 1 x) '(var e var-e)) + (math-known-realp (nth 2 x))) + (nth 2 x)) + ((math-infinitep x) + (if (equal x '(var nan var-nan)) + x + '(var inf var-inf))) + (t (calc-record-why 'numberp x) + (list 'calcFunc-ln x))) +) + +(defun calcFunc-log10 (x) ; [N N] [Public] + (cond ((math-equal-int x 1) + (if (math-floatp x) '(float 0 0) 0)) + ((and (Math-integerp x) + (math-posp x) + (let ((res (math-integer-log x 10))) + (and (car res) + (setq x (cdr res))))) + x) + ((and (eq (car-safe x) 'frac) + (eq (nth 1 x) 1) + (let ((res (math-integer-log (nth 2 x) 10))) + (and (car res) + (setq x (- (cdr res)))))) + x) + ((math-zerop x) + (if calc-infinite-mode + '(neg (var inf var-inf)) + (math-reject-arg x "*Logarithm of zero"))) + (calc-symbolic-mode (signal 'inexact-result nil)) + ((Math-numberp x) + (math-with-extra-prec 2 + (let ((xf (math-float x))) + (if (eq (nth 1 xf) 0) + (math-reject-arg x "*Logarithm of zero")) + (if (Math-integer-posp (nth 1 xf)) + (if (eq (nth 1 xf) 1) ; log10(1*10^n) = n + (math-float (nth 2 xf)) + (let ((xdigs (1- (math-numdigs (nth 1 xf))))) + (math-add-float + (math-div-float (math-ln-raw-2 + (list 'float (nth 1 xf) (- xdigs))) + (math-ln-10)) + (math-float (+ (nth 2 xf) xdigs))))) + (math-div (calcFunc-ln xf) (math-ln-10)))))) + ((eq (car-safe x) 'sdev) + (math-make-sdev (calcFunc-log10 (nth 1 x)) + (math-div (nth 2 x) + (math-mul (nth 1 x) (math-ln-10))))) + ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) + (not (math-intv-constp x)))) + (math-make-intv (nth 1 x) + (calcFunc-log10 (nth 2 x)) + (calcFunc-log10 (nth 3 x)))) + ((math-infinitep x) + (if (equal x '(var nan var-nan)) + x + '(var inf var-inf))) + (t (calc-record-why 'numberp x) + (list 'calcFunc-log10 x))) +) + +(defun calcFunc-log (x &optional b) ; [N N N] [Public] + (cond ((or (null b) (equal b '(var e var-e))) + (math-normalize (list 'calcFunc-ln x))) + ((or (eq b 10) (equal b '(float 1 1))) + (math-normalize (list 'calcFunc-log10 x))) + ((math-zerop x) + (if calc-infinite-mode + (math-div (calcFunc-ln x) (calcFunc-ln b)) + (math-reject-arg x "*Logarithm of zero"))) + ((math-zerop b) + (if calc-infinite-mode + (math-div (calcFunc-ln x) (calcFunc-ln b)) + (math-reject-arg b "*Logarithm of zero"))) + ((math-equal-int b 1) + (if calc-infinite-mode + (math-div (calcFunc-ln x) 0) + (math-reject-arg b "*Logarithm base one"))) + ((math-equal-int x 1) + (if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0)) + ((and (Math-ratp x) (Math-ratp b) + (math-posp x) (math-posp b) + (let* ((sign 1) (inv nil) + (xx (if (Math-lessp 1 x) + x + (setq sign -1) + (math-div 1 x))) + (bb (if (Math-lessp 1 b) + b + (setq sign (- sign)) + (math-div 1 b))) + (res (if (Math-lessp xx bb) + (setq inv (math-integer-log bb xx)) + (math-integer-log xx bb)))) + (and (car res) + (setq x (if inv + (math-div 1 (* sign (cdr res))) + (* sign (cdr res))))))) + x) + (calc-symbolic-mode (signal 'inexact-result nil)) + ((and (Math-numberp x) (Math-numberp b)) + (math-with-extra-prec 2 + (math-div (math-ln-raw (math-float x)) + (math-log-base-raw b)))) + ((and (eq (car-safe x) 'sdev) + (Math-numberp b)) + (math-make-sdev (calcFunc-log (nth 1 x) b) + (math-div (nth 2 x) + (math-mul (nth 1 x) + (math-log-base-raw b))))) + ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) + (not (math-intv-constp x))) + (math-realp b)) + (math-make-intv (nth 1 x) + (calcFunc-log (nth 2 x) b) + (calcFunc-log (nth 3 x) b))) + ((or (eq (car-safe x) 'intv) (eq (car-safe b) 'intv)) + (math-div (calcFunc-ln x) (calcFunc-ln b))) + ((or (math-infinitep x) + (math-infinitep b)) + (math-div (calcFunc-ln x) (calcFunc-ln b))) + (t (if (Math-numberp b) + (calc-record-why 'numberp x) + (calc-record-why 'numberp b)) + (list 'calcFunc-log x b))) +) + +(defun calcFunc-alog (x &optional b) + (cond ((or (null b) (equal b '(var e var-e))) + (math-normalize (list 'calcFunc-exp x))) + (t (math-pow b x))) +) + +(defun calcFunc-ilog (x b) + (if (and (math-natnump x) (not (eq x 0)) + (math-natnump b) (not (eq b 0))) + (if (eq b 1) + (math-reject-arg x "*Logarithm base one") + (if (Math-natnum-lessp x b) + 0 + (cdr (math-integer-log x b)))) + (math-floor (calcFunc-log x b))) +) + +(defun math-integer-log (x b) + (let ((pows (list b)) + (pow (math-sqr b)) + next + sum n) + (while (not (Math-lessp x pow)) + (setq pows (cons pow pows) + pow (math-sqr pow))) + (setq n (lsh 1 (1- (length pows))) + sum n + pow (car pows)) + (while (and (setq pows (cdr pows)) + (Math-lessp pow x)) + (setq n (/ n 2) + next (math-mul pow (car pows))) + (or (Math-lessp x next) + (setq pow next + sum (+ sum n)))) + (cons (equal pow x) sum)) +) + + +(defun math-log-base-raw (b) ; [N N] + (if (not (and (equal (car math-log-base-cache) b) + (eq (nth 1 math-log-base-cache) calc-internal-prec))) + (setq math-log-base-cache (list b calc-internal-prec + (math-ln-raw (math-float b))))) + (nth 2 math-log-base-cache) +) +(setq math-log-base-cache nil) + +(defun calcFunc-lnp1 (x) ; [N N] [Public] + (cond ((Math-equal-int x -1) + (if calc-infinite-mode + '(neg (var inf var-inf)) + (math-reject-arg x "*Logarithm of zero"))) + ((eq x 0) 0) + ((math-zerop x) '(float 0 0)) + (calc-symbolic-mode (signal 'inexact-result nil)) + ((Math-numberp x) + (math-with-extra-prec 2 + (let ((x (math-float x))) + (if (and (eq (car x) 'float) + (math-lessp-float x '(float 5 -1)) + (math-lessp-float '(float -5 -1) x)) + (math-ln-plus-1-raw x) + (math-ln-raw (math-add-float x '(float 1 0))))))) + ((eq (car-safe x) 'sdev) + (math-make-sdev (calcFunc-lnp1 (nth 1 x)) + (math-div (nth 2 x) (math-add (nth 1 x) 1)))) + ((and (eq (car-safe x) 'intv) (or (Math-posp (nth 2 x)) + (not (math-intv-constp x)))) + (math-make-intv (nth 1 x) + (calcFunc-lnp1 (nth 2 x)) + (calcFunc-lnp1 (nth 3 x)))) + ((math-infinitep x) + (if (equal x '(var nan var-nan)) + x + '(var inf var-inf))) + (t (calc-record-why 'numberp x) + (list 'calcFunc-lnp1 x))) +) + +(defun math-ln-raw (x) ; [N N] --- must be float format! + (cond ((eq (car-safe x) 'cplx) + (list 'cplx + (math-mul-float (math-ln-raw + (math-add-float (math-sqr-float (nth 1 x)) + (math-sqr-float (nth 2 x)))) + '(float 5 -1)) + (math-arctan2-raw (nth 2 x) (nth 1 x)))) + ((eq (car x) 'polar) + (math-polar (list 'cplx + (math-ln-raw (nth 1 x)) + (math-to-radians (nth 2 x))))) + ((Math-equal-int x 1) + '(float 0 0)) + (calc-symbolic-mode (signal 'inexact-result nil)) + ((math-posp (nth 1 x)) ; positive and real + (let ((xdigs (1- (math-numdigs (nth 1 x))))) + (math-add-float (math-ln-raw-2 (list 'float (nth 1 x) (- xdigs))) + (math-mul-float (math-float (+ (nth 2 x) xdigs)) + (math-ln-10))))) + ((math-zerop x) + (math-reject-arg x "*Logarithm of zero")) + ((eq calc-complex-mode 'polar) ; negative and real + (math-polar + (list 'cplx ; negative and real + (math-ln-raw (math-neg-float x)) + (math-pi)))) + (t (list 'cplx ; negative and real + (math-ln-raw (math-neg-float x)) + (math-pi)))) +) + +(defun math-ln-raw-2 (x) ; [F F] + (cond ((math-lessp-float '(float 14 -1) x) + (math-add-float (math-ln-raw-2 (math-mul-float x '(float 5 -1))) + (math-ln-2))) + (t ; now .7 < x <= 1.4 + (math-ln-raw-3 (math-div-float (math-sub-float x '(float 1 0)) + (math-add-float x '(float 1 0)))))) +) + +(defun math-ln-raw-3 (x) ; [F F] + (math-mul-float (math-ln-raw-series x 3 x (math-sqr-float x)) + '(float 2 0)) +) + +;;; Compute ln((1+x)/(1-x)) +(defun math-ln-raw-series (sum n x xsqr) + (math-working "log" sum) + (let* ((nextx (math-mul-float x xsqr)) + (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) + (if (math-nearly-equal-float sum nextsum) + sum + (math-ln-raw-series nextsum (+ n 2) nextx xsqr))) +) + +(defun math-ln-plus-1-raw (x) + (math-lnp1-series x 2 x (math-neg x)) +) + +(defun math-lnp1-series (sum n xpow x) + (math-working "lnp1" sum) + (let* ((nextx (math-mul-float xpow x)) + (nextsum (math-add-float sum (math-div-float nextx (math-float n))))) + (if (math-nearly-equal-float sum nextsum) + sum + (math-lnp1-series nextsum (1+ n) nextx x))) +) + +(math-defcache math-ln-10 (float (bigpos 018 684 045 994 092 585 302 2) -21) + (math-ln-raw-2 '(float 1 1))) + +(math-defcache math-ln-2 (float (bigpos 417 309 945 559 180 147 693) -21) + (math-ln-raw-3 (math-float '(frac 1 3)))) + + + +;;; Hyperbolic functions. + +(defun calcFunc-sinh (x) ; [N N] [Public] + (cond ((eq x 0) 0) + (math-expand-formulas + (math-normalize + (list '/ (list '- (list 'calcFunc-exp x) + (list 'calcFunc-exp (list 'neg x))) 2))) + ((Math-numberp x) + (if calc-symbolic-mode (signal 'inexact-result nil)) + (math-with-extra-prec 2 + (let ((expx (math-exp-raw (math-float x)))) + (math-mul (math-add expx (math-div -1 expx)) '(float 5 -1))))) + ((eq (car-safe x) 'sdev) + (math-make-sdev (calcFunc-sinh (nth 1 x)) + (math-mul (nth 2 x) (calcFunc-cosh (nth 1 x))))) + ((eq (car x) 'intv) + (math-sort-intv (nth 1 x) + (calcFunc-sinh (nth 2 x)) + (calcFunc-sinh (nth 3 x)))) + ((or (equal x '(var inf var-inf)) + (equal x '(neg (var inf var-inf))) + (equal x '(var nan var-nan))) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-sinh x))) +) +(put 'calcFunc-sinh 'math-expandable t) + +(defun calcFunc-cosh (x) ; [N N] [Public] + (cond ((eq x 0) 1) + (math-expand-formulas + (math-normalize + (list '/ (list '+ (list 'calcFunc-exp x) + (list 'calcFunc-exp (list 'neg x))) 2))) + ((Math-numberp x) + (if calc-symbolic-mode (signal 'inexact-result nil)) + (math-with-extra-prec 2 + (let ((expx (math-exp-raw (math-float x)))) + (math-mul (math-add expx (math-div 1 expx)) '(float 5 -1))))) + ((eq (car-safe x) 'sdev) + (math-make-sdev (calcFunc-cosh (nth 1 x)) + (math-mul (nth 2 x) + (calcFunc-sinh (nth 1 x))))) + ((and (eq (car x) 'intv) (math-intv-constp x)) + (setq x (math-abs x)) + (math-sort-intv (nth 1 x) + (calcFunc-cosh (nth 2 x)) + (calcFunc-cosh (nth 3 x)))) + ((or (equal x '(var inf var-inf)) + (equal x '(neg (var inf var-inf))) + (equal x '(var nan var-nan))) + (math-abs x)) + (t (calc-record-why 'numberp x) + (list 'calcFunc-cosh x))) +) +(put 'calcFunc-cosh 'math-expandable t) + +(defun calcFunc-tanh (x) ; [N N] [Public] + (cond ((eq x 0) 0) + (math-expand-formulas + (math-normalize + (let ((expx (list 'calcFunc-exp x)) + (expmx (list 'calcFunc-exp (list 'neg x)))) + (math-normalize + (list '/ (list '- expx expmx) (list '+ expx expmx)))))) + ((Math-numberp x) + (if calc-symbolic-mode (signal 'inexact-result nil)) + (math-with-extra-prec 2 + (let* ((expx (calcFunc-exp (math-float x))) + (expmx (math-div 1 expx))) + (math-div (math-sub expx expmx) + (math-add expx expmx))))) + ((eq (car-safe x) 'sdev) + (math-make-sdev (calcFunc-tanh (nth 1 x)) + (math-div (nth 2 x) + (math-sqr (calcFunc-cosh (nth 1 x)))))) + ((eq (car x) 'intv) + (math-sort-intv (nth 1 x) + (calcFunc-tanh (nth 2 x)) + (calcFunc-tanh (nth 3 x)))) + ((equal x '(var inf var-inf)) + 1) + ((equal x '(neg (var inf var-inf))) + -1) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-tanh x))) +) +(put 'calcFunc-tanh 'math-expandable t) + +(defun calcFunc-arcsinh (x) ; [N N] [Public] + (cond ((eq x 0) 0) + (math-expand-formulas + (math-normalize + (list 'calcFunc-ln (list '+ x (list 'calcFunc-sqrt + (list '+ (list '^ x 2) 1)))))) + ((Math-numberp x) + (if calc-symbolic-mode (signal 'inexact-result nil)) + (math-with-extra-prec 2 + (math-ln-raw (math-add x (math-sqrt-raw (math-add (math-sqr x) + '(float 1 0))))))) + ((eq (car-safe x) 'sdev) + (math-make-sdev (calcFunc-arcsinh (nth 1 x)) + (math-div (nth 2 x) + (math-sqrt + (math-add (math-sqr (nth 1 x)) 1))))) + ((eq (car x) 'intv) + (math-sort-intv (nth 1 x) + (calcFunc-arcsinh (nth 2 x)) + (calcFunc-arcsinh (nth 3 x)))) + ((or (equal x '(var inf var-inf)) + (equal x '(neg (var inf var-inf))) + (equal x '(var nan var-nan))) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-arcsinh x))) +) +(put 'calcFunc-arcsinh 'math-expandable t) + +(defun calcFunc-arccosh (x) ; [N N] [Public] + (cond ((eq x 1) 0) + ((and (eq x -1) calc-symbolic-mode) + '(var pi var-pi)) + ((and (eq x 0) calc-symbolic-mode) + (math-div (math-mul '(var pi var-pi) '(var i var-i)) 2)) + (math-expand-formulas + (math-normalize + (list 'calcFunc-ln (list '+ x (list 'calcFunc-sqrt + (list '- (list '^ x 2) 1)))))) + ((Math-numberp x) + (if calc-symbolic-mode (signal 'inexact-result nil)) + (if (Math-equal-int x -1) + (math-imaginary (math-pi)) + (math-with-extra-prec 2 + (if (or t ; need to do this even in the real case! + (memq (car-safe x) '(cplx polar))) + (let ((xp1 (math-add 1 x))) ; this gets the branch cuts right + (math-ln-raw + (math-add x (math-mul xp1 + (math-sqrt-raw + (math-div (math-sub + x + '(float 1 0)) + xp1)))))) + (math-ln-raw + (math-add x (math-sqrt-raw (math-add (math-sqr x) + '(float -1 0))))))))) + ((eq (car-safe x) 'sdev) + (math-make-sdev (calcFunc-arccosh (nth 1 x)) + (math-div (nth 2 x) + (math-sqrt + (math-add (math-sqr (nth 1 x)) -1))))) + ((eq (car x) 'intv) + (math-sort-intv (nth 1 x) + (calcFunc-arccosh (nth 2 x)) + (calcFunc-arccosh (nth 3 x)))) + ((or (equal x '(var inf var-inf)) + (equal x '(neg (var inf var-inf))) + (equal x '(var nan var-nan))) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-arccosh x))) +) +(put 'calcFunc-arccosh 'math-expandable t) + +(defun calcFunc-arctanh (x) ; [N N] [Public] + (cond ((eq x 0) 0) + ((and (Math-equal-int x 1) calc-infinite-mode) + '(var inf var-inf)) + ((and (Math-equal-int x -1) calc-infinite-mode) + '(neg (var inf var-inf))) + (math-expand-formulas + (list '/ (list '- + (list 'calcFunc-ln (list '+ 1 x)) + (list 'calcFunc-ln (list '- 1 x))) 2)) + ((Math-numberp x) + (if calc-symbolic-mode (signal 'inexact-result nil)) + (math-with-extra-prec 2 + (if (or (memq (car-safe x) '(cplx polar)) + (Math-lessp 1 x)) + (math-mul (math-sub (math-ln-raw (math-add '(float 1 0) x)) + (math-ln-raw (math-sub '(float 1 0) x))) + '(float 5 -1)) + (if (and (math-equal-int x 1) calc-infinite-mode) + '(var inf var-inf) + (if (and (math-equal-int x -1) calc-infinite-mode) + '(neg (var inf var-inf)) + (math-mul (math-ln-raw (math-div (math-add '(float 1 0) x) + (math-sub 1 x))) + '(float 5 -1))))))) + ((eq (car-safe x) 'sdev) + (math-make-sdev (calcFunc-arctanh (nth 1 x)) + (math-div (nth 2 x) + (math-sub 1 (math-sqr (nth 1 x)))))) + ((eq (car x) 'intv) + (math-sort-intv (nth 1 x) + (calcFunc-arctanh (nth 2 x)) + (calcFunc-arctanh (nth 3 x)))) + ((equal x '(var nan var-nan)) + x) + (t (calc-record-why 'numberp x) + (list 'calcFunc-arctanh x))) +) +(put 'calcFunc-arctanh 'math-expandable t) + + +;;; Convert A from HMS or degrees to radians. +(defun calcFunc-rad (a) ; [R R] [Public] + (cond ((or (Math-numberp a) + (eq (car a) 'intv)) + (math-with-extra-prec 2 + (math-mul a (math-pi-over-180)))) + ((eq (car a) 'hms) + (math-from-hms a 'rad)) + ((eq (car a) 'sdev) + (math-make-sdev (calcFunc-rad (nth 1 a)) + (calcFunc-rad (nth 2 a)))) + (math-expand-formulas + (math-div (math-mul a '(var pi var-pi)) 180)) + ((math-infinitep a) a) + (t (list 'calcFunc-rad a))) +) +(put 'calcFunc-rad 'math-expandable t) + +;;; Convert A from HMS or radians to degrees. +(defun calcFunc-deg (a) ; [R R] [Public] + (cond ((or (Math-numberp a) + (eq (car a) 'intv)) + (math-with-extra-prec 2 + (math-div a (math-pi-over-180)))) + ((eq (car a) 'hms) + (math-from-hms a 'deg)) + ((eq (car a) 'sdev) + (math-make-sdev (calcFunc-deg (nth 1 a)) + (calcFunc-deg (nth 2 a)))) + (math-expand-formulas + (math-div (math-mul 180 a) '(var pi var-pi))) + ((math-infinitep a) a) + (t (list 'calcFunc-deg a))) +) +(put 'calcFunc-deg 'math-expandable t) + + + + diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el new file mode 100644 index 0000000000..1e4d376f64 --- /dev/null +++ b/lisp/calc/calc-misc.el @@ -0,0 +1,877 @@ +;; Calculator for GNU Emacs, part I [calc-misc.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc.el. +(require 'calc) + +(require 'calc-macs) + +(defun calc-Need-calc-misc () nil) + + +(defun calc-dispatch-help (arg) + "M-# is a prefix key; follow it with one of these letters: + +For turning Calc on and off: + C calc. Start the Calculator in a window at the bottom of the screen. + O calc-other-window. Start the Calculator but don't select its window. + B calc-big-or-small. Control whether to use the full Emacs screen for Calc. + Q quick-calc. Use the Calculator in the minibuffer. + K calc-keypad. Start the Calculator in keypad mode (X window system only). + E calc-embedded. Use the Calculator on a formula in this editing buffer. + J calc-embedded-select. Like E, but select appropriate half of => or :=. + W calc-embedded-word. Like E, but activate a single word, i.e., a number. + Z calc-user-invocation. Invoke Calc in the way you defined with `Z I' cmd. + X calc-quit. Turn Calc off. + +For moving data into and out of Calc: + G calc-grab-region. Grab the region defined by mark and point into Calc. + R calc-grab-rectangle. Grab the rectangle defined by mark, point into Calc. + : calc-grab-sum-down. Grab a rectangle and sum the columns. + _ calc-grab-sum-across. Grab a rectangle and sum the rows. + Y calc-copy-to-buffer. Copy a value from the stack into the editing buffer. + +For use with Embedded mode: + A calc-embedded-activate. Find and activate all :='s and =>'s in buffer. + D calc-embedded-duplicate. Make a copy of this formula and select it. + F calc-embedded-new-formula. Insert a new formula at current point. + N calc-embedded-next. Advance cursor to next known formula in buffer. + P calc-embedded-previous. Advance cursor to previous known formula. + U calc-embedded-update-formula. Re-evaluate formula at point. + ` calc-embedded-edit. Use calc-edit to edit formula at point. + +Documentation: + I calc-info. Read the Calculator manual in the Emacs Info system. + T calc-tutorial. Run the Calculator Tutorial using the Emacs Info system. + S calc-summary. Read the Summary from the Calculator manual in Info. + +Miscellaneous: + L calc-load-everything. Load all parts of the Calculator into memory. + M read-kbd-macro. Read a region of keystroke names as a keyboard macro. + 0 (zero) calc-reset. Reset Calc stack and modes to default state. + +Press twice (`M-# M-#' or `M-# #') to turn Calc on or off using the same +Calc user interface as before (either M-# C or M-# K; initially M-# C)." + (interactive "P") + (calc-check-defines) + (if calc-dispatch-help + (progn + (save-window-excursion + (describe-function 'calc-dispatch-help) + (let ((win (get-buffer-window "*Help*"))) + (if win + (let (key) + (select-window win) + (while (progn + (message "Calc options: Calc, Keypad, ... %s" + "press SPC, DEL to scroll, C-g to cancel") + (memq (car (setq key (calc-read-key t))) + '(? ?\C-h ?\C-? ?\C-v ?\M-v))) + (condition-case err + (if (memq (car key) '(? ?\C-v)) + (scroll-up) + (scroll-down)) + (error (beep)))) + (calc-unread-command (cdr key)))))) + (calc-do-dispatch nil)) + (let ((calc-dispatch-help t)) + (calc-do-dispatch arg))) +) + + +(defun calc-big-or-small (arg) + "Toggle Calc between full-screen and regular mode." + (interactive "P") + (let ((cwin (get-buffer-window "*Calculator*")) + (twin (get-buffer-window "*Calc Trail*")) + (kwin (get-buffer-window "*Calc Keypad*"))) + (if cwin + (setq calc-full-mode + (if kwin + (and twin (eq (window-width twin) (screen-width))) + (eq (window-height cwin) (1- (screen-height)))))) + (setq calc-full-mode (if arg + (> (prefix-numeric-value arg) 0) + (not calc-full-mode))) + (if kwin + (progn + (calc-quit) + (calc-do-keypad calc-full-mode nil)) + (if cwin + (progn + (calc-quit) + (calc nil calc-full-mode nil)))) + (message (if calc-full-mode + "Now using full screen for Calc." + "Now using partial screen for Calc."))) +) + +(defun calc-other-window () + "Invoke the Calculator in another window." + (interactive) + (if (memq major-mode '(calc-mode calc-trail-mode)) + (progn + (other-window 1) + (if (memq major-mode '(calc-mode calc-trail-mode)) + (other-window 1))) + (if (get-buffer-window "*Calculator*") + (calc-quit) + (let ((win (selected-window))) + (calc nil win (interactive-p))))) +) + +(defun another-calc () + "Create another, independent Calculator buffer." + (interactive) + (if (eq major-mode 'calc-mode) + (mapcar (function + (lambda (v) + (set-default v (symbol-value v)))) calc-local-var-list)) + (set-buffer (generate-new-buffer "*Calculator*")) + (pop-to-buffer (current-buffer)) + (calc-mode) +) + + +;;; Make an attempt to preserve the window configuration, while deleting +;;; windows on "bufs". Emacs 19's delete-window function will probably +;;; make this kludgery unnecessary, but Emacs 18's tendency to grow all +;;; windows on the screen to take up the slack from the deleted windows +;;; can be annoying when Calc was called during another multi-window +;;; application, such as GNUS. + +(defun calc-delete-windows-keep (&rest bufs) + (if (one-window-p) + (mapcar 'delete-windows-on bufs) + (let* ((w (car calc-was-split)) + (e (window-edges w)) + (wins nil) + w2 e2) + (while (progn + (setq w2 (previous-window w) + e2 (window-edges w2)) + (and (= (car e2) (car e)) + (= (nth 2 e2) (nth 2 e)) + (< (nth 1 e2) (nth 1 e)))) + (setq w w2 e e2)) + (setq w2 w e2 e) + (while (progn + (setq wins (cons (list w (nth 1 e) (window-buffer w) + (window-point w) (window-start w)) + wins) + w (next-window w) + e (window-edges w)) + (and (not (eq w w2)) + (= (car e2) (car e)) + (= (nth 2 e2) (nth 2 e))))) + (setq wins (nreverse wins)) + (mapcar 'delete-windows-on bufs) + (or (one-window-p) + (let ((w wins) + (main nil) + (mainpos 0) + (sel (if (window-point (nth 2 calc-was-split)) + (nth 2 calc-was-split) + (selected-window)))) + (while w + (if (window-point (car (car w))) + (if main + (delete-window (car (car w))) + (setq main (car (car w)) + mainpos (nth 1 (car w)) + wins (cdr wins))) + (setq wins (delq (car w) wins))) + (setq w (cdr w))) + (while wins + (setq w (split-window main + (if (eq main (car calc-was-split)) + (nth 1 calc-was-split) + (- (nth 1 (car wins)) mainpos)))) + (set-window-buffer w (nth 2 (car wins))) + (set-window-point w (nth 3 (car wins))) + (set-window-start w (nth 4 (car wins))) + (if (eq sel (car (car wins))) + (select-window w)) + (setq main w + mainpos (nth 1 (car wins)) + wins (cdr wins))) + (if (window-point sel) + (select-window sel)))))) +) + + +(defun calc-info () + "Run the Emacs Info system on the Calculator documentation." + (interactive) + (require 'info) + (select-window (get-largest-window)) + (or (file-name-absolute-p calc-info-filename) + (let ((p load-path) + name) + (if (boundp 'Info-directory) + (setq p (cons Info-directory p))) + (while (and p (not (file-exists-p + (setq name (expand-file-name calc-info-filename + (car p)))))) + (setq p (cdr p))) + (if p (setq calc-info-filename name)))) + (condition-case err + (info) + (error nil)) + (or (and (boundp 'Info-current-file) + (stringp Info-current-file) + (string-match "calc" Info-current-file)) + (Info-find-node calc-info-filename "Top")) +) + +(defun calc-tutorial () + "Run the Emacs Info system on the Calculator Tutorial." + (interactive) + (if (get-buffer-window "*Calculator*") + (calc-quit)) + (calc-info) + (Info-goto-node "Interactive Tutorial") + (calc-other-window) + (message "Welcome to the Calc Tutorial!") +) + +(defun calc-info-summary () + "Run the Emacs Info system on the Calculator Summary." + (interactive) + (calc-info) + (Info-goto-node "Summary") +) + +(defun calc-help () + (interactive) + (let ((msgs (append + '("Press `h' for complete help; press `?' repeatedly for a summary" + "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit" + "Letter keys: SHIFT + Undo, reDo; Keep-args; Inverse, Hyperbolic" + "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB" + "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi" + "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro" + "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)" + "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)" + "Other keys: ' (alg-entry), = (eval), ` (edit); M-RET (last-args)" + "Other keys: SPC/RET (enter/dup), LFD (over); < > (scroll horiz)" + "Other keys: DEL (drop), M-DEL (drop-above); { } (scroll vert)" + "Other keys: TAB (swap/roll-dn), M-TAB (roll-up)" + "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)" + "Prefix keys: Algebra, Binary/business, Convert, Display" + "Prefix keys: Functions, Graphics, Help, J (select)" + "Prefix keys: Kombinatorics/statistics, Modes, Store/recall" + "Prefix keys: Trail/time, Units/statistics, Vector/matrix" + "Prefix keys: Z (user), SHIFT + Z (define)" + "Prefix keys: prefix + ? gives further help for that prefix") + (list (format + " Calc %s by Dave Gillespie, [email protected]" + calc-version))))) + (if calc-full-help-flag + msgs + (if (or calc-inverse-flag calc-hyperbolic-flag) + (if calc-inverse-flag + (if calc-hyperbolic-flag + (calc-inv-hyp-prefix-help) + (calc-inverse-prefix-help)) + (calc-hyperbolic-prefix-help)) + (setq calc-help-phase + (if (eq this-command last-command) + (% (1+ calc-help-phase) (1+ (length msgs))) + 0)) + (let ((msg (nth calc-help-phase msgs))) + (message "%s" (if msg + (concat msg ":" + (make-string (- (apply 'max + (mapcar 'length + msgs)) + (length msg)) 32) + " [?=MORE]") + "")))))) +) + + + + +;;;; Stack and buffer management. + + +(defun calc-do-handle-whys () + (setq calc-why (sort calc-next-why + (function + (lambda (x y) + (and (eq (car x) '*) (not (eq (car y) '*)))))) + calc-next-why nil) + (if (and calc-why (or (eq calc-auto-why t) + (and (eq (car (car calc-why)) '*) + calc-auto-why))) + (progn + (calc-extensions) + (calc-explain-why (car calc-why) + (if (eq calc-auto-why t) + (cdr calc-why) + (if calc-auto-why + (eq (car (nth 1 calc-why)) '*)))) + (setq calc-last-why-command this-command) + (calc-clear-command-flag 'clear-message))) +) + +(defun calc-record-why (&rest stuff) + (if (eq (car stuff) 'quiet) + (setq stuff (cdr stuff)) + (if (and (symbolp (car stuff)) + (cdr stuff) + (or (Math-objectp (nth 1 stuff)) + (and (Math-vectorp (nth 1 stuff)) + (math-constp (nth 1 stuff))) + (math-infinitep (nth 1 stuff)))) + (setq stuff (cons '* stuff)) + (if (and (stringp (car stuff)) + (string-match "\\`\\*" (car stuff))) + (setq stuff (cons '* (cons (substring (car stuff) 1) + (cdr stuff))))))) + (setq calc-next-why (cons stuff calc-next-why)) + nil +) + +;;; True if A is a constant or vector of constants. [P x] [Public] +(defun math-constp (a) + (or (Math-scalarp a) + (and (memq (car a) '(sdev intv mod vec)) + (progn + (while (and (setq a (cdr a)) + (or (Math-scalarp (car a)) ; optimization + (math-constp (car a))))) + (null a)))) +) + + +(defun calc-roll-down-stack (n &optional m) + (if (< n 0) + (calc-roll-up-stack (- n) m) + (if (or (= n 0) (> n (calc-stack-size))) (setq n (calc-stack-size))) + (or m (setq m 1)) + (and (> n 1) + (< m n) + (if (and calc-any-selections + (not calc-use-selections)) + (calc-roll-down-with-selections n m) + (calc-pop-push-list n + (append (calc-top-list m 1) + (calc-top-list (- n m) (1+ m))))))) +) + +(defun calc-roll-up-stack (n &optional m) + (if (< n 0) + (calc-roll-down-stack (- n) m) + (if (or (= n 0) (> n (calc-stack-size))) (setq n (calc-stack-size))) + (or m (setq m 1)) + (and (> n 1) + (< m n) + (if (and calc-any-selections + (not calc-use-selections)) + (calc-roll-up-with-selections n m) + (calc-pop-push-list n + (append (calc-top-list (- n m) 1) + (calc-top-list m (- n m -1))))))) +) + + +(defun calc-do-refresh () + (if calc-hyperbolic-flag + (progn + (setq calc-display-dirty t) + nil) + (calc-refresh) + t) +) + + +(defun calc-record-list (vals &optional prefix) + (while vals + (or (eq (car vals) 'top-of-stack) + (progn + (calc-record (car vals) prefix) + (setq prefix "..."))) + (setq vals (cdr vals))) +) + + +(defun calc-last-args-stub (arg) + (interactive "p") + (calc-extensions) + (calc-last-args arg) +) + + +(defun calc-power (arg) + (interactive "P") + (calc-slow-wrapper + (if (and calc-extensions-loaded + (calc-is-inverse)) + (calc-binary-op "root" 'calcFunc-nroot arg nil nil) + (calc-binary-op "^" 'calcFunc-pow arg nil nil '^))) +) + +(defun calc-mod (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "%" 'calcFunc-mod arg nil nil '%)) +) + +(defun calc-inv (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "inv" 'calcFunc-inv arg)) +) + +(defun calc-percent () + (interactive) + (calc-slow-wrapper + (calc-pop-push-record-list + 1 "%" (list (list 'calcFunc-percent (calc-top-n 1))))) +) + + +(defun calc-over (n) + (interactive "P") + (if n + (calc-enter (- (prefix-numeric-value n))) + (calc-enter -2)) +) + + +(defun calc-pop-above (n) + (interactive "P") + (if n + (calc-pop (- (prefix-numeric-value n))) + (calc-pop -2)) +) + +(defun calc-roll-down (n) + (interactive "P") + (calc-wrapper + (let ((nn (prefix-numeric-value n))) + (cond ((null n) + (calc-roll-down-stack 2)) + ((> nn 0) + (calc-roll-down-stack nn)) + ((= nn 0) + (calc-pop-push-list (calc-stack-size) + (reverse + (calc-top-list (calc-stack-size))))) + (t + (calc-roll-down-stack (calc-stack-size) (- nn)))))) +) + +(defun calc-roll-up (n) + (interactive "P") + (calc-wrapper + (let ((nn (prefix-numeric-value n))) + (cond ((null n) + (calc-roll-up-stack 3)) + ((> nn 0) + (calc-roll-up-stack nn)) + ((= nn 0) + (calc-pop-push-list (calc-stack-size) + (reverse + (calc-top-list (calc-stack-size))))) + (t + (calc-roll-up-stack (calc-stack-size) (- nn)))))) +) + + + + +;;; Other commands. + +(defun calc-num-prefix-name (n) + (cond ((eq n '-) "- ") + ((equal n '(4)) "C-u ") + ((consp n) (format "%d " (car n))) + ((integerp n) (format "%d " n)) + (t "")) +) + +(defun calc-missing-key (n) + "This is a placeholder for a command which needs to be loaded from calc-ext. +When this key is used, calc-ext (the Calculator extensions module) will be +loaded and the keystroke automatically re-typed." + (interactive "P") + (calc-extensions) + (if (keymapp (key-binding (char-to-string last-command-char))) + (message "%s%c-" (calc-num-prefix-name n) last-command-char)) + (calc-unread-command) + (setq prefix-arg n) +) + +(defun calc-shift-Y-prefix-help () + (interactive) + (calc-extensions) + (calc-do-prefix-help calc-Y-help-msgs "other" ?Y) +) + + + + +(defun calcDigit-letter () + (interactive) + (if (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*") + (progn + (setq last-command-char (upcase last-command-char)) + (calcDigit-key)) + (calcDigit-nondigit)) +) + + +;; A Lisp version of temp_minibuffer_message from minibuf.c. +(defun calc-temp-minibuffer-message (m) + (let ((savemax (point-max))) + (save-excursion + (goto-char (point-max)) + (insert m)) + (let ((okay nil)) + (unwind-protect + (progn + (sit-for 2) + (identity 1) ; this forces a call to QUIT; in bytecode.c. + (setq okay t)) + (progn + (delete-region savemax (point-max)) + (or okay (abort-recursive-edit)))))) +) + + +(put 'math-with-extra-prec 'lisp-indent-hook 1) + + +;;; Concatenate two vectors, or a vector and an object. [V O O] [Public] +(defun math-concat (v1 v2) + (if (stringp v1) + (concat v1 v2) + (calc-extensions) + (if (and (or (math-objvecp v1) (math-known-scalarp v1)) + (or (math-objvecp v2) (math-known-scalarp v2))) + (append (if (and (math-vectorp v1) + (or (math-matrixp v1) + (not (math-matrixp v2)))) + v1 + (list 'vec v1)) + (if (and (math-vectorp v2) + (or (math-matrixp v2) + (not (math-matrixp v1)))) + (cdr v2) + (list v2))) + (list '| v1 v2))) +) + + +;;; True if A is zero. Works for un-normalized values. [P n] [Public] +(defun math-zerop (a) + (if (consp a) + (cond ((memq (car a) '(bigpos bigneg)) + (while (eq (car (setq a (cdr a))) 0)) + (null a)) + ((memq (car a) '(frac float polar mod)) + (math-zerop (nth 1 a))) + ((eq (car a) 'cplx) + (and (math-zerop (nth 1 a)) (math-zerop (nth 2 a)))) + ((eq (car a) 'hms) + (and (math-zerop (nth 1 a)) + (math-zerop (nth 2 a)) + (math-zerop (nth 3 a))))) + (eq a 0)) +) + + +;;; True if A is real and negative. [P n] [Public] + +(defun math-negp (a) + (if (consp a) + (cond ((eq (car a) 'bigpos) nil) + ((eq (car a) 'bigneg) (cdr a)) + ((memq (car a) '(float frac)) + (Math-integer-negp (nth 1 a))) + ((eq (car a) 'hms) + (if (math-zerop (nth 1 a)) + (if (math-zerop (nth 2 a)) + (math-negp (nth 3 a)) + (math-negp (nth 2 a))) + (math-negp (nth 1 a)))) + ((eq (car a) 'date) + (math-negp (nth 1 a))) + ((eq (car a) 'intv) + (or (math-negp (nth 3 a)) + (and (math-zerop (nth 3 a)) + (memq (nth 1 a) '(0 2))))) + ((equal a '(neg (var inf var-inf))) t)) + (< a 0)) +) + +;;; True if A is a negative number or an expression the starts with '-'. +(defun math-looks-negp (a) ; [P x] [Public] + (or (Math-negp a) + (eq (car-safe a) 'neg) + (and (memq (car-safe a) '(* /)) + (or (math-looks-negp (nth 1 a)) + (math-looks-negp (nth 2 a)))) + (and (eq (car-safe a) '-) + (math-looks-negp (nth 1 a)))) +) + + +;;; True if A is real and positive. [P n] [Public] +(defun math-posp (a) + (if (consp a) + (cond ((eq (car a) 'bigpos) (cdr a)) + ((eq (car a) 'bigneg) nil) + ((memq (car a) '(float frac)) + (Math-integer-posp (nth 1 a))) + ((eq (car a) 'hms) + (if (math-zerop (nth 1 a)) + (if (math-zerop (nth 2 a)) + (math-posp (nth 3 a)) + (math-posp (nth 2 a))) + (math-posp (nth 1 a)))) + ((eq (car a) 'date) + (math-posp (nth 1 a))) + ((eq (car a) 'mod) + (not (math-zerop (nth 1 a)))) + ((eq (car a) 'intv) + (or (math-posp (nth 2 a)) + (and (math-zerop (nth 2 a)) + (memq (nth 1 a) '(0 1))))) + ((equal a '(var inf var-inf)) t)) + (> a 0)) +) + +(fset 'math-fixnump (symbol-function 'integerp)) +(fset 'math-fixnatnump (symbol-function 'natnump)) + + +;;; True if A is an even integer. [P R R] [Public] +(defun math-evenp (a) + (if (consp a) + (and (memq (car a) '(bigpos bigneg)) + (= (% (nth 1 a) 2) 0)) + (= (% a 2) 0)) +) + +;;; Compute A / 2, for small or big integer A. [I i] +;;; If A is negative, type of truncation is undefined. +(defun math-div2 (a) + (if (consp a) + (if (cdr a) + (math-normalize (cons (car a) (math-div2-bignum (cdr a)))) + 0) + (/ a 2)) +) + +(defun math-div2-bignum (a) ; [l l] + (if (cdr a) + (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) 500)) + (math-div2-bignum (cdr a))) + (list (/ (car a) 2))) +) + + +;;; Reject an argument to a calculator function. [Public] +(defun math-reject-arg (&optional a p option) + (if option + (calc-record-why option p a) + (if p + (calc-record-why p a))) + (signal 'wrong-type-argument (and a (if p (list p a) (list a)))) +) + + +;;; Coerce A to be an integer (by truncation toward zero). [I N] [Public] +(defun math-trunc (a &optional prec) + (cond (prec + (calc-extensions) + (math-trunc-special a prec)) + ((Math-integerp a) a) + ((Math-looks-negp a) + (math-neg (math-trunc (math-neg a)))) + ((eq (car a) 'float) + (math-scale-int (nth 1 a) (nth 2 a))) + (t (calc-extensions) + (math-trunc-fancy a))) +) +(fset 'calcFunc-trunc (symbol-function 'math-trunc)) + +;;; Coerce A to be an integer (by truncation toward minus infinity). [I N] +(defun math-floor (a &optional prec) ; [Public] + (cond (prec + (calc-extensions) + (math-floor-special a prec)) + ((Math-integerp a) a) + ((Math-messy-integerp a) (math-trunc a)) + ((Math-realp a) + (if (Math-negp a) + (math-add (math-trunc a) -1) + (math-trunc a))) + (t (calc-extensions) + (math-floor-fancy a))) +) +(fset 'calcFunc-floor (symbol-function 'math-floor)) + + +(defun math-imod (a b) ; [I I I] [Public] + (if (and (not (consp a)) (not (consp b))) + (if (= b 0) + (math-reject-arg a "*Division by zero") + (% a b)) + (cdr (math-idivmod a b))) +) + + +(defun calcFunc-inv (m) + (if (Math-vectorp m) + (progn + (calc-extensions) + (if (math-square-matrixp m) + (or (math-with-extra-prec 2 (math-matrix-inv-raw m)) + (math-reject-arg m "*Singular matrix")) + (math-reject-arg m 'square-matrixp))) + (math-div 1 m)) +) + + +(defun math-do-working (msg arg) + (or executing-macro + (progn + (calc-set-command-flag 'clear-message) + (if math-working-step + (if math-working-step-2 + (setq msg (format "[%d/%d] %s" + math-working-step math-working-step-2 msg)) + (setq msg (format "[%d] %s" math-working-step msg)))) + (message "Working... %s = %s" msg + (math-showing-full-precision (math-format-number arg))))) +) + + +;;; Compute A modulo B, defined in terms of truncation toward minus infinity. +(defun math-mod (a b) ; [R R R] [Public] + (cond ((and (Math-zerop a) (not (eq (car-safe a) 'mod))) a) + ((Math-zerop b) + (math-reject-arg a "*Division by zero")) + ((and (Math-natnump a) (Math-natnump b)) + (math-imod a b)) + ((and (Math-anglep a) (Math-anglep b)) + (math-sub a (math-mul (math-floor (math-div a b)) b))) + (t (calc-extensions) + (math-mod-fancy a b))) +) + + + +;;; General exponentiation. + +(defun math-pow (a b) ; [O O N] [Public] + (cond ((equal b '(var nan var-nan)) + b) + ((Math-zerop a) + (if (and (Math-scalarp b) (Math-posp b)) + (if (math-floatp b) (math-float a) a) + (calc-extensions) + (math-pow-of-zero a b))) + ((or (eq a 1) (eq b 1)) a) + ((or (equal a '(float 1 0)) (equal b '(float 1 0))) a) + ((Math-zerop b) + (if (Math-scalarp a) + (if (or (math-floatp a) (math-floatp b)) + '(float 1 0) 1) + (calc-extensions) + (math-pow-zero a b))) + ((and (Math-integerp b) (or (Math-numberp a) (Math-vectorp a))) + (if (and (equal a '(float 1 1)) (integerp b)) + (math-make-float 1 b) + (math-with-extra-prec 2 + (math-ipow a b)))) + (t + (calc-extensions) + (math-pow-fancy a b))) +) + +(defun math-ipow (a n) ; [O O I] [Public] + (cond ((Math-integer-negp n) + (math-ipow (math-div 1 a) (Math-integer-neg n))) + ((not (consp n)) + (if (and (Math-ratp a) (> n 20)) + (math-iipow-show a n) + (math-iipow a n))) + ((math-evenp n) + (math-ipow (math-mul a a) (math-div2 n))) + (t + (math-mul a (math-ipow (math-mul a a) + (math-div2 (math-add n -1)))))) +) + +(defun math-iipow (a n) ; [O O S] + (cond ((= n 0) 1) + ((= n 1) a) + ((= (% n 2) 0) (math-iipow (math-mul a a) (/ n 2))) + (t (math-mul a (math-iipow (math-mul a a) (/ n 2))))) +) + +(defun math-iipow-show (a n) ; [O O S] + (math-working "pow" a) + (let ((val (cond + ((= n 0) 1) + ((= n 1) a) + ((= (% n 2) 0) (math-iipow-show (math-mul a a) (/ n 2))) + (t (math-mul a (math-iipow-show (math-mul a a) (/ n 2))))))) + (math-working "pow" val) + val) +) + + +(defun math-read-radix-digit (dig) ; [D S; Z S] + (if (> dig ?9) + (if (< dig ?A) + nil + (- dig 55)) + (if (>= dig ?0) + (- dig ?0) + nil)) +) + + + + + +;;; Bug reporting + +(defun report-calc-bug (topic) + "Report a bug in Calc, the GNU Emacs calculator. +Prompts for bug subject. Leaves you in a mail buffer." + (interactive "sBug Subject: ") + (mail nil calc-bug-address topic) + (goto-char (point-max)) + (insert "\nIn Calc " calc-version ", Emacs " (emacs-version) "\n\n") + (message (substitute-command-keys "Type \\[mail-send] to send bug report.")) +) +(fset 'calc-report-bug (symbol-function 'report-calc-bug)) + diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el new file mode 100644 index 0000000000..334bc3e7de --- /dev/null +++ b/lisp/calc/calc-mode.el @@ -0,0 +1,714 @@ +;; Calculator for GNU Emacs, part II [calc-mode.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-mode () nil) + + +(defun calc-line-numbering (n) + (interactive "P") + (calc-wrapper + (message (if (calc-change-mode 'calc-line-numbering n t t) + "Displaying stack level numbers." + "Hiding stack level numbers."))) +) + +(defun calc-line-breaking (n) + (interactive "P") + (calc-wrapper + (setq n (if n + (and (> (setq n (prefix-numeric-value n)) 0) + (or (< n 5) + n)) + (not calc-line-breaking))) + (if (calc-change-mode 'calc-line-breaking n t) + (if (integerp calc-line-breaking) + (message "Breaking lines longer than %d characters." n) + (message "Breaking long lines in Stack display.")) + (message "Not breaking long lines in Stack display."))) +) + + +(defun calc-left-justify (n) + (interactive "P") + (calc-wrapper + (and n (setq n (prefix-numeric-value n))) + (calc-change-mode '(calc-display-just calc-display-origin) + (list nil n) t) + (if n + (message "Displaying stack entries indented by %d." n) + (message "Displaying stack entries left-justified."))) +) + +(defun calc-center-justify (n) + (interactive "P") + (calc-wrapper + (and n (setq n (prefix-numeric-value n))) + (calc-change-mode '(calc-display-just calc-display-origin) + (list 'center n) t) + (if n + (message "Displaying stack entries centered on column %d." n) + (message "Displaying stack entries centered in window."))) +) + +(defun calc-right-justify (n) + (interactive "P") + (calc-wrapper + (and n (setq n (prefix-numeric-value n))) + (calc-change-mode '(calc-display-just calc-display-origin) + (list 'right n) t) + (if n + (message "Displaying stack entries right-justified to column %d." n) + (message "Displaying stack entries right-justified in window."))) +) + +(defun calc-left-label (s) + (interactive "sLefthand label: ") + (calc-wrapper + (or (equal s "") + (setq s (concat s " "))) + (calc-change-mode 'calc-left-label s t)) +) + +(defun calc-right-label (s) + (interactive "sRighthand label: ") + (calc-wrapper + (or (equal s "") + (setq s (concat " " s))) + (calc-change-mode 'calc-right-label s t)) +) + +(defun calc-auto-why (n) + (interactive "P") + (calc-wrapper + (if n + (progn + (setq n (prefix-numeric-value n)) + (if (<= n 0) (setq n nil) + (if (> n 1) (setq n t)))) + (setq n (and (not (eq calc-auto-why t)) (if calc-auto-why t 1)))) + (calc-change-mode 'calc-auto-why n nil) + (cond ((null n) + (message "User must press `w' to explain unsimplified results.")) + ((eq n t) + (message "Automatically doing `w' to explain unsimplified results.")) + (t + (message "Automatically doing `w' only for unusual messages.")))) +) + +(defun calc-group-digits (n) + (interactive "P") + (calc-wrapper + (if n + (progn + (setq n (prefix-numeric-value n)) + (cond ((or (> n 0) (< n -1))) + ((= n -1) + (setq n nil)) + (t + (setq n calc-group-digits)))) + (setq n (not calc-group-digits))) + (calc-change-mode 'calc-group-digits n t) + (cond ((null n) + (message "Grouping is off.")) + ((integerp n) + (message "Grouping every %d digits." (math-abs n))) + (t + (message "Grouping is on.")))) +) + +(defun calc-group-char (ch) + (interactive "cGrouping character: ") + (calc-wrapper + (or (>= ch 32) + (error "Control characters not allowed for grouping.")) + (if (= ch ?\\) + (setq ch "\\,") + (setq ch (char-to-string ch))) + (calc-change-mode 'calc-group-char ch calc-group-digits) + (message "Digit grouping character is \"%s\"." ch)) +) + +(defun calc-point-char (ch) + (interactive "cCharacter to use as decimal point: ") + (calc-wrapper + (or (>= ch 32) + (error "Control characters not allowed as decimal point.")) + (calc-change-mode 'calc-point-char (char-to-string ch) t) + (message "Decimal point character is \"%c\"." ch)) +) + +(defun calc-normal-notation (n) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-float-format + (let* ((val (if n (prefix-numeric-value n) 0)) + (mode (/ (+ val 5000) 10000))) + (if (or (< val -5000) (> mode 3)) + (error "Prefix out of range")) + (setq n (list (aref [float sci eng fix] mode) + (- (% (+ val 5000) 10000) 5000)))) + t) + (if (eq (nth 1 n) 0) + (message "Displaying floating-point numbers normally.") + (if (> (nth 1 n) 0) + (message + "Displaying floating-point numbers with %d significant digits." + (nth 1 n)) + (message "Displaying floating-point numbers with (precision%d)." + (nth 1 n))))) +) + +(defun calc-fix-notation (n) + (interactive "NDigits after decimal point: ") + (calc-wrapper + (calc-change-mode 'calc-float-format + (setq n (list 'fix (if n (prefix-numeric-value n) 0))) + t) + (message "Displaying floats with %d digits after decimal." + (math-abs (nth 1 n)))) +) + +(defun calc-sci-notation (n) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-float-format + (setq n (list 'sci (if n (prefix-numeric-value n) 0))) + t) + (if (eq (nth 1 n) 0) + (message "Displaying floats in scientific notation.") + (if (> (nth 1 n) 0) + (message "Displaying scientific notation with %d significant digits." + (nth 1 n)) + (message "Displaying scientific notation with (precision%d)." + (nth 1 n))))) +) + +(defun calc-eng-notation (n) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-float-format + (setq n (list 'eng (if n (prefix-numeric-value n) 0))) + t) + (if (eq (nth 1 n) 0) + (message "Displaying floats in engineering notation.") + (if (> (nth 1 n) 0) + (message "Displaying engineering notation with %d significant digits." + (nth 1 n)) + (message "Displaying engineering notation with (precision%d)." + (nth 1 n))))) +) + + +(defun calc-truncate-stack (n &optional rel) + (interactive "P") + (calc-wrapper + (let ((oldtop calc-stack-top) + (newtop calc-stack-top)) + (calc-record-undo (list 'set 'saved-stack-top calc-stack-top)) + (let ((calc-stack-top 0) + (nn (prefix-numeric-value n))) + (setq newtop + (if n + (progn + (if rel + (setq nn (+ oldtop nn)) + (if (< nn 0) + (setq nn (+ nn (calc-stack-size))) + (setq nn (1+ nn)))) + (if (< nn 1) + 1 + (if (> nn (calc-stack-size)) + (calc-stack-size) + nn))) + (max 1 (calc-locate-cursor-element (point))))) + (if (= newtop oldtop) + () + (calc-pop-stack 1 oldtop t) + (calc-push-list '(top-of-stack) newtop) + (if calc-line-numbering + (calc-refresh)))) + (calc-record-undo (list 'set 'saved-stack-top 0)) + (setq calc-stack-top newtop))) +) + +(defun calc-truncate-up (n) + (interactive "p") + (calc-truncate-stack n t) +) + +(defun calc-truncate-down (n) + (interactive "p") + (calc-truncate-stack (- n) t) +) + +(defun calc-display-raw (arg) + (interactive "P") + (calc-wrapper + (setq calc-display-raw (if calc-display-raw nil (if arg 0 t))) + (calc-do-refresh) + (if calc-display-raw + (message "Press d ' again to cancel \"raw\" display mode."))) +) + + + + +;;; Mode commands. + +(defun calc-save-modes (&optional quiet) + (interactive) + (calc-wrapper + (let (pos + (vals (mapcar (function (lambda (v) (symbol-value (car v)))) + calc-mode-var-list))) + (set-buffer (find-file-noselect (substitute-in-file-name + calc-settings-file))) + (goto-char (point-min)) + (if (and (search-forward ";;; Mode settings stored by Calc" nil t) + (progn + (beginning-of-line) + (setq pos (point)) + (search-forward "\n;;; End of mode settings" nil t))) + (progn + (beginning-of-line) + (forward-line 1) + (delete-region pos (point))) + (goto-char (point-max)) + (insert "\n\n") + (forward-char -1)) + (insert ";;; Mode settings stored by Calc on " (current-time-string) "\n") + (let ((list calc-mode-var-list)) + (while list + (let* ((v (car (car list))) + (def (nth 1 (car list))) + (val (car vals))) + (or (equal val def) + (progn + (insert "(setq " (symbol-name v) " ") + (if (and (or (listp val) + (symbolp val)) + (not (memq val '(nil t)))) + (insert "'")) + (insert (prin1-to-string val) ")\n")))) + (setq list (cdr list) + vals (cdr vals)))) + (run-hooks 'calc-mode-save-hook) + (insert ";;; End of mode settings\n") + (if quiet + (let ((executing-macro "")) ; what a kludge! + (save-buffer)) + (save-buffer)))) +) + +(defun calc-settings-file-name (name &optional arg) + (interactive "sSettings file name (normally ~/.emacs): \nP") + (calc-wrapper + (setq arg (if arg (prefix-numeric-value arg) 0)) + (if (equal name "") + (message "Calc settings file is \"%s\"" calc-settings-file) + (if (< (math-abs arg) 2) + (let ((list calc-mode-var-list)) + (while list + (set (car (car list)) (nth 1 (car list))) + (setq list (cdr list))))) + (setq calc-settings-file name) + (or (and (string-match "\\.emacs" calc-settings-file) + (> arg 0)) + (< arg 0) + (load name t) + (message "New file")))) +) + +(defun math-get-modes-vec () + (list 'vec + calc-internal-prec + calc-word-size + (calc-stack-size) + calc-number-radix + (+ (if (<= (nth 1 calc-float-format) 0) + (+ calc-internal-prec (nth 1 calc-float-format)) + (nth 1 calc-float-format)) + (cdr (assq (car calc-float-format) + '((float . 0) (sci . 10000) + (eng . 20000) (fix . 30000))))) + (cond ((eq calc-angle-mode 'rad) 2) + ((eq calc-angle-mode 'hms) 3) + (t 1)) + (if calc-symbolic-mode 1 0) + (if calc-prefer-frac 1 0) + (if (eq calc-complex-mode 'polar) 1 0) + (cond ((eq calc-matrix-mode 'scalar) 0) + ((eq calc-matrix-mode 'matrix) -2) + (calc-matrix-mode) + (t -1)) + (cond ((eq calc-simplify-mode 'none) -1) + ((eq calc-simplify-mode 'num) 0) + ((eq calc-simplify-mode 'binary) 2) + ((eq calc-simplify-mode 'alg) 3) + ((eq calc-simplify-mode 'ext) 4) + ((eq calc-simplify-mode 'units) 5) + (t 1)) + (cond ((eq calc-infinite-mode 1) 0) + (calc-infinite-mode 1) + (t -1))) +) + +(defun calc-get-modes (n) + (interactive "P") + (calc-wrapper + (let ((modes (math-get-modes-vec))) + (calc-enter-result 0 "mode" + (if n + (if (and (>= (setq n (prefix-numeric-value n)) 1) + (< n (length modes))) + (nth n modes) + (error "Prefix out of range")) + modes)))) +) + +(defun calc-shift-prefix (arg) + (interactive "P") + (calc-wrapper + (setq calc-shift-prefix (if arg + (> (prefix-numeric-value arg) 0) + (not calc-shift-prefix))) + (calc-init-prefixes) + (message (if calc-shift-prefix + "Prefix keys are now case-insensitive" + "Prefix keys must be unshifted (except V, Z)"))) +) + +(defun calc-mode-record-mode (n) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-mode-save-mode + (cond ((null n) + (cond ((not calc-embedded-info) + (if (eq calc-mode-save-mode 'save) + 'local 'save)) + ((eq calc-mode-save-mode 'local) 'edit) + ((eq calc-mode-save-mode 'edit) 'perm) + ((eq calc-mode-save-mode 'perm) 'global) + ((eq calc-mode-save-mode 'global) 'save) + ((eq calc-mode-save-mode 'save) nil) + ((eq calc-mode-save-mode nil) 'local))) + ((= (setq n (prefix-numeric-value n)) 0) nil) + ((= n 2) 'edit) + ((= n 3) 'perm) + ((= n 4) 'global) + ((= n 5) 'save) + (t 'local))) + (message (cond ((and (eq calc-mode-save-mode 'local) calc-embedded-info) + "Recording mode changes with [calc-mode: ...]") + ((eq calc-mode-save-mode 'edit) + "Recording mode changes with [calc-edit-mode: ...]") + ((eq calc-mode-save-mode 'perm) + "Recording mode changes with [calc-perm-mode: ...]") + ((eq calc-mode-save-mode 'global) + "Recording mode changes with [calc-global-mode: ...]") + ((eq calc-mode-save-mode 'save) + (format "Recording mode changes in \"%s\"." + calc-settings-file)) + (t + "Not recording mode changes permanently.")))) +) + +(defun calc-total-algebraic-mode (flag) + (interactive "P") + (if calc-emacs-type-19 + (error "Total algebraic mode not yet supported for Emacs 19")) + (calc-wrapper + (if (eq calc-algebraic-mode 'total) + (calc-algebraic-mode nil) + (calc-change-mode '(calc-algebraic-mode calc-incomplete-algebraic-mode) + '(total nil)) + (use-local-map calc-alg-map) + (message + "All keys begin algebraic entry; use Meta (ESC) for Calc keys."))) +) + +(defun calc-algebraic-mode (flag) + (interactive "P") + (calc-wrapper + (if flag + (calc-change-mode '(calc-algebraic-mode + calc-incomplete-algebraic-mode) + (list nil (not calc-incomplete-algebraic-mode))) + (calc-change-mode '(calc-algebraic-mode calc-incomplete-algebraic-mode) + (list (not calc-algebraic-mode) nil))) + (use-local-map calc-mode-map) + (message (if calc-algebraic-mode + "Numeric keys and ( and [ begin algebraic entry." + (if calc-incomplete-algebraic-mode + "Only ( and [ begin algebraic entry." + "No keys except ' and $ begin algebraic entry.")))) +) + +(defun calc-symbolic-mode (n) + (interactive "P") + (calc-wrapper + + (message (if (calc-change-mode 'calc-symbolic-mode n nil t) + "Inexact computations like sqrt(2) are deferred." + "Numerical computations are always done immediately."))) +) + +(defun calc-infinite-mode (n) + (interactive "P") + (calc-wrapper + (if (eq n 0) + (progn + (calc-change-mode 'calc-infinite-mode 1) + (message "Computations like 1 / 0 produce \"inf\".")) + (message (if (calc-change-mode 'calc-infinite-mode n nil t) + "Computations like 1 / 0 produce \"uinf\"." + "Computations like 1 / 0 are left unsimplified.")))) +) + +(defun calc-matrix-mode (arg) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-matrix-mode + (cond ((eq arg 0) 'scalar) + ((< (prefix-numeric-value arg) 1) + (and (< (prefix-numeric-value arg) -1) 'matrix)) + (arg (prefix-numeric-value arg)) + ((eq calc-matrix-mode 'matrix) 'scalar) + ((eq calc-matrix-mode 'scalar) nil) + (t 'matrix))) + (if (integerp calc-matrix-mode) + (message "Variables are assumed to be %dx%d matrices." + calc-matrix-mode calc-matrix-mode) + (message (if (eq calc-matrix-mode 'matrix) + "Variables are assumed to be matrices." + (if calc-matrix-mode + "Variables are assumed to be scalars (non-matrices)." + "Variables are not assumed to be matrix or scalar."))))) +) + +(defun calc-set-simplify-mode (mode arg msg) + (calc-change-mode 'calc-simplify-mode + (if arg + (and (> (prefix-numeric-value arg) 0) + mode) + (and (not (eq calc-simplify-mode mode)) + mode))) + (message (if (eq calc-simplify-mode mode) + msg + "Default simplifications enabled.")) +) + +(defun calc-no-simplify-mode (arg) + (interactive "P") + (calc-wrapper + (calc-set-simplify-mode 'none arg + "All default simplifications are disabled.")) +) + +(defun calc-num-simplify-mode (arg) + (interactive "P") + (calc-wrapper + (calc-set-simplify-mode 'num arg + "Default simplifications apply only if arguments are numeric.")) +) + +(defun calc-default-simplify-mode (arg) + (interactive "p") + (cond ((= arg 1) + (calc-wrapper + (calc-set-simplify-mode + nil nil "Usual default simplifications are enabled."))) + ((= arg 0) (calc-num-simplify-mode 1)) + ((< arg 0) (calc-no-simplify-mode 1)) + ((= arg 2) (calc-bin-simplify-mode 1)) + ((= arg 3) (calc-alg-simplify-mode 1)) + ((= arg 4) (calc-ext-simplify-mode 1)) + ((= arg 5) (calc-units-simplify-mode 1)) + (t (error "Prefix argument out of range"))) +) + +(defun calc-bin-simplify-mode (arg) + (interactive "P") + (calc-wrapper + (calc-set-simplify-mode 'binary arg + (format "Binary simplification occurs by default (word size=%d)." + calc-word-size))) +) + +(defun calc-alg-simplify-mode (arg) + (interactive "P") + (calc-wrapper + (calc-set-simplify-mode 'alg arg + "Algebraic simplification occurs by default.")) +) + +(defun calc-ext-simplify-mode (arg) + (interactive "P") + (calc-wrapper + (calc-set-simplify-mode 'ext arg + "Extended algebraic simplification occurs by default.")) +) + +(defun calc-units-simplify-mode (arg) + (interactive "P") + (calc-wrapper + (calc-set-simplify-mode 'units arg + "Units simplification occurs by default.")) +) + +(defun calc-auto-recompute (arg) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-auto-recompute arg nil t) + (calc-refresh-evaltos) + (message (if calc-auto-recompute + "Automatically recomputing `=>' forms when necessary." + "Not recomputing `=>' forms automatically."))) +) + +(defun calc-working (n) + (interactive "P") + (calc-wrapper + (cond ((consp n) + (calc-pop-push-record 0 "work" + (cond ((eq calc-display-working-message t) 1) + (calc-display-working-message 2) + (t 0)))) + ((eq n 2) (calc-change-mode 'calc-display-working-message 'lots)) + ((eq n 0) (calc-change-mode 'calc-display-working-message nil)) + ((eq n 1) (calc-change-mode 'calc-display-working-message t))) + (cond ((eq calc-display-working-message t) + (message "\"Working...\" messages enabled.")) + (calc-display-working-message + (message "Detailed \"Working...\" messages enabled.")) + (t + (message "\"Working...\" messages disabled.")))) +) + +(defun calc-always-load-extensions () + (interactive) + (calc-wrapper + (if (setq calc-always-load-extensions (not calc-always-load-extensions)) + (message "Always loading extensions package.") + (message "Loading extensions package on demand only."))) +) + + +(defun calc-matrix-left-justify () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-matrix-just nil t) + (message "Matrix elements will be left-justified in columns.")) +) + +(defun calc-matrix-center-justify () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-matrix-just 'center t) + (message "Matrix elements will be centered in columns.")) +) + +(defun calc-matrix-right-justify () + (interactive) + (calc-wrapper + (calc-change-mode 'calc-matrix-just 'right t) + (message "Matrix elements will be right-justified in columns.")) +) + +(defun calc-full-vectors (n) + (interactive "P") + (calc-wrapper + (message (if (calc-change-mode 'calc-full-vectors n t t) + "Displaying long vectors in full." + "Displaying long vectors in [a, b, c, ..., z] notation."))) +) + +(defun calc-full-trail-vectors (n) + (interactive "P") + (calc-wrapper + (message (if (calc-change-mode 'calc-full-trail-vectors n nil t) + "Recording long vectors in full." + "Recording long vectors in [a, b, c, ..., z] notation."))) +) + +(defun calc-break-vectors (n) + (interactive "P") + (calc-wrapper + (message (if (calc-change-mode 'calc-break-vectors n t t) + "Displaying vector elements one-per-line." + "Displaying vector elements all on one line."))) +) + +(defun calc-vector-commas () + (interactive) + (calc-wrapper + (if (calc-change-mode 'calc-vector-commas (if calc-vector-commas nil ",") t) + (message "Separating vector elements with \",\".") + (message "Separating vector elements with spaces."))) +) + +(defun calc-vector-brackets () + (interactive) + (calc-wrapper + (if (calc-change-mode 'calc-vector-brackets + (if (equal calc-vector-brackets "[]") nil "[]") t) + (message "Surrounding vectors with \"[]\".") + (message "Not surrounding vectors with brackets."))) +) + +(defun calc-vector-braces () + (interactive) + (calc-wrapper + (if (calc-change-mode 'calc-vector-brackets + (if (equal calc-vector-brackets "{}") nil "{}") t) + (message "Surrounding vectors with \"{}\".") + (message "Not surrounding vectors with brackets."))) +) + +(defun calc-vector-parens () + (interactive) + (calc-wrapper + (if (calc-change-mode 'calc-vector-brackets + (if (equal calc-vector-brackets "()") nil "()") t) + (message "Surrounding vectors with \"()\".") + (message "Not surrounding vectors with brackets."))) +) + +(defun calc-matrix-brackets (arg) + (interactive "sCode letters (R, O, C, P): ") + (calc-wrapper + (let ((code (append (and (string-match "[rR]" arg) '(R)) + (and (string-match "[oO]" arg) '(O)) + (and (string-match "[cC]" arg) '(C)) + (and (string-match "[pP]" arg) '(P)))) + (bad (string-match "[^rRoOcCpP ]" arg))) + (if bad + (error "Unrecognized character: %c" (aref arg bad))) + (calc-change-mode 'calc-matrix-brackets code t))) +) + diff --git a/lisp/calc/calc-mtx.el b/lisp/calc/calc-mtx.el new file mode 100644 index 0000000000..b9dc2aa6d0 --- /dev/null +++ b/lisp/calc/calc-mtx.el @@ -0,0 +1,378 @@ +;; Calculator for GNU Emacs, part II [calc-mat.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-mat () nil) + + +(defun calc-mdet (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "mdet" 'calcFunc-det arg)) +) + +(defun calc-mtrace (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "mtr" 'calcFunc-tr arg)) +) + +(defun calc-mlud (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "mlud" 'calcFunc-lud arg)) +) + + +;;; Coerce row vector A to be a matrix. [V V] +(defun math-row-matrix (a) + (if (and (Math-vectorp a) + (not (math-matrixp a))) + (list 'vec a) + a) +) + +;;; Coerce column vector A to be a matrix. [V V] +(defun math-col-matrix (a) + (if (and (Math-vectorp a) + (not (math-matrixp a))) + (cons 'vec (mapcar (function (lambda (x) (list 'vec x))) (cdr a))) + a) +) + + + +;;; Multiply matrices A and B. [V V V] +(defun math-mul-mats (a b) + (let ((mat nil) + (cols (length (nth 1 b))) + row col ap bp accum) + (while (setq a (cdr a)) + (setq col cols + row nil) + (while (> (setq col (1- col)) 0) + (setq ap (cdr (car a)) + bp (cdr b) + accum (math-mul (car ap) (nth col (car bp)))) + (while (setq ap (cdr ap) bp (cdr bp)) + (setq accum (math-add accum (math-mul (car ap) (nth col (car bp)))))) + (setq row (cons accum row))) + (setq mat (cons (cons 'vec row) mat))) + (cons 'vec (nreverse mat))) +) + +(defun math-mul-mat-vec (a b) + (cons 'vec (mapcar (function (lambda (row) + (math-dot-product row b))) + (cdr a))) +) + + + +(defun calcFunc-tr (mat) ; [Public] + (if (math-square-matrixp mat) + (math-matrix-trace-step 2 (1- (length mat)) mat (nth 1 (nth 1 mat))) + (math-reject-arg mat 'square-matrixp)) +) + +(defun math-matrix-trace-step (n size mat sum) + (if (<= n size) + (math-matrix-trace-step (1+ n) size mat + (math-add sum (nth n (nth n mat)))) + sum) +) + + +;;; Matrix inverse and determinant. +(defun math-matrix-inv-raw (m) + (let ((n (1- (length m)))) + (if (<= n 3) + (let ((det (math-det-raw m))) + (and (not (math-zerop det)) + (math-div + (cond ((= n 1) 1) + ((= n 2) + (list 'vec + (list 'vec + (nth 2 (nth 2 m)) + (math-neg (nth 2 (nth 1 m)))) + (list 'vec + (math-neg (nth 1 (nth 2 m))) + (nth 1 (nth 1 m))))) + ((= n 3) + (list 'vec + (list 'vec + (math-sub (math-mul (nth 3 (nth 3 m)) + (nth 2 (nth 2 m))) + (math-mul (nth 3 (nth 2 m)) + (nth 2 (nth 3 m)))) + (math-sub (math-mul (nth 3 (nth 1 m)) + (nth 2 (nth 3 m))) + (math-mul (nth 3 (nth 3 m)) + (nth 2 (nth 1 m)))) + (math-sub (math-mul (nth 3 (nth 2 m)) + (nth 2 (nth 1 m))) + (math-mul (nth 3 (nth 1 m)) + (nth 2 (nth 2 m))))) + (list 'vec + (math-sub (math-mul (nth 3 (nth 2 m)) + (nth 1 (nth 3 m))) + (math-mul (nth 3 (nth 3 m)) + (nth 1 (nth 2 m)))) + (math-sub (math-mul (nth 3 (nth 3 m)) + (nth 1 (nth 1 m))) + (math-mul (nth 3 (nth 1 m)) + (nth 1 (nth 3 m)))) + (math-sub (math-mul (nth 3 (nth 1 m)) + (nth 1 (nth 2 m))) + (math-mul (nth 3 (nth 2 m)) + (nth 1 (nth 1 m))))) + (list 'vec + (math-sub (math-mul (nth 2 (nth 3 m)) + (nth 1 (nth 2 m))) + (math-mul (nth 2 (nth 2 m)) + (nth 1 (nth 3 m)))) + (math-sub (math-mul (nth 2 (nth 1 m)) + (nth 1 (nth 3 m))) + (math-mul (nth 2 (nth 3 m)) + (nth 1 (nth 1 m)))) + (math-sub (math-mul (nth 2 (nth 2 m)) + (nth 1 (nth 1 m))) + (math-mul (nth 2 (nth 1 m)) + (nth 1 (nth 2 m)))))))) + det))) + (let ((lud (math-matrix-lud m))) + (and lud + (math-lud-solve lud (calcFunc-idn 1 n)))))) +) + +(defun calcFunc-det (m) + (if (math-square-matrixp m) + (math-with-extra-prec 2 (math-det-raw m)) + (if (and (eq (car-safe m) 'calcFunc-idn) + (or (math-zerop (nth 1 m)) + (math-equal-int (nth 1 m) 1))) + (nth 1 m) + (math-reject-arg m 'square-matrixp))) +) + +(defun math-det-raw (m) + (let ((n (1- (length m)))) + (cond ((= n 1) + (nth 1 (nth 1 m))) + ((= n 2) + (math-sub (math-mul (nth 1 (nth 1 m)) + (nth 2 (nth 2 m))) + (math-mul (nth 2 (nth 1 m)) + (nth 1 (nth 2 m))))) + ((= n 3) + (math-sub + (math-sub + (math-sub + (math-add + (math-add + (math-mul (nth 1 (nth 1 m)) + (math-mul (nth 2 (nth 2 m)) + (nth 3 (nth 3 m)))) + (math-mul (nth 2 (nth 1 m)) + (math-mul (nth 3 (nth 2 m)) + (nth 1 (nth 3 m))))) + (math-mul (nth 3 (nth 1 m)) + (math-mul (nth 1 (nth 2 m)) + (nth 2 (nth 3 m))))) + (math-mul (nth 3 (nth 1 m)) + (math-mul (nth 2 (nth 2 m)) + (nth 1 (nth 3 m))))) + (math-mul (nth 1 (nth 1 m)) + (math-mul (nth 3 (nth 2 m)) + (nth 2 (nth 3 m))))) + (math-mul (nth 2 (nth 1 m)) + (math-mul (nth 1 (nth 2 m)) + (nth 3 (nth 3 m)))))) + (t (let ((lud (math-matrix-lud m))) + (if lud + (let ((lu (car lud))) + (math-det-step n (nth 2 lud))) + 0))))) +) + +(defun math-det-step (n prod) + (if (> n 0) + (math-det-step (1- n) (math-mul prod (nth n (nth n lu)))) + prod) +) + +;;; This returns a list (LU index d), or NIL if not possible. +;;; Argument M must be a square matrix. +(defun math-matrix-lud (m) + (let ((old (assoc m math-lud-cache)) + (context (list calc-internal-prec calc-prefer-frac))) + (if (and old (equal (nth 1 old) context)) + (cdr (cdr old)) + (let* ((lud (catch 'singular (math-do-matrix-lud m))) + (entry (cons context lud))) + (if old + (setcdr old entry) + (setq math-lud-cache (cons (cons m entry) math-lud-cache))) + lud))) +) +(defvar math-lud-cache nil) + +;;; Numerical Recipes section 2.3; implicit pivoting omitted. +(defun math-do-matrix-lud (m) + (let* ((lu (math-copy-matrix m)) + (n (1- (length lu))) + i (j 1) k imax sum big + (d 1) (index nil)) + (while (<= j n) + (setq i 1 + big 0 + imax j) + (while (< i j) + (math-working "LUD step" (format "%d/%d" j i)) + (setq sum (nth j (nth i lu)) + k 1) + (while (< k i) + (setq sum (math-sub sum (math-mul (nth k (nth i lu)) + (nth j (nth k lu)))) + k (1+ k))) + (setcar (nthcdr j (nth i lu)) sum) + (setq i (1+ i))) + (while (<= i n) + (math-working "LUD step" (format "%d/%d" j i)) + (setq sum (nth j (nth i lu)) + k 1) + (while (< k j) + (setq sum (math-sub sum (math-mul (nth k (nth i lu)) + (nth j (nth k lu)))) + k (1+ k))) + (setcar (nthcdr j (nth i lu)) sum) + (let ((dum (math-abs-approx sum))) + (if (Math-lessp big dum) + (setq big dum + imax i))) + (setq i (1+ i))) + (if (> imax j) + (setq lu (math-swap-rows lu j imax) + d (- d))) + (setq index (cons imax index)) + (let ((pivot (nth j (nth j lu)))) + (if (math-zerop pivot) + (throw 'singular nil) + (setq i j) + (while (<= (setq i (1+ i)) n) + (setcar (nthcdr j (nth i lu)) + (math-div (nth j (nth i lu)) pivot))))) + (setq j (1+ j))) + (list lu (nreverse index) d)) +) + +(defun math-swap-rows (m r1 r2) + (or (= r1 r2) + (let* ((r1prev (nthcdr (1- r1) m)) + (row1 (cdr r1prev)) + (r2prev (nthcdr (1- r2) m)) + (row2 (cdr r2prev)) + (r2next (cdr row2))) + (setcdr r2prev row1) + (setcdr r1prev row2) + (setcdr row2 (cdr row1)) + (setcdr row1 r2next))) + m +) + + +(defun math-lud-solve (lud b &optional need) + (if lud + (let* ((x (math-copy-matrix b)) + (n (1- (length x))) + (m (1- (length (nth 1 x)))) + (lu (car lud)) + (col 1) + i j ip ii index sum) + (while (<= col m) + (math-working "LUD solver step" col) + (setq i 1 + ii nil + index (nth 1 lud)) + (while (<= i n) + (setq ip (car index) + index (cdr index) + sum (nth col (nth ip x))) + (setcar (nthcdr col (nth ip x)) (nth col (nth i x))) + (if (null ii) + (or (math-zerop sum) + (setq ii i)) + (setq j ii) + (while (< j i) + (setq sum (math-sub sum (math-mul (nth j (nth i lu)) + (nth col (nth j x)))) + j (1+ j)))) + (setcar (nthcdr col (nth i x)) sum) + (setq i (1+ i))) + (while (>= (setq i (1- i)) 1) + (setq sum (nth col (nth i x)) + j i) + (while (<= (setq j (1+ j)) n) + (setq sum (math-sub sum (math-mul (nth j (nth i lu)) + (nth col (nth j x)))))) + (setcar (nthcdr col (nth i x)) + (math-div sum (nth i (nth i lu))))) + (setq col (1+ col))) + x) + (and need + (math-reject-arg need "*Singular matrix"))) +) + +(defun calcFunc-lud (m) + (if (math-square-matrixp m) + (or (math-with-extra-prec 2 + (let ((lud (math-matrix-lud m))) + (and lud + (let* ((lmat (math-copy-matrix (car lud))) + (umat (math-copy-matrix (car lud))) + (n (1- (length (car lud)))) + (perm (calcFunc-idn 1 n)) + i (j 1)) + (while (<= j n) + (setq i 1) + (while (< i j) + (setcar (nthcdr j (nth i lmat)) 0) + (setq i (1+ i))) + (setcar (nthcdr j (nth j lmat)) 1) + (while (<= (setq i (1+ i)) n) + (setcar (nthcdr j (nth i umat)) 0)) + (setq j (1+ j))) + (while (>= (setq j (1- j)) 1) + (let ((pos (nth (1- j) (nth 1 lud)))) + (or (= pos j) + (setq perm (math-swap-rows perm j pos))))) + (list 'vec perm lmat umat))))) + (math-reject-arg m "*Singular matrix")) + (math-reject-arg m 'square-matrixp)) +) + diff --git a/lisp/calc/calc-poly.el b/lisp/calc/calc-poly.el new file mode 100644 index 0000000000..eba14b7d62 --- /dev/null +++ b/lisp/calc/calc-poly.el @@ -0,0 +1,1195 @@ +;; Calculator for GNU Emacs, part II [calc-poly.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-poly () nil) + + +(defun calcFunc-pcont (expr &optional var) + (cond ((Math-primp expr) + (cond ((Math-zerop expr) 1) + ((Math-messy-integerp expr) (math-trunc expr)) + ((Math-objectp expr) expr) + ((or (equal expr var) (not var)) 1) + (t expr))) + ((eq (car expr) '*) + (math-mul (calcFunc-pcont (nth 1 expr) var) + (calcFunc-pcont (nth 2 expr) var))) + ((eq (car expr) '/) + (math-div (calcFunc-pcont (nth 1 expr) var) + (calcFunc-pcont (nth 2 expr) var))) + ((and (eq (car expr) '^) (Math-natnump (nth 2 expr))) + (math-pow (calcFunc-pcont (nth 1 expr) var) (nth 2 expr))) + ((memq (car expr) '(neg polar)) + (calcFunc-pcont (nth 1 expr) var)) + ((consp var) + (let ((p (math-is-polynomial expr var))) + (if p + (let ((lead (nth (1- (length p)) p)) + (cont (math-poly-gcd-list p))) + (if (math-guess-if-neg lead) + (math-neg cont) + cont)) + 1))) + ((memq (car expr) '(+ - cplx sdev)) + (let ((cont (calcFunc-pcont (nth 1 expr) var))) + (if (eq cont 1) + 1 + (let ((c2 (calcFunc-pcont (nth 2 expr) var))) + (if (and (math-negp cont) + (if (eq (car expr) '-) (math-posp c2) (math-negp c2))) + (math-neg (math-poly-gcd cont c2)) + (math-poly-gcd cont c2)))))) + (var expr) + (t 1)) +) + +(defun calcFunc-pprim (expr &optional var) + (let ((cont (calcFunc-pcont expr var))) + (if (math-equal-int cont 1) + expr + (math-poly-div-exact expr cont var))) +) + +(defun math-div-poly-const (expr c) + (cond ((memq (car-safe expr) '(+ -)) + (list (car expr) + (math-div-poly-const (nth 1 expr) c) + (math-div-poly-const (nth 2 expr) c))) + (t (math-div expr c))) +) + +(defun calcFunc-pdeg (expr &optional var) + (if (Math-zerop expr) + '(neg (var inf var-inf)) + (if var + (or (math-polynomial-p expr var) + (math-reject-arg expr "Expected a polynomial")) + (math-poly-degree expr))) +) + +(defun math-poly-degree (expr) + (cond ((Math-primp expr) + (if (eq (car-safe expr) 'var) 1 0)) + ((eq (car expr) 'neg) + (math-poly-degree (nth 1 expr))) + ((eq (car expr) '*) + (+ (math-poly-degree (nth 1 expr)) + (math-poly-degree (nth 2 expr)))) + ((eq (car expr) '/) + (- (math-poly-degree (nth 1 expr)) + (math-poly-degree (nth 2 expr)))) + ((and (eq (car expr) '^) (natnump (nth 2 expr))) + (* (math-poly-degree (nth 1 expr)) (nth 2 expr))) + ((memq (car expr) '(+ -)) + (max (math-poly-degree (nth 1 expr)) + (math-poly-degree (nth 2 expr)))) + (t 1)) +) + +(defun calcFunc-plead (expr var) + (cond ((eq (car-safe expr) '*) + (math-mul (calcFunc-plead (nth 1 expr) var) + (calcFunc-plead (nth 2 expr) var))) + ((eq (car-safe expr) '/) + (math-div (calcFunc-plead (nth 1 expr) var) + (calcFunc-plead (nth 2 expr) var))) + ((and (eq (car-safe expr) '^) (math-natnump (nth 2 expr))) + (math-pow (calcFunc-plead (nth 1 expr) var) (nth 2 expr))) + ((Math-primp expr) + (if (equal expr var) + 1 + expr)) + (t + (let ((p (math-is-polynomial expr var))) + (if (cdr p) + (nth (1- (length p)) p) + 1)))) +) + + + + + +;;; Polynomial quotient, remainder, and GCD. +;;; Originally by Ove Ewerlid ([email protected]). +;;; Modifications and simplifications by daveg. + +(setq math-poly-modulus 1) + +;;; Return gcd of two polynomials +(defun calcFunc-pgcd (pn pd) + (if (math-any-floats pn) + (math-reject-arg pn "Coefficients must be rational")) + (if (math-any-floats pd) + (math-reject-arg pd "Coefficients must be rational")) + (let ((calc-prefer-frac t) + (math-poly-modulus (math-poly-modulus pn pd))) + (math-poly-gcd pn pd)) +) + +;;; Return only quotient to top of stack (nil if zero) +(defun calcFunc-pdiv (pn pd &optional base) + (let* ((calc-prefer-frac t) + (math-poly-modulus (math-poly-modulus pn pd)) + (res (math-poly-div pn pd base))) + (setq calc-poly-div-remainder (cdr res)) + (car res)) +) + +;;; Return only remainder to top of stack +(defun calcFunc-prem (pn pd &optional base) + (let ((calc-prefer-frac t) + (math-poly-modulus (math-poly-modulus pn pd))) + (cdr (math-poly-div pn pd base))) +) + +(defun calcFunc-pdivrem (pn pd &optional base) + (let* ((calc-prefer-frac t) + (math-poly-modulus (math-poly-modulus pn pd)) + (res (math-poly-div pn pd base))) + (list 'vec (car res) (cdr res))) +) + +(defun calcFunc-pdivide (pn pd &optional base) + (let* ((calc-prefer-frac t) + (math-poly-modulus (math-poly-modulus pn pd)) + (res (math-poly-div pn pd base))) + (math-add (car res) (math-div (cdr res) pd))) +) + + +;;; Multiply two terms, expanding out products of sums. +(defun math-mul-thru (lhs rhs) + (if (memq (car-safe lhs) '(+ -)) + (list (car lhs) + (math-mul-thru (nth 1 lhs) rhs) + (math-mul-thru (nth 2 lhs) rhs)) + (if (memq (car-safe rhs) '(+ -)) + (list (car rhs) + (math-mul-thru lhs (nth 1 rhs)) + (math-mul-thru lhs (nth 2 rhs))) + (math-mul lhs rhs))) +) + +(defun math-div-thru (num den) + (if (memq (car-safe num) '(+ -)) + (list (car num) + (math-div-thru (nth 1 num) den) + (math-div-thru (nth 2 num) den)) + (math-div num den)) +) + + +;;; Sort the terms of a sum into canonical order. +(defun math-sort-terms (expr) + (if (memq (car-safe expr) '(+ -)) + (math-list-to-sum + (sort (math-sum-to-list expr) + (function (lambda (a b) (math-beforep (car a) (car b)))))) + expr) +) + +(defun math-list-to-sum (lst) + (if (cdr lst) + (list (if (cdr (car lst)) '- '+) + (math-list-to-sum (cdr lst)) + (car (car lst))) + (if (cdr (car lst)) + (math-neg (car (car lst))) + (car (car lst)))) +) + +(defun math-sum-to-list (tree &optional neg) + (cond ((eq (car-safe tree) '+) + (nconc (math-sum-to-list (nth 1 tree) neg) + (math-sum-to-list (nth 2 tree) neg))) + ((eq (car-safe tree) '-) + (nconc (math-sum-to-list (nth 1 tree) neg) + (math-sum-to-list (nth 2 tree) (not neg)))) + (t (list (cons tree neg)))) +) + +;;; Check if the polynomial coefficients are modulo forms. +(defun math-poly-modulus (expr &optional expr2) + (or (math-poly-modulus-rec expr) + (and expr2 (math-poly-modulus-rec expr2)) + 1) +) + +(defun math-poly-modulus-rec (expr) + (if (and (eq (car-safe expr) 'mod) (Math-natnump (nth 2 expr))) + (list 'mod 1 (nth 2 expr)) + (and (memq (car-safe expr) '(+ - * /)) + (or (math-poly-modulus-rec (nth 1 expr)) + (math-poly-modulus-rec (nth 2 expr))))) +) + + +;;; Divide two polynomials. Return (quotient . remainder). +(defun math-poly-div (u v &optional math-poly-div-base) + (if math-poly-div-base + (math-do-poly-div u v) + (math-do-poly-div (calcFunc-expand u) (calcFunc-expand v))) +) +(setq math-poly-div-base nil) + +(defun math-poly-div-exact (u v &optional base) + (let ((res (math-poly-div u v base))) + (if (eq (cdr res) 0) + (car res) + (math-reject-arg (list 'vec u v) "Argument is not a polynomial"))) +) + +(defun math-do-poly-div (u v) + (cond ((math-constp u) + (if (math-constp v) + (cons (math-div u v) 0) + (cons 0 u))) + ((math-constp v) + (cons (if (eq v 1) + u + (if (memq (car-safe u) '(+ -)) + (math-add-or-sub (math-poly-div-exact (nth 1 u) v) + (math-poly-div-exact (nth 2 u) v) + nil (eq (car u) '-)) + (math-div u v))) + 0)) + ((Math-equal u v) + (cons math-poly-modulus 0)) + ((and (math-atomic-factorp u) (math-atomic-factorp v)) + (cons (math-simplify (math-div u v)) 0)) + (t + (let ((base (or math-poly-div-base + (math-poly-div-base u v))) + vp up res) + (if (or (null base) + (null (setq vp (math-is-polynomial v base nil 'gen)))) + (cons 0 u) + (setq up (math-is-polynomial u base nil 'gen) + res (math-poly-div-coefs up vp)) + (cons (math-build-polynomial-expr (car res) base) + (math-build-polynomial-expr (cdr res) base)))))) +) + +(defun math-poly-div-rec (u v) + (cond ((math-constp u) + (math-div u v)) + ((math-constp v) + (if (eq v 1) + u + (if (memq (car-safe u) '(+ -)) + (math-add-or-sub (math-poly-div-rec (nth 1 u) v) + (math-poly-div-rec (nth 2 u) v) + nil (eq (car u) '-)) + (math-div u v)))) + ((Math-equal u v) math-poly-modulus) + ((and (math-atomic-factorp u) (math-atomic-factorp v)) + (math-simplify (math-div u v))) + (math-poly-div-base + (math-div u v)) + (t + (let ((base (math-poly-div-base u v)) + vp up res) + (if (or (null base) + (null (setq vp (math-is-polynomial v base nil 'gen)))) + (math-div u v) + (setq up (math-is-polynomial u base nil 'gen) + res (math-poly-div-coefs up vp)) + (math-add (math-build-polynomial-expr (car res) base) + (math-div (math-build-polynomial-expr (cdr res) base) + v)))))) +) + +;;; Divide two polynomials in coefficient-list form. Return (quot . rem). +(defun math-poly-div-coefs (u v) + (cond ((null v) (math-reject-arg nil "Division by zero")) + ((< (length u) (length v)) (cons nil u)) + ((cdr u) + (let ((q nil) + (urev (reverse u)) + (vrev (reverse v))) + (while + (let ((qk (math-poly-div-rec (math-simplify (car urev)) + (car vrev))) + (up urev) + (vp vrev)) + (if (or q (not (math-zerop qk))) + (setq q (cons qk q))) + (while (setq up (cdr up) vp (cdr vp)) + (setcar up (math-sub (car up) (math-mul-thru qk (car vp))))) + (setq urev (cdr urev)) + up)) + (while (and urev (Math-zerop (car urev))) + (setq urev (cdr urev))) + (cons q (nreverse (mapcar 'math-simplify urev))))) + (t + (cons (list (math-poly-div-rec (car u) (car v))) + nil))) +) + +;;; Perform a pseudo-division of polynomials. (See Knuth section 4.6.1.) +;;; This returns only the remainder from the pseudo-division. +(defun math-poly-pseudo-div (u v) + (cond ((null v) nil) + ((< (length u) (length v)) u) + ((or (cdr u) (cdr v)) + (let ((urev (reverse u)) + (vrev (reverse v)) + up) + (while + (let ((vp vrev)) + (setq up urev) + (while (setq up (cdr up) vp (cdr vp)) + (setcar up (math-sub (math-mul-thru (car vrev) (car up)) + (math-mul-thru (car urev) (car vp))))) + (setq urev (cdr urev)) + up) + (while up + (setcar up (math-mul-thru (car vrev) (car up))) + (setq up (cdr up)))) + (while (and urev (Math-zerop (car urev))) + (setq urev (cdr urev))) + (nreverse (mapcar 'math-simplify urev)))) + (t nil)) +) + +;;; Compute the GCD of two multivariate polynomials. +(defun math-poly-gcd (u v) + (cond ((Math-equal u v) u) + ((math-constp u) + (if (Math-zerop u) + v + (calcFunc-gcd u (calcFunc-pcont v)))) + ((math-constp v) + (if (Math-zerop v) + v + (calcFunc-gcd v (calcFunc-pcont u)))) + (t + (let ((base (math-poly-gcd-base u v))) + (if base + (math-simplify + (calcFunc-expand + (math-build-polynomial-expr + (math-poly-gcd-coefs (math-is-polynomial u base nil 'gen) + (math-is-polynomial v base nil 'gen)) + base))) + (calcFunc-gcd (calcFunc-pcont u) (calcFunc-pcont u)))))) +) + +(defun math-poly-div-list (lst a) + (if (eq a 1) + lst + (if (eq a -1) + (math-mul-list lst a) + (mapcar (function (lambda (x) (math-poly-div-exact x a))) lst))) +) + +(defun math-mul-list (lst a) + (if (eq a 1) + lst + (if (eq a -1) + (mapcar 'math-neg lst) + (and (not (eq a 0)) + (mapcar (function (lambda (x) (math-mul x a))) lst)))) +) + +;;; Run GCD on all elements in a list. +(defun math-poly-gcd-list (lst) + (if (or (memq 1 lst) (memq -1 lst)) + (math-poly-gcd-frac-list lst) + (let ((gcd (car lst))) + (while (and (setq lst (cdr lst)) (not (eq gcd 1))) + (or (eq (car lst) 0) + (setq gcd (math-poly-gcd gcd (car lst))))) + (if lst (setq lst (math-poly-gcd-frac-list lst))) + gcd)) +) + +(defun math-poly-gcd-frac-list (lst) + (while (and lst (not (eq (car-safe (car lst)) 'frac))) + (setq lst (cdr lst))) + (if lst + (let ((denom (nth 2 (car lst)))) + (while (setq lst (cdr lst)) + (if (eq (car-safe (car lst)) 'frac) + (setq denom (calcFunc-lcm denom (nth 2 (car lst)))))) + (list 'frac 1 denom)) + 1) +) + +;;; Compute the GCD of two monovariate polynomial lists. +;;; Knuth section 4.6.1, algorithm C. +(defun math-poly-gcd-coefs (u v) + (let ((d (math-poly-gcd (math-poly-gcd-list u) + (math-poly-gcd-list v))) + (g 1) (h 1) (z 0) hh r delta ghd) + (while (and u v (Math-zerop (car u)) (Math-zerop (car v))) + (setq u (cdr u) v (cdr v) z (1+ z))) + (or (eq d 1) + (setq u (math-poly-div-list u d) + v (math-poly-div-list v d))) + (while (progn + (setq delta (- (length u) (length v))) + (if (< delta 0) + (setq r u u v v r delta (- delta))) + (setq r (math-poly-pseudo-div u v)) + (cdr r)) + (setq u v + v (math-poly-div-list r (math-mul g (math-pow h delta))) + g (nth (1- (length u)) u) + h (if (<= delta 1) + (math-mul (math-pow g delta) (math-pow h (- 1 delta))) + (math-poly-div-exact (math-pow g delta) + (math-pow h (1- delta)))))) + (setq v (if r + (list d) + (math-mul-list (math-poly-div-list v (math-poly-gcd-list v)) d))) + (if (math-guess-if-neg (nth (1- (length v)) v)) + (setq v (math-mul-list v -1))) + (while (>= (setq z (1- z)) 0) + (setq v (cons 0 v))) + v) +) + + +;;; Return true if is a factor containing no sums or quotients. +(defun math-atomic-factorp (expr) + (cond ((eq (car-safe expr) '*) + (and (math-atomic-factorp (nth 1 expr)) + (math-atomic-factorp (nth 2 expr)))) + ((memq (car-safe expr) '(+ - /)) + nil) + ((memq (car-safe expr) '(^ neg)) + (math-atomic-factorp (nth 1 expr))) + (t t)) +) + +;;; Find a suitable base for dividing a by b. +;;; The base must exist in both expressions. +;;; The degree in the numerator must be higher or equal than the +;;; degree in the denominator. +;;; If the above conditions are not met the quotient is just a remainder. +;;; Return nil if this is the case. + +(defun math-poly-div-base (a b) + (let (a-base b-base) + (and (setq a-base (math-total-polynomial-base a)) + (setq b-base (math-total-polynomial-base b)) + (catch 'return + (while a-base + (let ((maybe (assoc (car (car a-base)) b-base))) + (if maybe + (if (>= (nth 1 (car a-base)) (nth 1 maybe)) + (throw 'return (car (car a-base)))))) + (setq a-base (cdr a-base)))))) +) + +;;; Same as above but for gcd algorithm. +;;; Here there is no requirement that degree(a) > degree(b). +;;; Take the base that has the highest degree considering both a and b. +;;; ("a^20+b^21+x^3+a+b", "a+b^2+x^5+a^22+b^10") --> (a 22) + +(defun math-poly-gcd-base (a b) + (let (a-base b-base) + (and (setq a-base (math-total-polynomial-base a)) + (setq b-base (math-total-polynomial-base b)) + (catch 'return + (while (and a-base b-base) + (if (> (nth 1 (car a-base)) (nth 1 (car b-base))) + (if (assoc (car (car a-base)) b-base) + (throw 'return (car (car a-base))) + (setq a-base (cdr a-base))) + (if (assoc (car (car b-base)) a-base) + (throw 'return (car (car b-base))) + (setq b-base (cdr b-base)))))))) +) + +;;; Sort a list of polynomial bases. +(defun math-sort-poly-base-list (lst) + (sort lst (function (lambda (a b) + (or (> (nth 1 a) (nth 1 b)) + (and (= (nth 1 a) (nth 1 b)) + (math-beforep (car a) (car b))))))) +) + +;;; Given an expression find all variables that are polynomial bases. +;;; Return list in the form '( (var1 degree1) (var2 degree2) ... ). +;;; Note dynamic scope of mpb-total-base. +(defun math-total-polynomial-base (expr) + (let ((mpb-total-base nil)) + (math-polynomial-base expr 'math-polynomial-p1) + (math-sort-poly-base-list mpb-total-base)) +) + +(defun math-polynomial-p1 (subexpr) + (or (assoc subexpr mpb-total-base) + (memq (car subexpr) '(+ - * / neg)) + (and (eq (car subexpr) '^) (natnump (nth 2 subexpr))) + (let* ((math-poly-base-variable subexpr) + (exponent (math-polynomial-p mpb-top-expr subexpr))) + (if exponent + (setq mpb-total-base (cons (list subexpr exponent) + mpb-total-base))))) + nil +) + + + + +(defun calcFunc-factors (expr &optional var) + (let ((math-factored-vars (if var t nil)) + (math-to-list t) + (calc-prefer-frac t)) + (or var + (setq var (math-polynomial-base expr))) + (let ((res (math-factor-finish + (or (catch 'factor (math-factor-expr-try var)) + expr)))) + (math-simplify (if (math-vectorp res) + res + (list 'vec (list 'vec res 1)))))) +) + +(defun calcFunc-factor (expr &optional var) + (let ((math-factored-vars nil) + (math-to-list nil) + (calc-prefer-frac t)) + (math-simplify (math-factor-finish + (if var + (let ((math-factored-vars t)) + (or (catch 'factor (math-factor-expr-try var)) expr)) + (math-factor-expr expr))))) +) + +(defun math-factor-finish (x) + (if (Math-primp x) + x + (if (eq (car x) 'calcFunc-Fac-Prot) + (math-factor-finish (nth 1 x)) + (cons (car x) (mapcar 'math-factor-finish (cdr x))))) +) + +(defun math-factor-protect (x) + (if (memq (car-safe x) '(+ -)) + (list 'calcFunc-Fac-Prot x) + x) +) + +(defun math-factor-expr (expr) + (cond ((eq math-factored-vars t) expr) + ((or (memq (car-safe expr) '(* / ^ neg)) + (assq (car-safe expr) calc-tweak-eqn-table)) + (cons (car expr) (mapcar 'math-factor-expr (cdr expr)))) + ((memq (car-safe expr) '(+ -)) + (let* ((math-factored-vars math-factored-vars) + (y (catch 'factor (math-factor-expr-part expr)))) + (if y + (math-factor-expr y) + expr))) + (t expr)) +) + +(defun math-factor-expr-part (x) ; uses "expr" + (if (memq (car-safe x) '(+ - * / ^ neg)) + (while (setq x (cdr x)) + (math-factor-expr-part (car x))) + (and (not (Math-objvecp x)) + (not (assoc x math-factored-vars)) + (> (math-factor-contains expr x) 1) + (setq math-factored-vars (cons (list x) math-factored-vars)) + (math-factor-expr-try x))) +) + +(defun math-factor-expr-try (x) + (if (eq (car-safe expr) '*) + (let ((res1 (catch 'factor (let ((expr (nth 1 expr))) + (math-factor-expr-try x)))) + (res2 (catch 'factor (let ((expr (nth 2 expr))) + (math-factor-expr-try x))))) + (and (or res1 res2) + (throw 'factor (math-accum-factors (or res1 (nth 1 expr)) 1 + (or res2 (nth 2 expr)))))) + (let* ((p (math-is-polynomial expr x 30 'gen)) + (math-poly-modulus (math-poly-modulus expr)) + res) + (and (cdr p) + (setq res (math-factor-poly-coefs p)) + (throw 'factor res)))) +) + +(defun math-accum-factors (fac pow facs) + (if math-to-list + (if (math-vectorp fac) + (progn + (while (setq fac (cdr fac)) + (setq facs (math-accum-factors (nth 1 (car fac)) + (* pow (nth 2 (car fac))) + facs))) + facs) + (if (and (eq (car-safe fac) '^) (natnump (nth 2 fac))) + (setq pow (* pow (nth 2 fac)) + fac (nth 1 fac))) + (if (eq fac 1) + facs + (or (math-vectorp facs) + (setq facs (if (eq facs 1) '(vec) + (list 'vec (list 'vec facs 1))))) + (let ((found facs)) + (while (and (setq found (cdr found)) + (not (equal fac (nth 1 (car found)))))) + (if found + (progn + (setcar (cdr (cdr (car found))) (+ pow (nth 2 (car found)))) + facs) + ;; Put constant term first. + (if (and (cdr facs) (Math-ratp (nth 1 (nth 1 facs)))) + (cons 'vec (cons (nth 1 facs) (cons (list 'vec fac pow) + (cdr (cdr facs))))) + (cons 'vec (cons (list 'vec fac pow) (cdr facs)))))))) + (math-mul (math-pow fac pow) facs)) +) + +(defun math-factor-poly-coefs (p &optional square-free) ; uses "x" + (let (t1 t2) + (cond ((not (cdr p)) + (or (car p) 0)) + + ;; Strip off multiples of x. + ((Math-zerop (car p)) + (let ((z 0)) + (while (and p (Math-zerop (car p))) + (setq z (1+ z) p (cdr p))) + (if (cdr p) + (setq p (math-factor-poly-coefs p square-free)) + (setq p (math-sort-terms (math-factor-expr (car p))))) + (math-accum-factors x z (math-factor-protect p)))) + + ;; Factor out content. + ((and (not square-free) + (not (eq 1 (setq t1 (math-mul (math-poly-gcd-list p) + (if (math-guess-if-neg + (nth (1- (length p)) p)) + -1 1)))))) + (math-accum-factors t1 1 (math-factor-poly-coefs + (math-poly-div-list p t1) 'cont))) + + ;; Check if linear in x. + ((not (cdr (cdr p))) + (math-add (math-factor-protect + (math-sort-terms + (math-factor-expr (car p)))) + (math-mul x (math-factor-protect + (math-sort-terms + (math-factor-expr (nth 1 p))))))) + + ;; If symbolic coefficients, use FactorRules. + ((let ((pp p)) + (while (and pp (or (Math-ratp (car pp)) + (and (eq (car (car pp)) 'mod) + (Math-integerp (nth 1 (car pp))) + (Math-integerp (nth 2 (car pp)))))) + (setq pp (cdr pp))) + pp) + (let ((res (math-rewrite + (list 'calcFunc-thecoefs x (cons 'vec p)) + '(var FactorRules var-FactorRules)))) + (or (and (eq (car-safe res) 'calcFunc-thefactors) + (= (length res) 3) + (math-vectorp (nth 2 res)) + (let ((facs 1) + (vec (nth 2 res))) + (while (setq vec (cdr vec)) + (setq facs (math-accum-factors (car vec) 1 facs))) + facs)) + (math-build-polynomial-expr p x)))) + + ;; Check if rational coefficients (i.e., not modulo a prime). + ((eq math-poly-modulus 1) + + ;; Check if there are any squared terms, or a content not = 1. + (if (or (eq square-free t) + (equal (setq t1 (math-poly-gcd-coefs + p (setq t2 (math-poly-deriv-coefs p)))) + '(1))) + + ;; We now have a square-free polynomial with integer coefs. + ;; For now, we use a kludgey method that finds linear and + ;; quadratic terms using floating-point root-finding. + (if (setq t1 (let ((calc-symbolic-mode nil)) + (math-poly-all-roots nil p t))) + (let ((roots (car t1)) + (csign (if (math-negp (nth (1- (length p)) p)) -1 1)) + (expr 1) + (unfac (nth 1 t1)) + (scale (nth 2 t1))) + (while roots + (let ((coef0 (car (car roots))) + (coef1 (cdr (car roots)))) + (setq expr (math-accum-factors + (if coef1 + (let ((den (math-lcm-denoms + coef0 coef1))) + (setq scale (math-div scale den)) + (math-add + (math-add + (math-mul den (math-pow x 2)) + (math-mul (math-mul coef1 den) x)) + (math-mul coef0 den))) + (let ((den (math-lcm-denoms coef0))) + (setq scale (math-div scale den)) + (math-add (math-mul den x) + (math-mul coef0 den)))) + 1 expr) + roots (cdr roots)))) + (setq expr (math-accum-factors + expr 1 + (math-mul csign + (math-build-polynomial-expr + (math-mul-list (nth 1 t1) scale) + x))))) + (math-build-polynomial-expr p x)) ; can't factor it. + + ;; Separate out the squared terms (Knuth exercise 4.6.2-34). + ;; This step also divides out the content of the polynomial. + (let* ((cabs (math-poly-gcd-list p)) + (csign (if (math-negp (nth (1- (length p)) p)) -1 1)) + (t1s (math-mul-list t1 csign)) + (uu nil) + (v (car (math-poly-div-coefs p t1s))) + (w (car (math-poly-div-coefs t2 t1s)))) + (while + (not (math-poly-zerop + (setq t2 (math-poly-simplify + (math-poly-mix + w 1 (math-poly-deriv-coefs v) -1))))) + (setq t1 (math-poly-gcd-coefs v t2) + uu (cons t1 uu) + v (car (math-poly-div-coefs v t1)) + w (car (math-poly-div-coefs t2 t1)))) + (setq t1 (length uu) + t2 (math-accum-factors (math-factor-poly-coefs v t) + (1+ t1) 1)) + (while uu + (setq t2 (math-accum-factors (math-factor-poly-coefs + (car uu) t) + t1 t2) + t1 (1- t1) + uu (cdr uu))) + (math-accum-factors (math-mul cabs csign) 1 t2)))) + + ;; Factoring modulo a prime. + ((and (= (length (setq temp (math-poly-gcd-coefs + p (math-poly-deriv-coefs p)))) + (length p))) + (setq p (car temp)) + (while (cdr temp) + (setq temp (nthcdr (nth 2 math-poly-modulus) temp) + p (cons (car temp) p))) + (and (setq temp (math-factor-poly-coefs p)) + (math-pow temp (nth 2 math-poly-modulus)))) + (t + (math-reject-arg nil "*Modulo factorization not yet implemented")))) +) + +(defun math-poly-deriv-coefs (p) + (let ((n 1) + (dp nil)) + (while (setq p (cdr p)) + (setq dp (cons (math-mul (car p) n) dp) + n (1+ n))) + (nreverse dp)) +) + +(defun math-factor-contains (x a) + (if (equal x a) + 1 + (if (memq (car-safe x) '(+ - * / neg)) + (let ((sum 0)) + (while (setq x (cdr x)) + (setq sum (+ sum (math-factor-contains (car x) a)))) + sum) + (if (and (eq (car-safe x) '^) + (natnump (nth 2 x))) + (* (math-factor-contains (nth 1 x) a) (nth 2 x)) + 0))) +) + + + + + +;;; Merge all quotients and expand/simplify the numerator +(defun calcFunc-nrat (expr) + (if (math-any-floats expr) + (setq expr (calcFunc-pfrac expr))) + (if (or (math-vectorp expr) + (assq (car-safe expr) calc-tweak-eqn-table)) + (cons (car expr) (mapcar 'calcFunc-nrat (cdr expr))) + (let* ((calc-prefer-frac t) + (res (math-to-ratpoly expr)) + (num (math-simplify (math-sort-terms (calcFunc-expand (car res))))) + (den (math-simplify (math-sort-terms (calcFunc-expand (cdr res))))) + (g (math-poly-gcd num den))) + (or (eq g 1) + (let ((num2 (math-poly-div num g)) + (den2 (math-poly-div den g))) + (and (eq (cdr num2) 0) (eq (cdr den2) 0) + (setq num (car num2) den (car den2))))) + (math-simplify (math-div num den)))) +) + +;;; Returns expressions (num . denom). +(defun math-to-ratpoly (expr) + (let ((res (math-to-ratpoly-rec expr))) + (cons (math-simplify (car res)) (math-simplify (cdr res)))) +) + +(defun math-to-ratpoly-rec (expr) + (cond ((Math-primp expr) + (cons expr 1)) + ((memq (car expr) '(+ -)) + (let ((r1 (math-to-ratpoly-rec (nth 1 expr))) + (r2 (math-to-ratpoly-rec (nth 2 expr)))) + (if (equal (cdr r1) (cdr r2)) + (cons (list (car expr) (car r1) (car r2)) (cdr r1)) + (if (eq (cdr r1) 1) + (cons (list (car expr) + (math-mul (car r1) (cdr r2)) + (car r2)) + (cdr r2)) + (if (eq (cdr r2) 1) + (cons (list (car expr) + (car r1) + (math-mul (car r2) (cdr r1))) + (cdr r1)) + (let ((g (math-poly-gcd (cdr r1) (cdr r2)))) + (let ((d1 (and (not (eq g 1)) (math-poly-div (cdr r1) g))) + (d2 (and (not (eq g 1)) (math-poly-div + (math-mul (car r1) (cdr r2)) + g)))) + (if (and (eq (cdr d1) 0) (eq (cdr d2) 0)) + (cons (list (car expr) (car d2) + (math-mul (car r2) (car d1))) + (math-mul (car d1) (cdr r2))) + (cons (list (car expr) + (math-mul (car r1) (cdr r2)) + (math-mul (car r2) (cdr r1))) + (math-mul (cdr r1) (cdr r2))))))))))) + ((eq (car expr) '*) + (let* ((r1 (math-to-ratpoly-rec (nth 1 expr))) + (r2 (math-to-ratpoly-rec (nth 2 expr))) + (g (math-mul (math-poly-gcd (car r1) (cdr r2)) + (math-poly-gcd (cdr r1) (car r2))))) + (if (eq g 1) + (cons (math-mul (car r1) (car r2)) + (math-mul (cdr r1) (cdr r2))) + (cons (math-poly-div-exact (math-mul (car r1) (car r2)) g) + (math-poly-div-exact (math-mul (cdr r1) (cdr r2)) g))))) + ((eq (car expr) '/) + (let* ((r1 (math-to-ratpoly-rec (nth 1 expr))) + (r2 (math-to-ratpoly-rec (nth 2 expr)))) + (if (and (eq (cdr r1) 1) (eq (cdr r2) 1)) + (cons (car r1) (car r2)) + (let ((g (math-mul (math-poly-gcd (car r1) (car r2)) + (math-poly-gcd (cdr r1) (cdr r2))))) + (if (eq g 1) + (cons (math-mul (car r1) (cdr r2)) + (math-mul (cdr r1) (car r2))) + (cons (math-poly-div-exact (math-mul (car r1) (cdr r2)) g) + (math-poly-div-exact (math-mul (cdr r1) (car r2)) + g))))))) + ((and (eq (car expr) '^) (integerp (nth 2 expr))) + (let ((r1 (math-to-ratpoly-rec (nth 1 expr)))) + (if (> (nth 2 expr) 0) + (cons (math-pow (car r1) (nth 2 expr)) + (math-pow (cdr r1) (nth 2 expr))) + (cons (math-pow (cdr r1) (- (nth 2 expr))) + (math-pow (car r1) (- (nth 2 expr))))))) + ((eq (car expr) 'neg) + (let ((r1 (math-to-ratpoly-rec (nth 1 expr)))) + (cons (math-neg (car r1)) (cdr r1)))) + (t (cons expr 1))) +) + + +(defun math-ratpoly-p (expr &optional var) + (cond ((equal expr var) 1) + ((Math-primp expr) 0) + ((memq (car expr) '(+ -)) + (let ((p1 (math-ratpoly-p (nth 1 expr) var)) + p2) + (and p1 (setq p2 (math-ratpoly-p (nth 2 expr) var)) + (max p1 p2)))) + ((eq (car expr) '*) + (let ((p1 (math-ratpoly-p (nth 1 expr) var)) + p2) + (and p1 (setq p2 (math-ratpoly-p (nth 2 expr) var)) + (+ p1 p2)))) + ((eq (car expr) 'neg) + (math-ratpoly-p (nth 1 expr) var)) + ((eq (car expr) '/) + (let ((p1 (math-ratpoly-p (nth 1 expr) var)) + p2) + (and p1 (setq p2 (math-ratpoly-p (nth 2 expr) var)) + (- p1 p2)))) + ((and (eq (car expr) '^) + (integerp (nth 2 expr))) + (let ((p1 (math-ratpoly-p (nth 1 expr) var))) + (and p1 (* p1 (nth 2 expr))))) + ((not var) 1) + ((math-poly-depends expr var) nil) + (t 0)) +) + + +(defun calcFunc-apart (expr &optional var) + (cond ((Math-primp expr) expr) + ((eq (car expr) '+) + (math-add (calcFunc-apart (nth 1 expr) var) + (calcFunc-apart (nth 2 expr) var))) + ((eq (car expr) '-) + (math-sub (calcFunc-apart (nth 1 expr) var) + (calcFunc-apart (nth 2 expr) var))) + ((not (math-ratpoly-p expr var)) + (math-reject-arg expr "Expected a rational function")) + (t + (let* ((calc-prefer-frac t) + (rat (math-to-ratpoly expr)) + (num (car rat)) + (den (cdr rat)) + (qr (math-poly-div num den)) + (q (car qr)) + (r (cdr qr))) + (or var + (setq var (math-polynomial-base den))) + (math-add q (or (and var + (math-expr-contains den var) + (math-partial-fractions r den var)) + (math-div r den)))))) +) + + +(defun math-padded-polynomial (expr var deg) + (let ((p (math-is-polynomial expr var deg))) + (append p (make-list (- deg (length p)) 0))) +) + +(defun math-partial-fractions (r den var) + (let* ((fden (calcFunc-factors den var)) + (tdeg (math-polynomial-p den var)) + (fp fden) + (dlist nil) + (eqns 0) + (lz nil) + (tz (make-list (1- tdeg) 0)) + (calc-matrix-mode 'scalar)) + (and (not (and (= (length fden) 2) (eq (nth 2 (nth 1 fden)) 1))) + (progn + (while (setq fp (cdr fp)) + (let ((rpt (nth 2 (car fp))) + (deg (math-polynomial-p (nth 1 (car fp)) var)) + dnum dvar deg2) + (while (> rpt 0) + (setq deg2 deg + dnum 0) + (while (> deg2 0) + (setq dvar (append '(vec) lz '(1) tz) + lz (cons 0 lz) + tz (cdr tz) + deg2 (1- deg2) + dnum (math-add dnum (math-mul dvar + (math-pow var deg2))) + dlist (cons (and (= deg2 (1- deg)) + (math-pow (nth 1 (car fp)) rpt)) + dlist))) + (let ((fpp fden) + (mult 1)) + (while (setq fpp (cdr fpp)) + (or (eq fpp fp) + (setq mult (math-mul mult + (math-pow (nth 1 (car fpp)) + (nth 2 (car fpp))))))) + (setq dnum (math-mul dnum mult))) + (setq eqns (math-add eqns (math-mul dnum + (math-pow + (nth 1 (car fp)) + (- (nth 2 (car fp)) + rpt)))) + rpt (1- rpt))))) + (setq eqns (math-div (cons 'vec (math-padded-polynomial r var tdeg)) + (math-transpose + (cons 'vec + (mapcar + (function + (lambda (x) + (cons 'vec (math-padded-polynomial + x var tdeg)))) + (cdr eqns)))))) + (and (math-vectorp eqns) + (let ((res 0) + (num nil)) + (setq eqns (nreverse eqns)) + (while eqns + (setq num (cons (car eqns) num) + eqns (cdr eqns)) + (if (car dlist) + (setq num (math-build-polynomial-expr + (nreverse num) var) + res (math-add res (math-div num (car dlist))) + num nil)) + (setq dlist (cdr dlist))) + (math-normalize res)))))) +) + + + +(defun math-expand-term (expr) + (cond ((and (eq (car-safe expr) '*) + (memq (car-safe (nth 1 expr)) '(+ -))) + (math-add-or-sub (list '* (nth 1 (nth 1 expr)) (nth 2 expr)) + (list '* (nth 2 (nth 1 expr)) (nth 2 expr)) + nil (eq (car (nth 1 expr)) '-))) + ((and (eq (car-safe expr) '*) + (memq (car-safe (nth 2 expr)) '(+ -))) + (math-add-or-sub (list '* (nth 1 expr) (nth 1 (nth 2 expr))) + (list '* (nth 1 expr) (nth 2 (nth 2 expr))) + nil (eq (car (nth 2 expr)) '-))) + ((and (eq (car-safe expr) '/) + (memq (car-safe (nth 1 expr)) '(+ -))) + (math-add-or-sub (list '/ (nth 1 (nth 1 expr)) (nth 2 expr)) + (list '/ (nth 2 (nth 1 expr)) (nth 2 expr)) + nil (eq (car (nth 1 expr)) '-))) + ((and (eq (car-safe expr) '^) + (memq (car-safe (nth 1 expr)) '(+ -)) + (integerp (nth 2 expr)) + (if (> (nth 2 expr) 0) + (or (and (or (> mmt-many 500000) (< mmt-many -500000)) + (math-expand-power (nth 1 expr) (nth 2 expr) + nil t)) + (list '* + (nth 1 expr) + (list '^ (nth 1 expr) (1- (nth 2 expr))))) + (if (< (nth 2 expr) 0) + (list '/ 1 (list '^ (nth 1 expr) (- (nth 2 expr)))))))) + (t expr)) +) + +(defun calcFunc-expand (expr &optional many) + (math-normalize (math-map-tree 'math-expand-term expr many)) +) + +(defun math-expand-power (x n &optional var else-nil) + (or (and (natnump n) + (memq (car-safe x) '(+ -)) + (let ((terms nil) + (cterms nil)) + (while (memq (car-safe x) '(+ -)) + (setq terms (cons (if (eq (car x) '-) + (math-neg (nth 2 x)) + (nth 2 x)) + terms) + x (nth 1 x))) + (setq terms (cons x terms)) + (if var + (let ((p terms)) + (while p + (or (math-expr-contains (car p) var) + (setq terms (delq (car p) terms) + cterms (cons (car p) cterms))) + (setq p (cdr p))) + (if cterms + (setq terms (cons (apply 'calcFunc-add cterms) + terms))))) + (if (= (length terms) 2) + (let ((i 0) + (accum 0)) + (while (<= i n) + (setq accum (list '+ accum + (list '* (calcFunc-choose n i) + (list '* + (list '^ (nth 1 terms) i) + (list '^ (car terms) + (- n i))))) + i (1+ i))) + accum) + (if (= n 2) + (let ((accum 0) + (p1 terms) + p2) + (while p1 + (setq accum (list '+ accum + (list '^ (car p1) 2)) + p2 p1) + (while (setq p2 (cdr p2)) + (setq accum (list '+ accum + (list '* 2 (list '* + (car p1) + (car p2)))))) + (setq p1 (cdr p1))) + accum) + (if (= n 3) + (let ((accum 0) + (p1 terms) + p2 p3) + (while p1 + (setq accum (list '+ accum (list '^ (car p1) 3)) + p2 p1) + (while (setq p2 (cdr p2)) + (setq accum (list '+ + (list '+ + accum + (list '* 3 + (list + '* + (list '^ (car p1) 2) + (car p2)))) + (list '* 3 + (list + '* (car p1) + (list '^ (car p2) 2)))) + p3 p2) + (while (setq p3 (cdr p3)) + (setq accum (list '+ accum + (list '* 6 + (list '* + (car p1) + (list + '* (car p2) + (car p3)))))))) + (setq p1 (cdr p1))) + accum)))))) + (and (not else-nil) + (list '^ x n))) +) + +(defun calcFunc-expandpow (x n) + (math-normalize (math-expand-power x n)) +) + + + diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el new file mode 100644 index 0000000000..c6cce329b5 --- /dev/null +++ b/lisp/calc/calc-prog.el @@ -0,0 +1,2364 @@ +;; Calculator for GNU Emacs, part II [calc-prog.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-prog () nil) + + +(defun calc-equal-to (arg) + (interactive "P") + (calc-wrapper + (if (and (integerp arg) (> arg 2)) + (calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg))) + (calc-binary-op "eq" 'calcFunc-eq arg))) +) + +(defun calc-remove-equal (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "rmeq" 'calcFunc-rmeq arg)) +) + +(defun calc-not-equal-to (arg) + (interactive "P") + (calc-wrapper + (if (and (integerp arg) (> arg 2)) + (calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg))) + (calc-binary-op "neq" 'calcFunc-neq arg))) +) + +(defun calc-less-than (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "lt" 'calcFunc-lt arg)) +) + +(defun calc-greater-than (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "gt" 'calcFunc-gt arg)) +) + +(defun calc-less-equal (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "leq" 'calcFunc-leq arg)) +) + +(defun calc-greater-equal (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "geq" 'calcFunc-geq arg)) +) + +(defun calc-in-set (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "in" 'calcFunc-in arg)) +) + +(defun calc-logical-and (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "land" 'calcFunc-land arg 1)) +) + +(defun calc-logical-or (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "lor" 'calcFunc-lor arg 0)) +) + +(defun calc-logical-not (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "lnot" 'calcFunc-lnot arg)) +) + +(defun calc-logical-if () + (interactive) + (calc-wrapper + (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3)))) +) + + + + + +(defun calc-timing (n) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-timing n nil t) + (message (if calc-timing + "Reporting timing of slow commands in Trail." + "Not reporting timing of commands."))) +) + +(defun calc-pass-errors () + (interactive) + ;; The following two cases are for the new, optimizing byte compiler + ;; or the standard 18.57 byte compiler, respectively. + (condition-case err + (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15))) + (or (memq (car-safe (car-safe place)) '(error xxxerror)) + (setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27))) + (or (memq (car (car place)) '(error xxxerror)) + (error "foo")) + (setcar (car place) 'xxxerror)) + (error (error "The calc-do function has been modified; unable to patch."))) +) + +(defun calc-user-define () + (interactive) + (message "Define user key: z-") + (let ((key (read-char))) + (if (= (calc-user-function-classify key) 0) + (error "Can't redefine \"?\" key")) + (let ((func (intern (completing-read (concat "Set key z " + (char-to-string key) + " to command: ") + obarray + 'commandp + t + "calc-")))) + (let* ((kmap (calc-user-key-map)) + (old (assq key kmap))) + (if old + (setcdr old func) + (setcdr kmap (cons (cons key func) (cdr kmap))))))) +) + +(defun calc-user-undefine () + (interactive) + (message "Undefine user key: z-") + (let ((key (read-char))) + (if (= (calc-user-function-classify key) 0) + (error "Can't undefine \"?\" key")) + (let* ((kmap (calc-user-key-map))) + (delq (or (assq key kmap) + (assq (upcase key) kmap) + (assq (downcase key) kmap) + (error "No such user key is defined")) + kmap))) +) + +(defun calc-user-define-formula () + (interactive) + (calc-wrapper + (let* ((form (calc-top 1)) + (arglist nil) + (is-lambda (and (eq (car-safe form) 'calcFunc-lambda) + (>= (length form) 2))) + odef key keyname cmd cmd-base func alist is-symb) + (if is-lambda + (setq arglist (mapcar (function (lambda (x) (nth 1 x))) + (nreverse (cdr (reverse (cdr form))))) + form (nth (1- (length form)) form)) + (calc-default-formula-arglist form) + (setq arglist (sort arglist 'string-lessp))) + (message "Define user key: z-") + (setq key (read-char)) + (if (= (calc-user-function-classify key) 0) + (error "Can't redefine \"?\" key")) + (setq key (and (not (memq key '(13 32))) key) + keyname (and key + (if (or (and (<= ?0 key) (<= key ?9)) + (and (<= ?a key) (<= key ?z)) + (and (<= ?A key) (<= key ?Z))) + (char-to-string key) + (format "%03d" key))) + odef (assq key (calc-user-key-map))) + (while + (progn + (setq cmd (completing-read "Define M-x command name: " + obarray 'commandp nil + (if (and odef (symbolp (cdr odef))) + (symbol-name (cdr odef)) + "calc-")) + cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd) + (math-match-substring cmd 1)) + cmd (and (not (or (string-equal cmd "") + (string-equal cmd "calc-"))) + (intern cmd))) + (and cmd + (fboundp cmd) + odef + (not + (y-or-n-p + (if (get cmd 'calc-user-defn) + (concat "Replace previous definition for " + (symbol-name cmd) "? ") + "That name conflicts with a built-in Emacs function. Replace this function? ")))))) + (if (and key (not cmd)) + (setq cmd (intern (concat "calc-User-" keyname)))) + (while + (progn + (setq func (completing-read "Define algebraic function name: " + obarray 'fboundp nil + (concat "calcFunc-" + (if cmd-base + (if (string-match + "\\`User-.+" cmd-base) + (concat + "User" + (substring cmd-base 5)) + cmd-base) + ""))) + func (and (not (or (string-equal func "") + (string-equal func "calcFunc-"))) + (intern func))) + (and func + (fboundp func) + (not (fboundp cmd)) + odef + (not + (y-or-n-p + (if (get func 'calc-user-defn) + (concat "Replace previous definition for " + (symbol-name func) "? ") + "That name conflicts with a built-in Emacs function. Replace this function? ")))))) + (if (not func) + (setq func (intern (concat "calcFunc-User" + (or keyname + (and cmd (symbol-name cmd)) + (format "%05d" (% (random) 10000))))))) + (if is-lambda + (setq alist arglist) + (while + (progn + (setq alist (read-from-minibuffer "Function argument list: " + (if arglist + (prin1-to-string arglist) + "()") + minibuffer-local-map + t)) + (and (not (calc-subsetp alist arglist)) + (not (y-or-n-p + "Okay for arguments that don't appear in formula to be ignored? ")))))) + (setq is-symb (and alist + func + (y-or-n-p + "Leave it symbolic for non-constant arguments? "))) + (setq alist (mapcar (function (lambda (x) + (or (cdr (assq x '((nil . arg-nil) + (t . arg-t)))) + x))) alist)) + (if cmd + (progn + (calc-need-macros) + (fset cmd + (list 'lambda + '() + '(interactive) + (list 'calc-wrapper + (list 'calc-enter-result + (length alist) + (let ((name (symbol-name (or func cmd)))) + (and (string-match + "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'" + name) + (math-match-substring name 1))) + (list 'cons + (list 'quote func) + (list 'calc-top-list-n + (length alist))))))) + (put cmd 'calc-user-defn t))) + (let ((body (list 'math-normalize (calc-fix-user-formula form)))) + (fset func + (append + (list 'lambda alist) + (and is-symb + (mapcar (function (lambda (v) + (list 'math-check-const v t))) + alist)) + (list body)))) + (put func 'calc-user-defn form) + (setq math-integral-cache-state nil) + (if key + (let* ((kmap (calc-user-key-map)) + (old (assq key kmap))) + (if old + (setcdr old cmd) + (setcdr kmap (cons (cons key cmd) (cdr kmap))))))) + (message "")) +) + +(defun calc-default-formula-arglist (form) + (if (consp form) + (if (eq (car form) 'var) + (if (or (memq (nth 1 form) arglist) + (math-const-var form)) + () + (setq arglist (cons (nth 1 form) arglist))) + (calc-default-formula-arglist-step (cdr form)))) +) + +(defun calc-default-formula-arglist-step (l) + (and l + (progn + (calc-default-formula-arglist (car l)) + (calc-default-formula-arglist-step (cdr l)))) +) + +(defun calc-subsetp (a b) + (or (null a) + (and (memq (car a) b) + (calc-subsetp (cdr a) b))) +) + +(defun calc-fix-user-formula (f) + (if (consp f) + (let (temp) + (cond ((and (eq (car f) 'var) + (memq (setq temp (or (cdr (assq (nth 1 f) '((nil . arg-nil) + (t . arg-t)))) + (nth 1 f))) + alist)) + temp) + ((or (math-constp f) (eq (car f) 'var)) + (list 'quote f)) + ((and (eq (car f) 'calcFunc-eval) + (= (length f) 2)) + (list 'let '((calc-simplify-mode nil)) + (list 'math-normalize (calc-fix-user-formula (nth 1 f))))) + ((and (eq (car f) 'calcFunc-evalsimp) + (= (length f) 2)) + (list 'math-simplify (calc-fix-user-formula (nth 1 f)))) + ((and (eq (car f) 'calcFunc-evalextsimp) + (= (length f) 2)) + (list 'math-simplify-extended + (calc-fix-user-formula (nth 1 f)))) + (t + (cons 'list + (cons (list 'quote (car f)) + (mapcar 'calc-fix-user-formula (cdr f))))))) + f) +) + +(defun calc-user-define-composition () + (interactive) + (calc-wrapper + (if (eq calc-language 'unform) + (error "Can't define formats for unformatted mode")) + (let* ((comp (calc-top 1)) + (func (intern (completing-read "Define format for which function: " + obarray 'fboundp nil "calcFunc-"))) + (comps (get func 'math-compose-forms)) + entry entry2 + (arglist nil) + (alist nil)) + (if (math-zerop comp) + (if (setq entry (assq calc-language comps)) + (put func 'math-compose-forms (delq entry comps))) + (calc-default-formula-arglist comp) + (setq arglist (sort arglist 'string-lessp)) + (while + (progn + (setq alist (read-from-minibuffer "Composition argument list: " + (if arglist + (prin1-to-string arglist) + "()") + minibuffer-local-map + t)) + (and (not (calc-subsetp alist arglist)) + (y-or-n-p + "Okay for arguments that don't appear in formula to be invisible? ")))) + (or (setq entry (assq calc-language comps)) + (put func 'math-compose-forms + (cons (setq entry (list calc-language)) comps))) + (or (setq entry2 (assq (length alist) (cdr entry))) + (setcdr entry + (cons (setq entry2 (list (length alist))) (cdr entry)))) + (setcdr entry2 (list 'lambda alist (calc-fix-user-formula comp)))) + (calc-pop-stack 1) + (calc-do-refresh))) +) + + +(defun calc-user-define-kbd-macro (arg) + (interactive "P") + (or last-kbd-macro + (error "No keyboard macro defined")) + (message "Define last kbd macro on user key: z-") + (let ((key (read-char))) + (if (= (calc-user-function-classify key) 0) + (error "Can't redefine \"?\" key")) + (let ((cmd (intern (completing-read "Full name for new command: " + obarray + 'commandp + nil + (concat "calc-User-" + (if (or (and (>= key ?a) + (<= key ?z)) + (and (>= key ?A) + (<= key ?Z)) + (and (>= key ?0) + (<= key ?9))) + (char-to-string key) + (format "%03d" key))))))) + (and (fboundp cmd) + (not (let ((f (symbol-function cmd))) + (or (stringp f) + (and (consp f) + (eq (car-safe (nth 3 f)) + 'calc-execute-kbd-macro))))) + (error "Function %s is already defined and not a keyboard macro" + cmd)) + (put cmd 'calc-user-defn t) + (fset cmd (if (< (prefix-numeric-value arg) 0) + last-kbd-macro + (list 'lambda + '(arg) + '(interactive "P") + (list 'calc-execute-kbd-macro + (vector (key-description last-kbd-macro) + last-kbd-macro) + 'arg + (format "z%c" key))))) + (let* ((kmap (calc-user-key-map)) + (old (assq key kmap))) + (if old + (setcdr old cmd) + (setcdr kmap (cons (cons key cmd) (cdr kmap))))))) +) + + +(defun calc-edit-user-syntax () + (interactive) + (calc-wrapper + (let ((lang calc-language)) + (calc-edit-mode (list 'calc-finish-user-syntax-edit (list 'quote lang)) + t + (format "Editing %s-Mode Syntax Table" + (cond ((null lang) "Normal") + ((eq lang 'tex) "TeX") + (t (capitalize (symbol-name lang)))))) + (calc-write-parse-table (cdr (assq lang calc-user-parse-tables)) + lang))) + (calc-show-edit-buffer) +) + +(defun calc-finish-user-syntax-edit (lang) + (let ((tab (calc-read-parse-table calc-original-buffer lang)) + (entry (assq lang calc-user-parse-tables))) + (if tab + (setcdr (or entry + (car (setq calc-user-parse-tables + (cons (list lang) calc-user-parse-tables)))) + tab) + (if entry + (setq calc-user-parse-tables + (delq entry calc-user-parse-tables))))) + (switch-to-buffer calc-original-buffer) +) + +(defun calc-write-parse-table (tab calc-lang) + (let ((p tab)) + (while p + (calc-write-parse-table-part (car (car p))) + (insert ":= " + (let ((math-format-hash-args t)) + (math-format-flat-expr (cdr (car p)) 0)) + "\n") + (setq p (cdr p)))) +) + +(defun calc-write-parse-table-part (p) + (while p + (cond ((stringp (car p)) + (let ((s (car p))) + (if (and (string-match "\\`\\\\dots\\>" s) + (not (eq calc-lang 'tex))) + (setq s (concat ".." (substring s 5)))) + (if (or (and (string-match + "[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s) + (string-match "[^a-zA-Z0-9\\]" s)) + (and (assoc s '((")") ("]") (">"))) + (not (cdr p)))) + (insert (prin1-to-string s) " ") + (insert s " ")))) + ((integerp (car p)) + (insert "#") + (or (= (car p) 0) + (insert "/" (int-to-string (car p)))) + (insert " ")) + ((and (eq (car (car p)) '\?) (equal (car (nth 2 (car p))) "$$")) + (insert (car (nth 1 (car p))) " ")) + (t + (insert "{ ") + (calc-write-parse-table-part (nth 1 (car p))) + (insert "}" (symbol-name (car (car p)))) + (if (nth 2 (car p)) + (calc-write-parse-table-part (list (car (nth 2 (car p))))) + (insert " ")))) + (setq p (cdr p))) +) + +(defun calc-read-parse-table (calc-buf calc-lang) + (let ((tab nil)) + (while (progn + (skip-chars-forward "\n\t ") + (not (eobp))) + (if (looking-at "%%") + (end-of-line) + (let ((pt (point)) + (p (calc-read-parse-table-part ":=[\n\t ]+" ":="))) + (or (stringp (car p)) + (and (integerp (car p)) + (stringp (nth 1 p))) + (progn + (goto-char pt) + (error "Malformed syntax rule"))) + (let ((pos (point))) + (end-of-line) + (let* ((str (buffer-substring pos (point))) + (exp (save-excursion + (set-buffer calc-buf) + (let ((calc-user-parse-tables nil) + (calc-language nil) + (math-expr-opers math-standard-opers) + (calc-hashes-used 0)) + (math-read-expr + (if (string-match ",[ \t]*\\'" str) + (substring str 0 (match-beginning 0)) + str)))))) + (if (eq (car-safe exp) 'error) + (progn + (goto-char (+ pos (nth 1 exp))) + (error (nth 2 exp)))) + (setq tab (nconc tab (list (cons p exp))))))))) + tab) +) + +(defun calc-fix-token-name (name &optional unquoted) + (cond ((string-match "\\`\\.\\." name) + (concat "\\dots" (substring name 2))) + ((and (equal name "{") (memq calc-lang '(tex eqn))) + "(") + ((and (equal name "}") (memq calc-lang '(tex eqn))) + ")") + ((and (equal name "&") (eq calc-lang 'tex)) + ",") + ((equal name "#") + (search-backward "#") + (error "Token '#' is reserved")) + ((and unquoted (string-match "#" name)) + (error "Tokens containing '#' must be quoted")) + ((not (string-match "[^ ]" name)) + (search-backward "\"" nil t) + (error "Blank tokens are not allowed")) + (t name)) +) + +(defun calc-read-parse-table-part (term eterm) + (let ((part nil) + (quoted nil)) + (while (progn + (skip-chars-forward "\n\t ") + (if (eobp) (error "Expected '%s'" eterm)) + (not (looking-at term))) + (cond ((looking-at "%%") + (end-of-line)) + ((looking-at "{[\n\t ]") + (forward-char 2) + (let ((p (calc-read-parse-table-part "}" "}"))) + (or (looking-at "[+*?]") + (error "Expected '+', '*', or '?'")) + (let ((sym (intern (buffer-substring (point) (1+ (point)))))) + (forward-char 1) + (looking-at "[^\n\t ]*") + (let ((sep (buffer-substring (point) (match-end 0)))) + (goto-char (match-end 0)) + (and (eq sym '\?) (> (length sep) 0) + (not (equal sep "$")) (not (equal sep ".")) + (error "Separator not allowed with { ... }?")) + (if (string-match "\\`\"" sep) + (setq sep (read-from-string sep))) + (setq sep (calc-fix-token-name sep)) + (setq part (nconc part + (list (list sym p + (and (> (length sep) 0) + (cons sep p)))))))))) + ((looking-at "}") + (error "Too many }'s")) + ((looking-at "\"") + (setq quoted (calc-fix-token-name (read (current-buffer))) + part (nconc part (list quoted)))) + ((looking-at "#\\(\\(/[0-9]+\\)?\\)[\n\t ]") + (setq part (nconc part (list (if (= (match-beginning 1) + (match-end 1)) + 0 + (string-to-int + (buffer-substring + (1+ (match-beginning 1)) + (match-end 1))))))) + (goto-char (match-end 0))) + ((looking-at ":=[\n\t ]") + (error "Misplaced ':='")) + (t + (looking-at "[^\n\t ]*") + (let ((end (match-end 0))) + (setq part (nconc part (list (calc-fix-token-name + (buffer-substring + (point) end) t)))) + (goto-char end))))) + (goto-char (match-end 0)) + (let ((len (length part))) + (while (and (> len 1) + (let ((last (nthcdr (setq len (1- len)) part))) + (and (assoc (car last) '((")") ("]") (">"))) + (not (eq (car last) quoted)) + (setcar last + (list '\? (list (car last)) '("$$")))))))) + part) +) + + +(defun calc-user-define-invocation () + (interactive) + (or last-kbd-macro + (error "No keyboard macro defined")) + (setq calc-invocation-macro last-kbd-macro) + (message "Use `M-# Z' to invoke this macro") +) + + +(defun calc-user-define-edit (prefix) + (interactive "P") ; but no calc-wrapper! + (message "Edit definition of command: z-") + (let* ((key (read-char)) + (def (or (assq key (calc-user-key-map)) + (assq (upcase key) (calc-user-key-map)) + (assq (downcase key) (calc-user-key-map)) + (error "No command defined for that key"))) + (cmd (cdr def))) + (if (symbolp cmd) + (setq cmd (symbol-function cmd))) + (cond ((or (stringp cmd) + (and (consp cmd) + (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro))) + (if (and (>= (prefix-numeric-value prefix) 0) + (fboundp 'edit-kbd-macro) + (symbolp (cdr def)) + (eq major-mode 'calc-mode)) + (progn + (if (and (< (window-width) (screen-width)) + calc-display-trail) + (let ((win (get-buffer-window (calc-trail-buffer)))) + (if win + (delete-window win)))) + (edit-kbd-macro (cdr def) prefix nil + (function + (lambda (x) + (and calc-display-trail + (calc-wrapper + (calc-trail-display 1 t))))) + (function + (lambda (cmd) + (if (stringp (symbol-function cmd)) + (symbol-function cmd) + (let ((mac (nth 1 (nth 3 (symbol-function + cmd))))) + (if (vectorp mac) + (aref mac 1) + mac))))) + (function + (lambda (new cmd) + (if (stringp (symbol-function cmd)) + (fset cmd new) + (let ((mac (cdr (nth 3 (symbol-function + cmd))))) + (if (vectorp (car mac)) + (progn + (aset (car mac) 0 + (key-description new)) + (aset (car mac) 1 new)) + (setcar mac new)))))))) + (let ((keys (progn (and (fboundp 'edit-kbd-macro) + (edit-kbd-macro nil)) + (fboundp 'MacEdit-parse-keys)))) + (calc-wrapper + (calc-edit-mode (list 'calc-finish-macro-edit + (list 'quote def) + keys) + t) + (if keys + (let (top + (fill-column 70) + (fill-prefix nil)) + (insert "Notations: RET, SPC, TAB, DEL, LFD, NUL" + ", C-xxx, M-xxx.\n\n") + (setq top (point)) + (insert (if (stringp cmd) + (key-description cmd) + (if (vectorp (nth 1 (nth 3 cmd))) + (aref (nth 1 (nth 3 cmd)) 0) + (key-description (nth 1 (nth 3 cmd))))) + "\n") + (if (>= (prog2 (forward-char -1) + (current-column) + (forward-char 1)) + (screen-width)) + (fill-region top (point)))) + (insert "Press C-q to quote control characters like RET" + " and TAB.\n" + (if (stringp cmd) + cmd + (if (vectorp (nth 1 (nth 3 cmd))) + (aref (nth 1 (nth 3 cmd)) 1) + (nth 1 (nth 3 cmd))))))) + (calc-show-edit-buffer) + (forward-line (if keys 2 1))))) + (t (let* ((func (calc-stack-command-p cmd)) + (defn (and func + (symbolp func) + (get func 'calc-user-defn)))) + (if (and defn (calc-valid-formula-func func)) + (progn + (calc-wrapper + (calc-edit-mode (list 'calc-finish-formula-edit + (list 'quote func))) + (insert (math-showing-full-precision + (math-format-nice-expr defn (screen-width))) + "\n")) + (calc-show-edit-buffer)) + (error "That command's definition cannot be edited")))))) +) + +(defun calc-finish-macro-edit (def keys) + (forward-line 1) + (if (and keys (looking-at "\n")) (forward-line 1)) + (let* ((true-str (buffer-substring (point) (point-max))) + (str true-str)) + (if keys (setq str (MacEdit-parse-keys str))) + (if (symbolp (cdr def)) + (if (stringp (symbol-function (cdr def))) + (fset (cdr def) str) + (let ((mac (cdr (nth 3 (symbol-function (cdr def)))))) + (if (vectorp (car mac)) + (progn + (aset (car mac) 0 (if keys true-str (key-description str))) + (aset (car mac) 1 str)) + (setcar mac str)))) + (setcdr def str))) +) + +;;; The following are hooks into the MacEdit package from macedit.el. +(put 'calc-execute-extended-command 'MacEdit-print + (function (lambda () + (setq macro-str (concat "\excalc-" macro-str)))) +) + +(put 'calcDigit-start 'MacEdit-print + (function (lambda () + (if calc-algebraic-mode + (calc-macro-edit-algebraic) + (MacEdit-unread-chars key-last) + (let ((str "") + (min-bsp 0) + ch last) + (while (and (setq ch (MacEdit-read-char)) + (or (and (>= ch ?0) (<= ch ?9)) + (memq ch '(?\. ?e ?\_ ?n ?\: ?\# ?M + ?o ?h ?\@ ?\")) + (and (memq ch '(?\' ?m ?s)) + (string-match "[@oh]" str)) + (and (or (and (>= ch ?a) (<= ch ?z)) + (and (>= ch ?A) (<= ch ?Z))) + (string-match + "^[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#" + str)) + (and (memq ch '(?\177 ?\C-h)) + (> (length str) 0)) + (and (memq ch '(?+ ?-)) + (> (length str) 0) + (eq (aref str (1- (length str))) + ?e)))) + (if (or (and (>= ch ?0) (<= ch ?9)) + (and (or (not (memq ch '(?\177 ?\C-h))) + (<= (length str) min-bsp)) + (setq min-bsp (1+ (length str))))) + (setq str (concat str (char-to-string ch))) + (setq str (substring str 0 -1)))) + (if (memq ch '(32 10 13)) + (setq str (concat str (char-to-string ch))) + (MacEdit-unread-chars ch)) + (insert "type \"") + (MacEdit-insert-string str) + (insert "\"\n"))))) +) + +(defun calc-macro-edit-algebraic () + (MacEdit-unread-chars key-last) + (let ((str "") + (min-bsp 0)) + (while (progn + (MacEdit-lookup-key calc-alg-ent-map) + (or (and (memq key-symbol '(self-insert-command + calcAlg-previous)) + (< (length str) 60)) + (memq key-symbol + '(backward-delete-char + delete-backward-char + backward-delete-char-untabify)) + (eq key-last 9))) + (setq macro-str (substring macro-str (length key-str))) + (if (or (eq key-symbol 'self-insert-command) + (and (or (not (memq key-symbol '(backward-delete-char + delete-backward-char + backward-delete-char-untabify))) + (<= (length str) min-bsp)) + (setq min-bsp (+ (length str) (length key-str))))) + (setq str (concat str key-str)) + (setq str (substring str 0 -1)))) + (if (memq key-last '(10 13)) + (setq str (concat str key-str) + macro-str (substring macro-str (length key-str)))) + (if (> (length str) 0) + (progn + (insert "type \"") + (MacEdit-insert-string str) + (insert "\"\n")))) +) +(put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic) +(put 'calc-auto-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic) + +(defun calc-macro-edit-variable (&optional no-cmd) + (let ((str "") ch) + (or no-cmd (insert (symbol-name key-symbol) "\n")) + (if (memq (MacEdit-peek-char) '(?\+ ?\- ?\* ?\/ ?\^ ?\|)) + (setq str (char-to-string (MacEdit-read-char)))) + (if (and (setq ch (MacEdit-peek-char)) + (>= ch ?0) (<= ch ?9)) + (insert "type \"" str + (char-to-string (MacEdit-read-char)) "\"\n") + (if (> (length str) 0) + (insert "type \"" str "\"\n")) + (MacEdit-read-argument))) +) +(put 'calc-store 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-into 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-neg 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-plus 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-minus 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-times 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-div 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-power 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-concat 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-inv 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-decr 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-incr 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-store-exchange 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-unstore 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-recall 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-let 'MacEdit-print 'calc-macro-edit-variable) +(put 'calc-permanent-variable 'MacEdit-print 'calc-macro-edit-variable) + +(defun calc-macro-edit-variable-2 () + (calc-macro-edit-variable) + (calc-macro-edit-variable t) +) +(put 'calc-copy-variable 'MacEdit-print 'calc-macro-edit-variable-2) +(put 'calc-declare-variable 'MacEdit-print 'calc-macro-edit-variable-2) + +(defun calc-macro-edit-quick-digit () + (insert "type \"" key-str "\" # " (symbol-name key-symbol) "\n") +) +(put 'calc-store-quick 'MacEdit-print 'calc-macro-edit-quick-digit) +(put 'calc-store-into-quick 'MacEdit-print 'calc-macro-edit-quick-digit) +(put 'calc-recall-quick 'MacEdit-print 'calc-macro-edit-quick-digit) +(put 'calc-select-part 'MacEdit-print 'calc-macro-edit-quick-digit) +(put 'calc-clean-num 'MacEdit-print 'calc-macro-edit-quick-digit) + + +(defun calc-finish-formula-edit (func) + (let ((buf (current-buffer)) + (str (buffer-substring (point) (point-max))) + (start (point)) + (body (calc-valid-formula-func func))) + (set-buffer calc-original-buffer) + (let ((val (math-read-expr str))) + (if (eq (car-safe val) 'error) + (progn + (set-buffer buf) + (goto-char (+ start (nth 1 val))) + (error (nth 2 val)))) + (setcar (cdr body) + (let ((alist (nth 1 (symbol-function func)))) + (calc-fix-user-formula val))) + (put func 'calc-user-defn val))) +) + +(defun calc-valid-formula-func (func) + (let ((def (symbol-function func))) + (and (consp def) + (eq (car def) 'lambda) + (progn + (setq def (cdr (cdr def))) + (while (and def + (not (eq (car (car def)) 'math-normalize))) + (setq def (cdr def))) + (car def)))) +) + + +(defun calc-get-user-defn () + (interactive) + (calc-wrapper + (message "Get definition of command: z-") + (let* ((key (read-char)) + (def (or (assq key (calc-user-key-map)) + (assq (upcase key) (calc-user-key-map)) + (assq (downcase key) (calc-user-key-map)) + (error "No command defined for that key"))) + (cmd (cdr def))) + (if (symbolp cmd) + (setq cmd (symbol-function cmd))) + (cond ((stringp cmd) + (message "Keyboard macro: %s" cmd)) + (t (let* ((func (calc-stack-command-p cmd)) + (defn (and func + (symbolp func) + (get func 'calc-user-defn)))) + (if defn + (progn + (and (calc-valid-formula-func func) + (setq defn (append '(calcFunc-lambda) + (mapcar 'math-build-var-name + (nth 1 (symbol-function + func))) + (list defn)))) + (calc-enter-result 0 "gdef" defn)) + (error "That command is not defined by a formula"))))))) +) + + +(defun calc-user-define-permanent () + (interactive) + (calc-wrapper + (message "Record in %s the command: z-" calc-settings-file) + (let* ((key (read-char)) + (def (or (assq key (calc-user-key-map)) + (assq (upcase key) (calc-user-key-map)) + (assq (downcase key) (calc-user-key-map)) + (and (eq key ?\') + (cons nil + (intern (completing-read + (format "Record in %s the function: " + calc-settings-file) + obarray 'fboundp nil "calcFunc-")))) + (error "No command defined for that key")))) + (set-buffer (find-file-noselect (substitute-in-file-name + calc-settings-file))) + (goto-char (point-max)) + (let* ((cmd (cdr def)) + (fcmd (and cmd (symbolp cmd) (symbol-function cmd))) + (func nil) + (pt (point)) + (fill-column 70) + (fill-prefix nil) + str q-ok) + (insert "\n;;; Definition stored by Calc on " (current-time-string) + "\n(put 'calc-define '" + (if (symbolp cmd) (symbol-name cmd) (format "key%d" key)) + " '(progn\n") + (if (and fcmd + (eq (car-safe fcmd) 'lambda) + (get cmd 'calc-user-defn)) + (let ((pt (point))) + (and (eq (car-safe (nth 3 fcmd)) 'calc-execute-kbd-macro) + (vectorp (nth 1 (nth 3 fcmd))) + (progn (and (fboundp 'edit-kbd-macro) + (edit-kbd-macro nil)) + (fboundp 'MacEdit-parse-keys)) + (setq q-ok t) + (aset (nth 1 (nth 3 fcmd)) 1 nil)) + (insert (setq str (prin1-to-string + (cons 'defun (cons cmd (cdr fcmd))))) + "\n") + (or (and (string-match "\"" str) (not q-ok)) + (fill-region pt (point))) + (indent-rigidly pt (point) 2) + (delete-region pt (1+ pt)) + (insert " (put '" (symbol-name cmd) + " 'calc-user-defn '" + (prin1-to-string (get cmd 'calc-user-defn)) + ")\n") + (setq func (calc-stack-command-p cmd)) + (let ((ffunc (and func (symbolp func) (symbol-function func))) + (pt (point))) + (and ffunc + (eq (car-safe ffunc) 'lambda) + (get func 'calc-user-defn) + (progn + (insert (setq str (prin1-to-string + (cons 'defun (cons func + (cdr ffunc))))) + "\n") + (or (and (string-match "\"" str) (not q-ok)) + (fill-region pt (point))) + (indent-rigidly pt (point) 2) + (delete-region pt (1+ pt)) + (setq pt (point)) + (insert "(put '" (symbol-name func) + " 'calc-user-defn '" + (prin1-to-string (get func 'calc-user-defn)) + ")\n") + (fill-region pt (point)) + (indent-rigidly pt (point) 2) + (delete-region pt (1+ pt)))))) + (and (stringp fcmd) + (insert " (fset '" (prin1-to-string cmd) + " " (prin1-to-string fcmd) ")\n"))) + (or func (setq func (and cmd (symbolp cmd) (fboundp cmd) cmd))) + (if (get func 'math-compose-forms) + (let ((pt (point))) + (insert "(put '" (symbol-name cmd) + " 'math-compose-forms '" + (prin1-to-string (get func 'math-compose-forms)) + ")\n") + (fill-region pt (point)) + (indent-rigidly pt (point) 2) + (delete-region pt (1+ pt)))) + (if (car def) + (insert " (define-key calc-mode-map " + (prin1-to-string (concat "z" (char-to-string key))) + " '" + (prin1-to-string cmd) + ")\n"))) + (insert "))\n") + (save-buffer))) +) + +(defun calc-stack-command-p (cmd) + (if (and cmd (symbolp cmd)) + (and (fboundp cmd) + (calc-stack-command-p (symbol-function cmd))) + (and (consp cmd) + (eq (car cmd) 'lambda) + (setq cmd (or (assq 'calc-wrapper cmd) + (assq 'calc-slow-wrapper cmd))) + (setq cmd (assq 'calc-enter-result cmd)) + (memq (car (nth 3 cmd)) '(cons list)) + (eq (car (nth 1 (nth 3 cmd))) 'quote) + (nth 1 (nth 1 (nth 3 cmd))))) +) + + +(defun calc-call-last-kbd-macro (arg) + (interactive "P") + (and defining-kbd-macro + (error "Can't execute anonymous macro while defining one")) + (or last-kbd-macro + (error "No kbd macro has been defined")) + (calc-execute-kbd-macro last-kbd-macro arg) +) + +(defun calc-execute-kbd-macro (mac arg &rest prefix) + (if (and (vectorp mac) (> (length mac) 0) (stringp (aref mac 0))) + (setq mac (or (aref mac 1) + (aset mac 1 (progn (and (fboundp 'edit-kbd-macro) + (edit-kbd-macro nil)) + (MacEdit-parse-keys (aref mac 0))))))) + (if (< (prefix-numeric-value arg) 0) + (execute-kbd-macro mac (- (prefix-numeric-value arg))) + (if calc-executing-macro + (execute-kbd-macro mac arg) + (calc-slow-wrapper + (let ((old-stack-whole (copy-sequence calc-stack)) + (old-stack-top calc-stack-top) + (old-buffer-size (buffer-size)) + (old-refresh-count calc-refresh-count)) + (unwind-protect + (let ((calc-executing-macro mac)) + (execute-kbd-macro mac arg)) + (calc-select-buffer) + (let ((new-stack (reverse calc-stack)) + (old-stack (reverse old-stack-whole))) + (while (and new-stack old-stack + (equal (car new-stack) (car old-stack))) + (setq new-stack (cdr new-stack) + old-stack (cdr old-stack))) + (or (equal prefix '(nil)) + (calc-record-list (if (> (length new-stack) 1) + (mapcar 'car new-stack) + '("")) + (or (car prefix) "kmac"))) + (calc-record-undo (list 'set 'saved-stack-top old-stack-top)) + (and old-stack + (calc-record-undo (list 'pop 1 (mapcar 'car old-stack)))) + (let ((calc-stack old-stack-whole) + (calc-stack-top 0)) + (calc-cursor-stack-index (length old-stack))) + (if (and (= old-buffer-size (buffer-size)) + (= old-refresh-count calc-refresh-count)) + (let ((buffer-read-only nil)) + (delete-region (point) (point-max)) + (while new-stack + (calc-record-undo (list 'push 1)) + (insert (math-format-stack-value (car new-stack)) "\n") + (setq new-stack (cdr new-stack))) + (calc-renumber-stack)) + (while new-stack + (calc-record-undo (list 'push 1)) + (setq new-stack (cdr new-stack))) + (calc-refresh)) + (calc-record-undo (list 'set 'saved-stack-top 0)))))))) +) + +(defun calc-push-list-in-macro (vals m sels) + (let ((entry (list (car vals) 1 (car sels))) + (mm (+ (or m 1) calc-stack-top))) + (if (> mm 1) + (setcdr (nthcdr (- mm 2) calc-stack) + (cons entry (nthcdr (1- mm) calc-stack))) + (setq calc-stack (cons entry calc-stack)))) +) + +(defun calc-pop-stack-in-macro (n mm) + (if (> mm 1) + (setcdr (nthcdr (- mm 2) calc-stack) + (nthcdr (+ n mm -1) calc-stack)) + (setq calc-stack (nthcdr n calc-stack))) +) + + +(defun calc-kbd-if () + (interactive) + (calc-wrapper + (let ((cond (calc-top-n 1))) + (calc-pop-stack 1) + (if (math-is-true cond) + (if defining-kbd-macro + (message "If true...")) + (if defining-kbd-macro + (message "Condition is false; skipping to Z: or Z] ...")) + (calc-kbd-skip-to-else-if t)))) +) + +(defun calc-kbd-else-if () + (interactive) + (calc-kbd-if) +) + +(defun calc-kbd-skip-to-else-if (else-okay) + (let ((count 0) + ch) + (while (>= count 0) + (setq ch (read-char)) + (if (= ch -1) + (error "Unterminated Z[ in keyboard macro")) + (if (= ch ?Z) + (progn + (setq ch (read-char)) + (cond ((= ch ?\[) + (setq count (1+ count))) + ((= ch ?\]) + (setq count (1- count))) + ((= ch ?\:) + (and (= count 0) + else-okay + (setq count -1))) + ((eq ch 7) + (keyboard-quit)))))) + (and defining-kbd-macro + (if (= ch ?\:) + (message "Else...") + (message "End-if...")))) +) + +(defun calc-kbd-end-if () + (interactive) + (if defining-kbd-macro + (message "End-if...")) +) + +(defun calc-kbd-else () + (interactive) + (if defining-kbd-macro + (message "Else; skipping to Z] ...")) + (calc-kbd-skip-to-else-if nil) +) + + +(defun calc-kbd-repeat () + (interactive) + (let (count) + (calc-wrapper + (setq count (math-trunc (calc-top-n 1))) + (or (Math-integerp count) + (error "Count must be an integer")) + (if (Math-integer-negp count) + (setq count 0)) + (or (integerp count) + (setq count 1000000)) + (calc-pop-stack 1)) + (calc-kbd-loop count)) +) + +(defun calc-kbd-for (dir) + (interactive "P") + (let (init final) + (calc-wrapper + (setq init (calc-top-n 2) + final (calc-top-n 1)) + (or (and (math-anglep init) (math-anglep final)) + (error "Initial and final values must be real numbers")) + (calc-pop-stack 2)) + (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir)))) +) + +(defun calc-kbd-loop (rpt-count &optional initial final dir) + (interactive "P") + (setq rpt-count (if rpt-count (prefix-numeric-value rpt-count) 1000000)) + (let* ((count 0) + (parts nil) + (body "") + (open last-command-char) + (counter initial) + ch) + (or executing-macro + (message "Reading loop body...")) + (while (>= count 0) + (setq ch (read-char)) + (if (= ch -1) + (error "Unterminated Z%c in keyboard macro" open)) + (if (= ch ?Z) + (progn + (setq ch (read-char) + body (concat body "Z" (char-to-string ch))) + (cond ((memq ch '(?\< ?\( ?\{)) + (setq count (1+ count))) + ((memq ch '(?\> ?\) ?\})) + (setq count (1- count))) + ((and (= ch ?/) + (= count 0)) + (setq parts (nconc parts (list (concat (substring body 0 -2) + "Z]"))) + body "")) + ((eq ch 7) + (keyboard-quit)))) + (setq body (concat body (char-to-string ch))))) + (if (/= ch (cdr (assq open '( (?\< . ?\>) (?\( . ?\)) (?\{ . ?\}) )))) + (error "Mismatched Z%c and Z%c in keyboard macro" open ch)) + (or executing-macro + (message "Looping...")) + (setq body (concat (substring body 0 -2) "Z]")) + (and (not executing-macro) + (= rpt-count 1000000) + (null parts) + (null counter) + (progn + (message "Warning: Infinite loop! Not executing.") + (setq rpt-count 0))) + (or (not initial) dir + (setq dir (math-compare final initial))) + (calc-wrapper + (while (> rpt-count 0) + (let ((part parts)) + (if counter + (if (cond ((eq dir 0) (Math-equal final counter)) + ((eq dir 1) (Math-lessp final counter)) + ((eq dir -1) (Math-lessp counter final))) + (setq rpt-count 0) + (calc-push counter))) + (while (and part (> rpt-count 0)) + (execute-kbd-macro (car part)) + (if (math-is-true (calc-top-n 1)) + (setq rpt-count 0) + (setq part (cdr part))) + (calc-pop-stack 1)) + (if (> rpt-count 0) + (progn + (execute-kbd-macro body) + (if counter + (let ((step (calc-top-n 1))) + (calc-pop-stack 1) + (setq counter (calcFunc-add counter step))) + (setq rpt-count (1- rpt-count)))))))) + (or executing-macro + (message "Looping...done"))) +) + +(defun calc-kbd-end-repeat () + (interactive) + (error "Unbalanced Z> in keyboard macro") +) + +(defun calc-kbd-end-for () + (interactive) + (error "Unbalanced Z) in keyboard macro") +) + +(defun calc-kbd-end-loop () + (interactive) + (error "Unbalanced Z} in keyboard macro") +) + +(defun calc-kbd-break () + (interactive) + (calc-wrapper + (let ((cond (calc-top-n 1))) + (calc-pop-stack 1) + (if (math-is-true cond) + (error "Keyboard macro aborted.")))) +) + + +(defun calc-kbd-push (arg) + (interactive "P") + (calc-wrapper + (let* ((defs (and arg (> (prefix-numeric-value arg) 0))) + (var-q0 (and (boundp 'var-q0) var-q0)) + (var-q1 (and (boundp 'var-q1) var-q1)) + (var-q2 (and (boundp 'var-q2) var-q2)) + (var-q3 (and (boundp 'var-q3) var-q3)) + (var-q4 (and (boundp 'var-q4) var-q4)) + (var-q5 (and (boundp 'var-q5) var-q5)) + (var-q6 (and (boundp 'var-q6) var-q6)) + (var-q7 (and (boundp 'var-q7) var-q7)) + (var-q8 (and (boundp 'var-q8) var-q8)) + (var-q9 (and (boundp 'var-q9) var-q9)) + (calc-internal-prec (if defs 12 calc-internal-prec)) + (calc-word-size (if defs 32 calc-word-size)) + (calc-angle-mode (if defs 'deg calc-angle-mode)) + (calc-simplify-mode (if defs nil calc-simplify-mode)) + (calc-algebraic-mode (if arg nil calc-algebraic-mode)) + (calc-incomplete-algebraic-mode (if arg nil + calc-incomplete-algebraic-mode)) + (calc-symbolic-mode (if defs nil calc-symbolic-mode)) + (calc-matrix-mode (if defs nil calc-matrix-mode)) + (calc-prefer-frac (if defs nil calc-prefer-frac)) + (calc-complex-mode (if defs nil calc-complex-mode)) + (calc-infinite-mode (if defs nil calc-infinite-mode)) + (count 0) + (body "") + ch) + (if (or executing-macro defining-kbd-macro) + (progn + (if defining-kbd-macro + (message "Reading body...")) + (while (>= count 0) + (setq ch (read-char)) + (if (= ch -1) + (error "Unterminated Z` in keyboard macro")) + (if (= ch ?Z) + (progn + (setq ch (read-char) + body (concat body "Z" (char-to-string ch))) + (cond ((eq ch ?\`) + (setq count (1+ count))) + ((eq ch ?\') + (setq count (1- count))) + ((eq ch 7) + (keyboard-quit)))) + (setq body (concat body (char-to-string ch))))) + (if defining-kbd-macro + (message "Reading body...done")) + (let ((calc-kbd-push-level 0)) + (execute-kbd-macro (substring body 0 -2)))) + (let ((calc-kbd-push-level (1+ calc-kbd-push-level))) + (message "Saving modes; type Z' to restore") + (recursive-edit))))) +) +(setq calc-kbd-push-level 0) + +(defun calc-kbd-pop () + (interactive) + (if (> calc-kbd-push-level 0) + (progn + (message "Mode settings restored") + (exit-recursive-edit)) + (error "Unbalanced Z' in keyboard macro")) +) + + +(defun calc-kbd-report (msg) + (interactive "sMessage: ") + (calc-wrapper + (let ((executing-macro nil) + (defining-kbd-macro nil)) + (math-working msg (calc-top-n 1)))) +) + +(defun calc-kbd-query (msg) + (interactive "sPrompt: ") + (calc-wrapper + (let ((executing-macro nil) + (defining-kbd-macro nil)) + (calc-alg-entry nil (and (not (equal msg "")) msg)))) +) + + + + + + + +;;;; Logical operations. + +(defun calcFunc-eq (a b &rest more) + (if more + (let* ((args (cons a (cons b (copy-sequence more)))) + (res 1) + (p args) + p2) + (while (and (cdr p) (not (eq res 0))) + (setq p2 p) + (while (and (setq p2 (cdr p2)) (not (eq res 0))) + (setq res (math-two-eq (car p) (car p2))) + (if (eq res 1) + (setcdr p (delq (car p2) (cdr p))))) + (setq p (cdr p))) + (if (eq res 0) + 0 + (if (cdr args) + (cons 'calcFunc-eq args) + 1))) + (or (math-two-eq a b) + (if (and (or (math-looks-negp a) (math-zerop a)) + (or (math-looks-negp b) (math-zerop b))) + (list 'calcFunc-eq (math-neg a) (math-neg b)) + (list 'calcFunc-eq a b)))) +) + +(defun calcFunc-neq (a b &rest more) + (if more + (let* ((args (cons a (cons b more))) + (res 0) + (all t) + (p args) + p2) + (while (and (cdr p) (not (eq res 1))) + (setq p2 p) + (while (and (setq p2 (cdr p2)) (not (eq res 1))) + (setq res (math-two-eq (car p) (car p2))) + (or res (setq all nil))) + (setq p (cdr p))) + (if (eq res 1) + 0 + (if all + 1 + (cons 'calcFunc-neq args)))) + (or (cdr (assq (math-two-eq a b) '((0 . 1) (1 . 0)))) + (if (and (or (math-looks-negp a) (math-zerop a)) + (or (math-looks-negp b) (math-zerop b))) + (list 'calcFunc-neq (math-neg a) (math-neg b)) + (list 'calcFunc-neq a b)))) +) + +(defun math-two-eq (a b) + (if (eq (car-safe a) 'vec) + (if (eq (car-safe b) 'vec) + (if (= (length a) (length b)) + (let ((res 1)) + (while (and (setq a (cdr a) b (cdr b)) (not (eq res 0))) + (if res + (setq res (math-two-eq (car a) (car b))) + (if (eq (math-two-eq (car a) (car b)) 0) + (setq res 0)))) + res) + 0) + (if (Math-objectp b) + 0 + nil)) + (if (eq (car-safe b) 'vec) + (if (Math-objectp a) + 0 + nil) + (let ((res (math-compare a b))) + (if (= res 0) + 1 + (if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b)))) + nil + 0))))) +) + +(defun calcFunc-lt (a b) + (let ((res (math-compare a b))) + (if (= res -1) + 1 + (if (= res 2) + (if (and (or (math-looks-negp a) (math-zerop a)) + (or (math-looks-negp b) (math-zerop b))) + (list 'calcFunc-gt (math-neg a) (math-neg b)) + (list 'calcFunc-lt a b)) + 0))) +) + +(defun calcFunc-gt (a b) + (let ((res (math-compare a b))) + (if (= res 1) + 1 + (if (= res 2) + (if (and (or (math-looks-negp a) (math-zerop a)) + (or (math-looks-negp b) (math-zerop b))) + (list 'calcFunc-lt (math-neg a) (math-neg b)) + (list 'calcFunc-gt a b)) + 0))) +) + +(defun calcFunc-leq (a b) + (let ((res (math-compare a b))) + (if (= res 1) + 0 + (if (= res 2) + (if (and (or (math-looks-negp a) (math-zerop a)) + (or (math-looks-negp b) (math-zerop b))) + (list 'calcFunc-geq (math-neg a) (math-neg b)) + (list 'calcFunc-leq a b)) + 1))) +) + +(defun calcFunc-geq (a b) + (let ((res (math-compare a b))) + (if (= res -1) + 0 + (if (= res 2) + (if (and (or (math-looks-negp a) (math-zerop a)) + (or (math-looks-negp b) (math-zerop b))) + (list 'calcFunc-leq (math-neg a) (math-neg b)) + (list 'calcFunc-geq a b)) + 1))) +) + +(defun calcFunc-rmeq (a) + (if (math-vectorp a) + (math-map-vec 'calcFunc-rmeq a) + (if (assq (car-safe a) calc-tweak-eqn-table) + (if (and (eq (car-safe (nth 2 a)) 'var) + (math-objectp (nth 1 a))) + (nth 1 a) + (nth 2 a)) + (if (eq (car-safe a) 'calcFunc-assign) + (nth 2 a) + (if (eq (car-safe a) 'calcFunc-evalto) + (nth 1 a) + (list 'calcFunc-rmeq a))))) +) + +(defun calcFunc-land (a b) + (cond ((Math-zerop a) + a) + ((Math-zerop b) + b) + ((math-is-true a) + b) + ((math-is-true b) + a) + (t (list 'calcFunc-land a b))) +) + +(defun calcFunc-lor (a b) + (cond ((Math-zerop a) + b) + ((Math-zerop b) + a) + ((math-is-true a) + a) + ((math-is-true b) + b) + (t (list 'calcFunc-lor a b))) +) + +(defun calcFunc-lnot (a) + (if (Math-zerop a) + 1 + (if (math-is-true a) + 0 + (let ((op (and (= (length a) 3) + (assq (car a) calc-tweak-eqn-table)))) + (if op + (cons (nth 2 op) (cdr a)) + (list 'calcFunc-lnot a))))) +) + +(defun calcFunc-if (c e1 e2) + (if (Math-zerop c) + e2 + (if (and (math-is-true c) (not (Math-vectorp c))) + e1 + (or (and (Math-vectorp c) + (math-constp c) + (let ((ee1 (if (Math-vectorp e1) + (if (= (length c) (length e1)) + (cdr e1) + (calc-record-why "*Dimension error" e1)) + (list e1))) + (ee2 (if (Math-vectorp e2) + (if (= (length c) (length e2)) + (cdr e2) + (calc-record-why "*Dimension error" e2)) + (list e2)))) + (and ee1 ee2 + (cons 'vec (math-if-vector (cdr c) ee1 ee2))))) + (list 'calcFunc-if c e1 e2)))) +) + +(defun math-if-vector (c e1 e2) + (and c + (cons (if (Math-zerop (car c)) (car e2) (car e1)) + (math-if-vector (cdr c) + (or (cdr e1) e1) + (or (cdr e2) e2)))) +) + +(defun math-normalize-logical-op (a) + (or (and (eq (car a) 'calcFunc-if) + (= (length a) 4) + (let ((a1 (math-normalize (nth 1 a)))) + (if (Math-zerop a1) + (math-normalize (nth 3 a)) + (if (Math-numberp a1) + (math-normalize (nth 2 a)) + (if (and (Math-vectorp (nth 1 a)) + (math-constp (nth 1 a))) + (calcFunc-if (nth 1 a) + (math-normalize (nth 2 a)) + (math-normalize (nth 3 a))) + (let ((calc-simplify-mode 'none)) + (list 'calcFunc-if a1 + (math-normalize (nth 2 a)) + (math-normalize (nth 3 a))))))))) + a) +) + +(defun calcFunc-in (a b) + (or (and (eq (car-safe b) 'vec) + (let ((bb b)) + (while (and (setq bb (cdr bb)) + (not (if (memq (car-safe (car bb)) '(vec intv)) + (eq (calcFunc-in a (car bb)) 1) + (Math-equal a (car bb)))))) + (if bb 1 (and (math-constp a) (math-constp bb) 0)))) + (and (eq (car-safe b) 'intv) + (let ((res (math-compare a (nth 2 b))) res2) + (cond ((= res -1) + 0) + ((and (= res 0) + (or (/= (nth 1 b) 2) + (Math-lessp (nth 2 b) (nth 3 b)))) + (if (memq (nth 1 b) '(2 3)) 1 0)) + ((= (setq res2 (math-compare a (nth 3 b))) 1) + 0) + ((and (= res2 0) + (or (/= (nth 1 b) 1) + (Math-lessp (nth 2 b) (nth 3 b)))) + (if (memq (nth 1 b) '(1 3)) 1 0)) + ((/= res 1) + nil) + ((/= res2 -1) + nil) + (t 1)))) + (and (Math-equal a b) + 1) + (and (math-constp a) (math-constp b) + 0) + (list 'calcFunc-in a b)) +) + +(defun calcFunc-typeof (a) + (cond ((Math-integerp a) 1) + ((eq (car a) 'frac) 2) + ((eq (car a) 'float) 3) + ((eq (car a) 'hms) 4) + ((eq (car a) 'cplx) 5) + ((eq (car a) 'polar) 6) + ((eq (car a) 'sdev) 7) + ((eq (car a) 'intv) 8) + ((eq (car a) 'mod) 9) + ((eq (car a) 'date) (if (Math-integerp (nth 1 a)) 10 11)) + ((eq (car a) 'var) + (if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100)) + ((eq (car a) 'vec) (if (math-matrixp a) 102 101)) + (t (math-calcFunc-to-var func))) +) + +(defun calcFunc-integer (a) + (if (Math-integerp a) + 1 + (if (Math-objvecp a) + 0 + (list 'calcFunc-integer a))) +) + +(defun calcFunc-real (a) + (if (Math-realp a) + 1 + (if (Math-objvecp a) + 0 + (list 'calcFunc-real a))) +) + +(defun calcFunc-constant (a) + (if (math-constp a) + 1 + (if (Math-objvecp a) + 0 + (list 'calcFunc-constant a))) +) + +(defun calcFunc-refers (a b) + (if (math-expr-contains a b) + 1 + (if (eq (car-safe a) 'var) + (list 'calcFunc-refers a b) + 0)) +) + +(defun calcFunc-negative (a) + (if (math-looks-negp a) + 1 + (if (or (math-zerop a) + (math-posp a)) + 0 + (list 'calcFunc-negative a))) +) + +(defun calcFunc-variable (a) + (if (eq (car-safe a) 'var) + 1 + (if (Math-objvecp a) + 0 + (list 'calcFunc-variable a))) +) + +(defun calcFunc-nonvar (a) + (if (eq (car-safe a) 'var) + (list 'calcFunc-nonvar a) + 1) +) + +(defun calcFunc-istrue (a) + (if (math-is-true a) + 1 + 0) +) + + + + +;;;; User-programmability. + +;;; Compiling Lisp-like forms to use the math library. + +(defun math-do-defmath (func args body) + (calc-need-macros) + (let* ((fname (intern (concat "calcFunc-" (symbol-name func)))) + (doc (if (stringp (car body)) (list (car body)))) + (clargs (mapcar 'math-clean-arg args)) + (body (math-define-function-body + (if (stringp (car body)) (cdr body) body) + clargs))) + (list 'progn + (if (and (consp (car body)) + (eq (car (car body)) 'interactive)) + (let ((inter (car body))) + (setq body (cdr body)) + (if (or (> (length inter) 2) + (integerp (nth 1 inter))) + (let ((hasprefix nil) (hasmulti nil)) + (if (stringp (nth 1 inter)) + (progn + (cond ((equal (nth 1 inter) "p") + (setq hasprefix t)) + ((equal (nth 1 inter) "m") + (setq hasmulti t)) + (t (error + "Can't handle interactive code string \"%s\"" + (nth 1 inter)))) + (setq inter (cdr inter)))) + (if (not (integerp (nth 1 inter))) + (error + "Expected an integer in interactive specification")) + (append (list 'defun + (intern (concat "calc-" + (symbol-name func))) + (if (or hasprefix hasmulti) + '(&optional n) + ())) + doc + (if (or hasprefix hasmulti) + '((interactive "P")) + '((interactive))) + (list + (append + '(calc-slow-wrapper) + (and hasmulti + (list + (list 'setq + 'n + (list 'if + 'n + (list 'prefix-numeric-value + 'n) + (nth 1 inter))))) + (list + (list 'calc-enter-result + (if hasmulti 'n (nth 1 inter)) + (nth 2 inter) + (if hasprefix + (list 'append + (list 'quote (list fname)) + (list 'calc-top-list-n + (nth 1 inter)) + (list 'and + 'n + (list + 'list + (list + 'math-normalize + (list + 'prefix-numeric-value + 'n))))) + (list 'cons + (list 'quote fname) + (list 'calc-top-list-n + (if hasmulti + 'n + (nth 1 inter))))))))))) + (append (list 'defun + (intern (concat "calc-" (symbol-name func))) + args) + doc + (list + inter + (cons 'calc-wrapper body)))))) + (append (list 'defun fname clargs) + doc + (math-do-arg-list-check args nil nil) + body))) +) + +(defun math-clean-arg (arg) + (if (consp arg) + (math-clean-arg (nth 1 arg)) + arg) +) + +(defun math-do-arg-check (arg var is-opt is-rest) + (if is-opt + (let ((chk (math-do-arg-check arg var nil nil))) + (list (cons 'and + (cons var + (if (cdr chk) + (setq chk (list (cons 'progn chk))) + chk))))) + (and (consp arg) + (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest)) + (qual (car arg)) + (qqual (list 'quote qual)) + (qual-name (symbol-name qual)) + (chk (intern (concat "math-check-" qual-name)))) + (if (fboundp chk) + (append rest + (list + (if is-rest + (list 'setq var + (list 'mapcar (list 'quote chk) var)) + (list 'setq var (list chk var))))) + (if (fboundp (setq chk (intern (concat "math-" qual-name)))) + (append rest + (list + (if is-rest + (list 'mapcar + (list 'function + (list 'lambda '(x) + (list 'or + (list chk 'x) + (list 'math-reject-arg + 'x qqual)))) + var) + (list 'or + (list chk var) + (list 'math-reject-arg var qqual))))) + (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name) + (fboundp (setq chk (intern + (concat "math-" + (math-match-substring + qual-name 1)))))) + (append rest + (list + (if is-rest + (list 'mapcar + (list 'function + (list 'lambda '(x) + (list 'and + (list chk 'x) + (list 'math-reject-arg + 'x qqual)))) + var) + (list 'and + (list chk var) + (list 'math-reject-arg var qqual))))) + (error "Unknown qualifier `%s'" qual-name))))))) +) + +(defun math-do-arg-list-check (args is-opt is-rest) + (cond ((null args) nil) + ((consp (car args)) + (append (math-do-arg-check (car args) + (math-clean-arg (car args)) + is-opt is-rest) + (math-do-arg-list-check (cdr args) is-opt is-rest))) + ((eq (car args) '&optional) + (math-do-arg-list-check (cdr args) t nil)) + ((eq (car args) '&rest) + (math-do-arg-list-check (cdr args) nil t)) + (t (math-do-arg-list-check (cdr args) is-opt is-rest))) +) + +(defconst math-prim-funcs + '( (~= . math-nearly-equal) + (% . math-mod) + (lsh . calcFunc-lsh) + (ash . calcFunc-ash) + (logand . calcFunc-and) + (logandc2 . calcFunc-diff) + (logior . calcFunc-or) + (logxor . calcFunc-xor) + (lognot . calcFunc-not) + (equal . equal) ; need to leave these ones alone! + (eq . eq) + (and . and) + (or . or) + (if . if) + (^ . math-pow) + (expt . math-pow) + ) +) + +(defconst math-prim-vars + '( (nil . nil) + (t . t) + (&optional . &optional) + (&rest . &rest) + ) +) + +(defun math-define-function-body (body env) + (let ((body (math-define-body body env))) + (if (math-body-refers-to body 'math-return) + (list (cons 'catch (cons '(quote math-return) body))) + body)) +) + +(defun math-define-body (body exp-env) + (math-define-list body) +) + +(defun math-define-list (body &optional quote) + (cond ((null body) + nil) + ((and (eq (car body) ':) + (stringp (nth 1 body))) + (cons (let* ((math-read-expr-quotes t) + (exp (math-read-plain-expr (nth 1 body) t))) + (math-define-exp exp)) + (math-define-list (cdr (cdr body))))) + (quote + (cons (cond ((consp (car body)) + (math-define-list (cdr body) t)) + (t + (car body))) + (math-define-list (cdr body)))) + (t + (cons (math-define-exp (car body)) + (math-define-list (cdr body))))) +) + +(defun math-define-exp (exp) + (cond ((consp exp) + (let ((func (car exp))) + (cond ((memq func '(quote function)) + (if (and (consp (nth 1 exp)) + (eq (car (nth 1 exp)) 'lambda)) + (cons 'quote + (math-define-lambda (nth 1 exp) exp-env)) + exp)) + ((memq func '(let let* for foreach)) + (let ((head (nth 1 exp)) + (body (cdr (cdr exp)))) + (if (memq func '(let let*)) + () + (setq func (cdr (assq func '((for . math-for) + (foreach . math-foreach))))) + (if (not (listp (car head))) + (setq head (list head)))) + (macroexpand + (cons func + (cons (math-define-let head) + (math-define-body body + (nconc + (math-define-let-env head) + exp-env))))))) + ((and (memq func '(setq setf)) + (math-complicated-lhs (cdr exp))) + (if (> (length exp) 3) + (cons 'progn (math-define-setf-list (cdr exp))) + (math-define-setf (nth 1 exp) (nth 2 exp)))) + ((eq func 'condition-case) + (cons func + (cons (nth 1 exp) + (math-define-body (cdr (cdr exp)) + (cons (nth 1 exp) + exp-env))))) + ((eq func 'cond) + (cons func + (math-define-cond (cdr exp)))) + ((and (consp func) ; ('spam a b) == force use of plain spam + (eq (car func) 'quote)) + (cons func (math-define-list (cdr exp)))) + ((symbolp func) + (let ((args (math-define-list (cdr exp))) + (prim (assq func math-prim-funcs))) + (cond (prim + (cons (cdr prim) args)) + ((eq func 'floatp) + (list 'eq (car args) '(quote float))) + ((eq func '+) + (math-define-binop 'math-add 0 + (car args) (cdr args))) + ((eq func '-) + (if (= (length args) 1) + (cons 'math-neg args) + (math-define-binop 'math-sub 0 + (car args) (cdr args)))) + ((eq func '*) + (math-define-binop 'math-mul 1 + (car args) (cdr args))) + ((eq func '/) + (math-define-binop 'math-div 1 + (car args) (cdr args))) + ((eq func 'min) + (math-define-binop 'math-min 0 + (car args) (cdr args))) + ((eq func 'max) + (math-define-binop 'math-max 0 + (car args) (cdr args))) + ((eq func '<) + (if (and (math-numberp (nth 1 args)) + (math-zerop (nth 1 args))) + (list 'math-negp (car args)) + (cons 'math-lessp args))) + ((eq func '>) + (if (and (math-numberp (nth 1 args)) + (math-zerop (nth 1 args))) + (list 'math-posp (car args)) + (list 'math-lessp (nth 1 args) (nth 0 args)))) + ((eq func '<=) + (list 'not + (if (and (math-numberp (nth 1 args)) + (math-zerop (nth 1 args))) + (list 'math-posp (car args)) + (list 'math-lessp + (nth 1 args) (nth 0 args))))) + ((eq func '>=) + (list 'not + (if (and (math-numberp (nth 1 args)) + (math-zerop (nth 1 args))) + (list 'math-negp (car args)) + (cons 'math-lessp args)))) + ((eq func '=) + (if (and (math-numberp (nth 1 args)) + (math-zerop (nth 1 args))) + (list 'math-zerop (nth 0 args)) + (if (and (integerp (nth 1 args)) + (/= (% (nth 1 args) 10) 0)) + (cons 'math-equal-int args) + (cons 'math-equal args)))) + ((eq func '/=) + (list 'not + (if (and (math-numberp (nth 1 args)) + (math-zerop (nth 1 args))) + (list 'math-zerop (nth 0 args)) + (if (and (integerp (nth 1 args)) + (/= (% (nth 1 args) 10) 0)) + (cons 'math-equal-int args) + (cons 'math-equal args))))) + ((eq func '1+) + (list 'math-add (car args) 1)) + ((eq func '1-) + (list 'math-add (car args) -1)) + ((eq func 'not) ; optimize (not (not x)) => x + (if (eq (car-safe args) func) + (car (nth 1 args)) + (cons func args))) + ((and (eq func 'elt) (cdr (cdr args))) + (math-define-elt (car args) (cdr args))) + (t + (macroexpand + (let* ((name (symbol-name func)) + (cfunc (intern (concat "calcFunc-" name))) + (mfunc (intern (concat "math-" name)))) + (cond ((fboundp cfunc) + (cons cfunc args)) + ((fboundp mfunc) + (cons mfunc args)) + ((or (fboundp func) + (string-match "\\`calcFunc-.*" name)) + (cons func args)) + (t + (cons cfunc args))))))))) + (t (cons func args))))) + ((symbolp exp) + (let ((prim (assq exp math-prim-vars)) + (name (symbol-name exp))) + (cond (prim + (cdr prim)) + ((memq exp exp-env) + exp) + ((string-match "-" name) + exp) + (t + (intern (concat "var-" name)))))) + ((integerp exp) + (if (or (<= exp -1000000) (>= exp 1000000)) + (list 'quote (math-normalize exp)) + exp)) + (t exp)) +) + +(defun math-define-cond (forms) + (and forms + (cons (math-define-list (car forms)) + (math-define-cond (cdr forms)))) +) + +(defun math-complicated-lhs (body) + (and body + (or (not (symbolp (car body))) + (math-complicated-lhs (cdr (cdr body))))) +) + +(defun math-define-setf-list (body) + (and body + (cons (math-define-setf (nth 0 body) (nth 1 body)) + (math-define-setf-list (cdr (cdr body))))) +) + +(defun math-define-setf (place value) + (setq place (math-define-exp place) + value (math-define-exp value)) + (cond ((symbolp place) + (list 'setq place value)) + ((eq (car-safe place) 'nth) + (list 'setcar (list 'nthcdr (nth 1 place) (nth 2 place)) value)) + ((eq (car-safe place) 'elt) + (list 'setcar (list 'nthcdr (nth 2 place) (nth 1 place)) value)) + ((eq (car-safe place) 'car) + (list 'setcar (nth 1 place) value)) + ((eq (car-safe place) 'cdr) + (list 'setcdr (nth 1 place) value)) + (t + (error "Bad place form for setf: %s" place))) +) + +(defun math-define-binop (op ident arg1 rest) + (if rest + (math-define-binop op ident + (list op arg1 (car rest)) + (cdr rest)) + (or arg1 ident)) +) + +(defun math-define-let (vlist) + (and vlist + (cons (if (consp (car vlist)) + (cons (car (car vlist)) + (math-define-list (cdr (car vlist)))) + (car vlist)) + (math-define-let (cdr vlist)))) +) + +(defun math-define-let-env (vlist) + (and vlist + (cons (if (consp (car vlist)) + (car (car vlist)) + (car vlist)) + (math-define-let-env (cdr vlist)))) +) + +(defun math-define-lambda (exp exp-env) + (nconc (list (nth 0 exp) ; 'lambda + (nth 1 exp)) ; arg list + (math-define-function-body (cdr (cdr exp)) + (append (nth 1 exp) exp-env))) +) + +(defun math-define-elt (seq idx) + (if idx + (math-define-elt (list 'elt seq (car idx)) (cdr idx)) + seq) +) + + + +;;; Useful programming macros. + +(defmacro math-while (head &rest body) + (let ((body (cons 'while (cons head body)))) + (if (math-body-refers-to body 'math-break) + (cons 'catch (cons '(quote math-break) (list body))) + body)) +) + + +(defmacro math-for (head &rest body) + (let ((body (if head + (math-handle-for head body) + (cons 'while (cons t body))))) + (if (math-body-refers-to body 'math-break) + (cons 'catch (cons '(quote math-break) (list body))) + body)) +) + +(defun math-handle-for (head body) + (let* ((var (nth 0 (car head))) + (init (nth 1 (car head))) + (limit (nth 2 (car head))) + (step (or (nth 3 (car head)) 1)) + (body (if (cdr head) + (list (math-handle-for (cdr head) body)) + body)) + (all-ints (and (integerp init) (integerp limit) (integerp step))) + (const-limit (or (integerp limit) + (and (eq (car-safe limit) 'quote) + (math-realp (nth 1 limit))))) + (const-step (or (integerp step) + (and (eq (car-safe step) 'quote) + (math-realp (nth 1 step))))) + (save-limit (if const-limit limit (make-symbol "<limit>"))) + (save-step (if const-step step (make-symbol "<step>")))) + (cons 'let + (cons (append (if const-limit nil (list (list save-limit limit))) + (if const-step nil (list (list save-step step))) + (list (list var init))) + (list + (cons 'while + (cons (if all-ints + (if (> step 0) + (list '<= var save-limit) + (list '>= var save-limit)) + (list 'not + (if const-step + (if (or (math-posp step) + (math-posp + (cdr-safe step))) + (list 'math-lessp + save-limit + var) + (list 'math-lessp + var + save-limit)) + (list 'if + (list 'math-posp + save-step) + (list 'math-lessp + save-limit + var) + (list 'math-lessp + var + save-limit))))) + (append body + (list (list 'setq + var + (list (if all-ints + '+ + 'math-add) + var + save-step)))))))))) +) + + +(defmacro math-foreach (head &rest body) + (let ((body (math-handle-foreach head body))) + (if (math-body-refers-to body 'math-break) + (cons 'catch (cons '(quote math-break) (list body))) + body)) +) + + +(defun math-handle-foreach (head body) + (let ((var (nth 0 (car head))) + (data (nth 1 (car head))) + (body (if (cdr head) + (list (math-handle-foreach (cdr head) body)) + body))) + (cons 'let + (cons (list (list var data)) + (list + (cons 'while + (cons var + (append body + (list (list 'setq + var + (list 'cdr var)))))))))) +) + + +(defun math-body-refers-to (body thing) + (or (equal body thing) + (and (consp body) + (or (math-body-refers-to (car body) thing) + (math-body-refers-to (cdr body) thing)))) +) + +(defun math-break (&optional value) + (throw 'math-break value) +) + +(defun math-return (&optional value) + (throw 'math-return value) +) + + + + + +(defun math-composite-inequalities (x op) + (if (memq (nth 1 op) '(calcFunc-eq calcFunc-neq)) + (if (eq (car x) (nth 1 op)) + (append x (list (math-read-expr-level (nth 3 op)))) + (throw 'syntax "Syntax error")) + (list 'calcFunc-in + (nth 2 x) + (if (memq (nth 1 op) '(calcFunc-lt calcFunc-leq)) + (if (memq (car x) '(calcFunc-lt calcFunc-leq)) + (math-make-intv + (+ (if (eq (car x) 'calcFunc-leq) 2 0) + (if (eq (nth 1 op) 'calcFunc-leq) 1 0)) + (nth 1 x) (math-read-expr-level (nth 3 op))) + (throw 'syntax "Syntax error")) + (if (memq (car x) '(calcFunc-gt calcFunc-geq)) + (math-make-intv + (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0) + (if (eq (car x) 'calcFunc-geq) 1 0)) + (math-read-expr-level (nth 3 op)) (nth 1 x)) + (throw 'syntax "Syntax error"))))) +) + diff --git a/lisp/calc/calc-rewr.el b/lisp/calc/calc-rewr.el new file mode 100644 index 0000000000..4250533f62 --- /dev/null +++ b/lisp/calc/calc-rewr.el @@ -0,0 +1,2097 @@ +;; Calculator for GNU Emacs, part II [calc-rewr.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-rewr () nil) + + +(defun calc-rewrite-selection (rules-str &optional many prefix) + (interactive "sRewrite rule(s): \np") + (calc-slow-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect t) + (pop-rules nil) + (entry (calc-top num 'entry)) + (expr (car entry)) + (sel (calc-auto-selection entry)) + (math-rewrite-selections t) + (math-rewrite-default-iters 1)) + (if (or (null rules-str) (equal rules-str "") (equal rules-str "$")) + (if (= num 1) + (error "Can't use same stack entry for formula and rules.") + (setq rules (calc-top-n 1 t) + pop-rules t)) + (setq rules (if (stringp rules-str) + (math-read-exprs rules-str) rules-str)) + (if (eq (car-safe rules) 'error) + (error "Bad format in expression: %s" (nth 1 rules))) + (if (= (length rules) 1) + (setq rules (car rules)) + (setq rules (cons 'vec rules))) + (or (memq (car-safe rules) '(vec var calcFunc-assign + calcFunc-condition)) + (let ((rhs (math-read-expr + (read-string (concat "Rewrite from: " rules-str + " to: "))))) + (if (eq (car-safe rhs) 'error) + (error "Bad format in expression: %s" (nth 1 rhs))) + (setq rules (list 'calcFunc-assign rules rhs)))) + (or (eq (car-safe rules) 'var) + (calc-record rules "rule"))) + (if (eq many 0) + (setq many '(var inf var-inf)) + (if many (setq many (prefix-numeric-value many)))) + (if sel + (setq expr (calc-replace-sub-formula (car entry) + sel + (list 'calcFunc-select sel))) + (setq expr (car entry) + reselect nil + math-rewrite-selections nil)) + (setq expr (calc-encase-atoms + (calc-normalize + (math-rewrite + (calc-normalize expr) + rules many))) + sel nil + expr (calc-locate-select-marker expr)) + (or (consp sel) (setq sel nil)) + (if pop-rules (calc-pop-stack 1)) + (calc-pop-push-record-list 1 (or prefix "rwrt") (list expr) + (- num (if pop-rules 1 0)) + (list (and reselect sel)))) + (calc-handle-whys)) +) + +(defun calc-locate-select-marker (expr) ; changes "sel" + (if (Math-primp expr) + expr + (if (and (eq (car expr) 'calcFunc-select) + (= (length expr) 2)) + (progn + (setq sel (if sel t (nth 1 expr))) + (nth 1 expr)) + (cons (car expr) + (mapcar 'calc-locate-select-marker (cdr expr))))) +) + + + +(defun calc-rewrite (rules-str many) + (interactive "sRewrite rule(s): \nP") + (calc-slow-wrapper + (let (n rules expr) + (if (or (null rules-str) (equal rules-str "") (equal rules-str "$")) + (setq expr (calc-top-n 2) + rules (calc-top-n 1 t) + n 2) + (setq rules (if (stringp rules-str) + (math-read-exprs rules-str) rules-str)) + (if (eq (car-safe rules) 'error) + (error "Bad format in expression: %s" (nth 1 rules))) + (if (= (length rules) 1) + (setq rules (car rules)) + (setq rules (cons 'vec rules))) + (or (memq (car-safe rules) '(vec var calcFunc-assign + calcFunc-condition)) + (let ((rhs (math-read-expr + (read-string (concat "Rewrite from: " rules-str + " to: "))))) + (if (eq (car-safe rhs) 'error) + (error "Bad format in expression: %s" (nth 1 rhs))) + (setq rules (list 'calcFunc-assign rules rhs)))) + (or (eq (car-safe rules) 'var) + (calc-record rules "rule")) + (setq expr (calc-top-n 1) + n 1)) + (if (eq many 0) + (setq many '(var inf var-inf)) + (if many (setq many (prefix-numeric-value many)))) + (setq expr (calc-normalize (math-rewrite expr rules many))) + (let (sel) + (setq expr (calc-locate-select-marker expr))) + (calc-pop-push-record-list n "rwrt" (list expr))) + (calc-handle-whys)) +) + +(defun calc-match (pat) + (interactive "sPattern: \n") + (calc-slow-wrapper + (let (n expr) + (if (or (null pat) (equal pat "") (equal pat "$")) + (setq expr (calc-top-n 2) + pat (calc-top-n 1) + n 2) + (if (interactive-p) (setq calc-previous-alg-entry pat)) + (setq pat (if (stringp pat) (math-read-expr pat) pat)) + (if (eq (car-safe pat) 'error) + (error "Bad format in expression: %s" (nth 1 pat))) + (if (not (eq (car-safe pat) 'var)) + (calc-record pat "pat")) + (setq expr (calc-top-n 1) + n 1)) + (or (math-vectorp expr) (error "Argument must be a vector")) + (if (calc-is-inverse) + (calc-enter-result n "mtcn" (math-match-patterns pat expr t)) + (calc-enter-result n "mtch" (math-match-patterns pat expr nil))))) +) + + + +(defun math-rewrite (whole-expr rules &optional mmt-many) + (let ((crules (math-compile-rewrites rules)) + (heads (math-rewrite-heads whole-expr)) + (trace-buffer (get-buffer "*Trace*")) + (calc-display-just 'center) + (calc-display-origin 39) + (calc-line-breaking 78) + (calc-line-numbering nil) + (calc-show-selections t) + (calc-why nil) + (mmt-func (function + (lambda (x) + (let ((result (math-apply-rewrites x (cdr crules) + heads crules))) + (if result + (progn + (if trace-buffer + (let ((fmt (math-format-stack-value + (list result nil nil)))) + (save-excursion + (set-buffer trace-buffer) + (insert "\nrewrite to\n" fmt "\n")))) + (setq heads (math-rewrite-heads result heads t)))) + result))))) + (if trace-buffer + (let ((fmt (math-format-stack-value (list whole-expr nil nil)))) + (save-excursion + (set-buffer trace-buffer) + (setq truncate-lines t) + (goto-char (point-max)) + (insert "\n\nBegin rewriting\n" fmt "\n")))) + (or mmt-many (setq mmt-many (or (nth 1 (car crules)) + math-rewrite-default-iters))) + (if (equal mmt-many '(var inf var-inf)) (setq mmt-many 1000000)) + (if (equal mmt-many '(neg (var inf var-inf))) (setq mmt-many -1000000)) + (math-rewrite-phase (nth 3 (car crules))) + (if trace-buffer + (let ((fmt (math-format-stack-value (list whole-expr nil nil)))) + (save-excursion + (set-buffer trace-buffer) + (insert "\nDone rewriting" + (if (= mmt-many 0) " (reached iteration limit)" "") + ":\n" fmt "\n")))) + whole-expr) +) +(setq math-rewrite-default-iters 100) + +(defun math-rewrite-phase (sched) + (while (and sched (/= mmt-many 0)) + (if (listp (car sched)) + (while (let ((save-expr whole-expr)) + (math-rewrite-phase (car sched)) + (not (equal whole-expr save-expr)))) + (if (symbolp (car sched)) + (progn + (setq whole-expr (math-normalize (list (car sched) whole-expr))) + (if trace-buffer + (let ((fmt (math-format-stack-value + (list whole-expr nil nil)))) + (save-excursion + (set-buffer trace-buffer) + (insert "\ncall " + (substring (symbol-name (car sched)) 9) + ":\n" fmt "\n"))))) + (let ((math-rewrite-phase (car sched))) + (if trace-buffer + (save-excursion + (set-buffer trace-buffer) + (insert (format "\n(Phase %d)\n" math-rewrite-phase)))) + (while (let ((save-expr whole-expr)) + (setq whole-expr (math-normalize + (math-map-tree-rec whole-expr))) + (not (equal whole-expr save-expr))))))) + (setq sched (cdr sched))) +) + +(defun calcFunc-rewrite (expr rules &optional many) + (or (null many) (integerp many) + (equal many '(var inf var-inf)) (equal many '(neg (var inf var-inf))) + (math-reject-arg many 'fixnump)) + (condition-case err + (math-rewrite expr rules (or many 1)) + (error (math-reject-arg rules (nth 1 err)))) +) + +(defun calcFunc-match (pat vec) + (or (math-vectorp vec) (math-reject-arg vec 'vectorp)) + (condition-case err + (math-match-patterns pat vec nil) + (error (math-reject-arg pat (nth 1 err)))) +) + +(defun calcFunc-matchnot (pat vec) + (or (math-vectorp vec) (math-reject-arg vec 'vectorp)) + (condition-case err + (math-match-patterns pat vec t) + (error (math-reject-arg pat (nth 1 err)))) +) + +(defun math-match-patterns (pat vec &optional not-flag) + (let ((newvec nil) + (crules (math-compile-patterns pat))) + (while (setq vec (cdr vec)) + (if (eq (not (math-apply-rewrites (car vec) crules)) + not-flag) + (setq newvec (cons (car vec) newvec)))) + (cons 'vec (nreverse newvec))) +) + +(defun calcFunc-matches (expr pat) + (condition-case err + (if (math-apply-rewrites expr (math-compile-patterns pat)) + 1 + 0) + (error (math-reject-arg pat (nth 1 err)))) +) + +(defun calcFunc-vmatches (expr pat) + (condition-case err + (or (math-apply-rewrites expr (math-compile-patterns pat)) + 0) + (error (math-reject-arg pat (nth 1 err)))) +) + + + +;;; A compiled rule set is an a-list of entries whose cars are functors, +;;; and whose cdrs are lists of rules. If there are rules with no +;;; well-defined head functor, they are included on all lists and also +;;; on an extra list whose car is nil. +;;; +;;; The first entry in the a-list is of the form (schedule A B C ...). +;;; +;;; Rule list entries take the form (regs prog head phases), where: +;;; +;;; regs is a vector of match registers. +;;; +;;; prog is a match program (see below). +;;; +;;; head is a rare function name appearing in the rule body (but not the +;;; head of the whole rule), or nil if none. +;;; +;;; phases is a list of phase numbers for which the rule is enabled. +;;; +;;; A match program is a list of match instructions. +;;; +;;; In the following, "part" is a register number that contains the +;;; subexpression to be operated on. +;;; +;;; Register 0 is the whole expression being matched. The others are +;;; meta-variables in the pattern, temporaries used for matching and +;;; backtracking, and constant expressions. +;;; +;;; (same part reg) +;;; The selected part must be math-equal to the contents of "reg". +;;; +;;; (same-neg part reg) +;;; The selected part must be math-equal to the negative of "reg". +;;; +;;; (copy part reg) +;;; The selected part is copied into "reg". (Rarely used.) +;;; +;;; (copy-neg part reg) +;;; The negative of the selected part is copied into "reg". +;;; +;;; (integer part) +;;; The selected part must be an integer. +;;; +;;; (real part) +;;; The selected part must be a real. +;;; +;;; (constant part) +;;; The selected part must be a constant. +;;; +;;; (negative part) +;;; The selected part must "look" negative. +;;; +;;; (rel part op reg) +;;; The selected part must satisfy "part op reg", where "op" +;;; is one of the 6 relational ops, and "reg" is a register. +;;; +;;; (mod part modulo value) +;;; The selected part must satisfy "part % modulo = value", where +;;; "modulo" and "value" are constants. +;;; +;;; (func part head reg1 reg2 ... regn) +;;; The selected part must be an n-ary call to function "head". +;;; The arguments are stored in "reg1" through "regn". +;;; +;;; (func-def part head defs reg1 reg2 ... regn) +;;; The selected part must be an n-ary call to function "head". +;;; "Defs" is a list of value/register number pairs for default args. +;;; If a match, assign default values to registers and then skip +;;; immediately over any following "func-def" instructions and +;;; the following "func" instruction. If wrong number of arguments, +;;; proceed to the following "func-def" or "func" instruction. +;;; +;;; (func-opt part head defs reg1) +;;; Like func-def with "n=1", except that if the selected part is +;;; not a call to "head", then the part itself successfully matches +;;; "reg1" (and the defaults are assigned). +;;; +;;; (try part heads mark reg1 [def]) +;;; The selected part must be a function of the correct type which is +;;; associative and/or commutative. "Heads" is a list of acceptable +;;; types. An initial assignment of arguments to "reg1" is tried. +;;; If the program later fails, it backtracks to this instruction +;;; and tries other assignments of arguments to "reg1". +;;; If "def" exists and normal matching fails, backtrack and assign +;;; "part" to "reg1", and "def" to "reg2" in the following "try2". +;;; The "mark" is a vector of size 5; only "mark[3-4]" are initialized. +;;; "mark[0]" points to the argument list; "mark[1]" points to the +;;; current argument; "mark[2]" is 0 if there are two arguments, +;;; 1 if reg1 is matching single arguments, 2 if reg2 is matching +;;; single arguments (a+b+c+d is never split as (a+b)+(c+d)), or +;;; 3 if reg2 is matching "def"; "mark[3]" is 0 if the function must +;;; have two arguments, 1 if phase-2 can be skipped, 2 if full +;;; backtracking is necessary; "mark[4]" is t if the arguments have +;;; been switched from the order given in the original pattern. +;;; +;;; (try2 try reg2) +;;; Every "try" will be followed by a "try2" whose "try" field is +;;; a pointer to the corresponding "try". The arguments which were +;;; not stored in "reg1" by that "try" are now stored in "reg2". +;;; +;;; (alt instr nil mark) +;;; Basic backtracking. Execute the instruction sequence "instr". +;;; If this fails, back up and execute following the "alt" instruction. +;;; The "mark" must be the vector "[nil nil 4]". The "instr" sequence +;;; should execute "end-alt" at the end. +;;; +;;; (end-alt ptr) +;;; Register success of the first alternative of a previous "alt". +;;; "Ptr" is a pointer to the next instruction following that "alt". +;;; +;;; (apply part reg1 reg2) +;;; The selected part must be a function call. The functor +;;; (as a variable name) is stored in "reg1"; the arguments +;;; (as a vector) are stored in "reg2". +;;; +;;; (cons part reg1 reg2) +;;; The selected part must be a nonempty vector. The first element +;;; of the vector is stored in "reg1"; the rest of the vector +;;; (as another vector) is stored in "reg2". +;;; +;;; (rcons part reg1 reg2) +;;; The selected part must be a nonempty vector. The last element +;;; of the vector is stored in "reg2"; the rest of the vector +;;; (as another vector) is stored in "reg1". +;;; +;;; (select part reg) +;;; If the selected part is a unary call to function "select", its +;;; argument is stored in "reg"; otherwise (provided this is an `a r' +;;; and not a `g r' command) the selected part is stored in "reg". +;;; +;;; (cond expr) +;;; The "expr", with registers substituted, must simplify to +;;; a non-zero value. +;;; +;;; (let reg expr) +;;; Evaluate "expr" and store the result in "reg". Always succeeds. +;;; +;;; (done rhs remember) +;;; Rewrite the expression to "rhs", with register substituted. +;;; Normalize; if the result is different from the original +;;; expression, the match has succeeded. This is the last +;;; instruction of every program. If "remember" is non-nil, +;;; record the result of the match as a new literal rule. + + +;;; Pseudo-functions related to rewrites: +;;; +;;; In patterns: quote, plain, condition, opt, apply, cons, select +;;; +;;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp, +;;; apply, cons, select +;;; +;;; In conditions: let + same as for righthand sides + +;;; Some optimizations that would be nice to have: +;;; +;;; * Merge registers with disjoint lifetimes. +;;; * Merge constant registers with equivalent values. +;;; +;;; * If an argument of a commutative op math-depends neither on the +;;; rest of the pattern nor on any of the conditions, then no backtracking +;;; should be done for that argument. (This won't apply to very many +;;; cases.) +;;; +;;; * If top functor is "select", and its argument is a unique function, +;;; add the rule to the lists for both "select" and that function. +;;; (Currently rules like this go on the "nil" list.) +;;; Same for "func-opt" functions. (Though not urgent for these.) +;;; +;;; * Shouldn't evaluate a "let" condition until the end, or until it +;;; would enable another condition to be evaluated. +;;; + +;;; Some additional features to add / things to think about: +;;; +;;; * Figure out what happens to "a +/- b" and "a +/- opt(b)". +;;; +;;; * Same for interval forms. +;;; +;;; * Have a name(v,pat) pattern which matches pat, and gives the +;;; whole match the name v. Beware of circular structures! +;;; + +(defun math-compile-patterns (pats) + (if (and (eq (car-safe pats) 'var) + (calc-var-value (nth 2 pats))) + (let ((prop (get (nth 2 pats) 'math-pattern-cache))) + (or prop + (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil)))) + (or (eq (car prop) (symbol-value (nth 2 pats))) + (progn + (setcdr prop (math-compile-patterns + (symbol-value (nth 2 pats)))) + (setcar prop (symbol-value (nth 2 pats))))) + (cdr prop)) + (let ((math-rewrite-whole t)) + (cdr (math-compile-rewrites (cons + 'vec + (mapcar (function (lambda (x) + (list 'vec x t))) + (if (eq (car-safe pats) 'vec) + (cdr pats) + (list pats)))))))) +) +(setq math-rewrite-whole nil) +(setq math-make-import-list nil) + +(defun math-compile-rewrites (rules &optional name) + (if (eq (car-safe rules) 'var) + (let ((prop (get (nth 2 rules) 'math-rewrite-cache)) + (math-import-list nil) + (math-make-import-list t) + p) + (or (calc-var-value (nth 2 rules)) + (error "Rules variable %s has no stored value" (nth 1 rules))) + (or prop + (put (nth 2 rules) 'math-rewrite-cache + (setq prop (list (list (cons (nth 2 rules) nil)))))) + (setq p (car prop)) + (while (and p (eq (symbol-value (car (car p))) (cdr (car p)))) + (setq p (cdr p))) + (or (null p) + (progn + (message "Compiling rule set %s..." (nth 1 rules)) + (setcdr prop (math-compile-rewrites + (symbol-value (nth 2 rules)) + (nth 2 rules))) + (message "Compiling rule set %s...done" (nth 1 rules)) + (setcar prop (cons (cons (nth 2 rules) + (symbol-value (nth 2 rules))) + math-import-list)))) + (cdr prop)) + (if (or (not (eq (car-safe rules) 'vec)) + (and (memq (length rules) '(3 4)) + (let ((p rules)) + (while (and (setq p (cdr p)) + (memq (car-safe (car p)) + '(vec + calcFunc-assign + calcFunc-condition + calcFunc-import + calcFunc-phase + calcFunc-schedule + calcFunc-iterations)))) + p))) + (setq rules (list rules)) + (setq rules (cdr rules))) + (if (assq 'calcFunc-import rules) + (let ((pp (setq rules (copy-sequence rules))) + p part) + (while (setq p (car (cdr pp))) + (if (eq (car-safe p) 'calcFunc-import) + (progn + (setcdr pp (cdr (cdr pp))) + (or (and (eq (car-safe (nth 1 p)) 'var) + (setq part (calc-var-value (nth 2 (nth 1 p)))) + (memq (car-safe part) '(vec + calcFunc-assign + calcFunc-condition))) + (error "Argument of import() must be a rules variable")) + (if math-make-import-list + (setq math-import-list + (cons (cons (nth 2 (nth 1 p)) + (symbol-value (nth 2 (nth 1 p)))) + math-import-list))) + (while (setq p (cdr (cdr p))) + (or (cdr p) + (error "import() must have odd number of arguments")) + (setq part (math-rwcomp-substitute part + (car p) (nth 1 p)))) + (if (eq (car-safe part) 'vec) + (setq part (cdr part)) + (setq part (list part))) + (setcdr pp (append part (cdr pp)))) + (setq pp (cdr pp)))))) + (let ((rule-set nil) + (all-heads nil) + (nil-rules nil) + (rule-count 0) + (math-schedule nil) + (math-iterations nil) + (math-phases nil) + (math-all-phases nil) + (math-remembering nil) + math-pattern math-rhs math-conds) + (while rules + (cond + ((and (eq (car-safe (car rules)) 'calcFunc-iterations) + (= (length (car rules)) 2)) + (or (integerp (nth 1 (car rules))) + (equal (nth 1 (car rules)) '(var inf var-inf)) + (equal (nth 1 (car rules)) '(neg (var inf var-inf))) + (error "Invalid argument for iterations(n)")) + (or math-iterations + (setq math-iterations (nth 1 (car rules))))) + ((eq (car-safe (car rules)) 'calcFunc-schedule) + (or math-schedule + (setq math-schedule (math-parse-schedule (cdr (car rules)))))) + ((eq (car-safe (car rules)) 'calcFunc-phase) + (setq math-phases (cdr (car rules))) + (if (equal math-phases '((var all var-all))) + (setq math-phases nil)) + (let ((p math-phases)) + (while p + (or (integerp (car p)) + (error "Phase numbers must be small integers")) + (or (memq (car p) math-all-phases) + (setq math-all-phases (cons (car p) math-all-phases))) + (setq p (cdr p))))) + ((or (and (eq (car-safe (car rules)) 'vec) + (cdr (cdr (car rules))) + (not (nthcdr 4 (car rules))) + (setq math-conds (nth 3 (car rules)) + math-rhs (nth 2 (car rules)) + math-pattern (nth 1 (car rules)))) + (progn + (setq math-conds nil + math-pattern (car rules)) + (while (and (eq (car-safe math-pattern) 'calcFunc-condition) + (= (length math-pattern) 3)) + (let ((cond (nth 2 math-pattern))) + (setq math-conds (if math-conds + (list 'calcFunc-land math-conds cond) + cond) + math-pattern (nth 1 math-pattern)))) + (and (eq (car-safe math-pattern) 'calcFunc-assign) + (= (length math-pattern) 3) + (setq math-rhs (nth 2 math-pattern) + math-pattern (nth 1 math-pattern))))) + (let* ((math-prog (list nil)) + (math-prog-last math-prog) + (math-num-regs 1) + (math-regs (list (list nil 0 nil nil))) + (math-bound-vars nil) + (math-aliased-vars nil) + (math-copy-neg nil)) + (setq math-conds (and math-conds (math-flatten-lands math-conds))) + (math-rwcomp-pattern math-pattern 0) + (while math-conds + (let ((expr (car math-conds))) + (setq math-conds (cdr math-conds)) + (math-rwcomp-cond-instr expr))) + (math-rwcomp-instr 'done + (if (eq math-rhs t) + (cons 'vec + (delq + nil + (nreverse + (mapcar + (function + (lambda (v) + (and (car v) + (list + 'calcFunc-assign + (math-build-var-name + (car v)) + (math-rwcomp-register-expr + (nth 1 v)))))) + math-regs)))) + (math-rwcomp-match-vars math-rhs)) + math-remembering) + (setq math-prog (cdr math-prog)) + (let* ((heads (math-rewrite-heads math-pattern)) + (rule (list (vconcat + (nreverse + (mapcar (function (lambda (x) (nth 3 x))) + math-regs))) + math-prog + heads + math-phases)) + (head (and (not (Math-primp math-pattern)) + (not (and (eq (car (car math-prog)) 'try) + (nth 5 (car math-prog)))) + (not (memq (car (car math-prog)) '(func-opt + apply + select + alt))) + (if (memq (car (car math-prog)) '(func + func-def)) + (nth 2 (car math-prog)) + (if (eq (car math-pattern) 'calcFunc-quote) + (car-safe (nth 1 math-pattern)) + (car math-pattern)))))) + (let (found) + (while heads + (if (setq found (assq (car heads) all-heads)) + (setcdr found (1+ (cdr found))) + (setq all-heads (cons (cons (car heads) 1) all-heads))) + (setq heads (cdr heads)))) + (if (eq head '-) (setq head '+)) + (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec)) + (if head + (progn + (nconc (or (assq head rule-set) + (car (setq rule-set (cons (cons head + (copy-sequence + nil-rules)) + rule-set)))) + (list rule)) + (if (eq head '*) + (nconc (or (assq '/ rule-set) + (car (setq rule-set (cons (cons + '/ + (copy-sequence + nil-rules)) + rule-set)))) + (list rule)))) + (setq nil-rules (nconc nil-rules (list rule))) + (let ((ptr rule-set)) + (while ptr + (nconc (car ptr) (list rule)) + (setq ptr (cdr ptr)))))))) + (t + (error "Rewrite rule set must be a vector of A := B rules"))) + (setq rules (cdr rules))) + (if nil-rules + (setq rule-set (cons (cons nil nil-rules) rule-set))) + (setq all-heads (mapcar 'car + (sort all-heads (function + (lambda (x y) + (< (cdr x) (cdr y))))))) + (let ((set rule-set) + rule heads ptr) + (while set + (setq rule (cdr (car set))) + (while rule + (if (consp (setq heads (nth 2 (car rule)))) + (progn + (setq heads (delq (car (car set)) heads) + ptr all-heads) + (while (and ptr (not (memq (car ptr) heads))) + (setq ptr (cdr ptr))) + (setcar (nthcdr 2 (car rule)) (car ptr)))) + (setq rule (cdr rule))) + (setq set (cdr set)))) + (let ((plus (assq '+ rule-set))) + (if plus + (setq rule-set (cons (cons '- (cdr plus)) rule-set)))) + (cons (list 'schedule math-iterations name + (or math-schedule + (sort math-all-phases '<) + (list 1))) + rule-set))) +) + +(defun math-flatten-lands (expr) + (if (eq (car-safe expr) 'calcFunc-land) + (append (math-flatten-lands (nth 1 expr)) + (math-flatten-lands (nth 2 expr))) + (list expr)) +) + +(defun math-rewrite-heads (expr &optional more all) + (let ((heads more) + (skips (and (not all) + '(calcFunc-apply calcFunc-condition calcFunc-opt + calcFunc-por calcFunc-pnot))) + (blanks (and (not all) + '(calcFunc-quote calcFunc-plain calcFunc-select + calcFunc-cons calcFunc-rcons + calcFunc-pand)))) + (or (Math-primp expr) + (math-rewrite-heads-rec expr)) + heads) +) + +(defun math-rewrite-heads-rec (expr) + (or (memq (car expr) skips) + (progn + (or (memq (car expr) heads) + (memq (car expr) blanks) + (memq 'algebraic (get (car expr) 'math-rewrite-props)) + (setq heads (cons (car expr) heads))) + (while (setq expr (cdr expr)) + (or (Math-primp (car expr)) + (math-rewrite-heads-rec (car expr)))))) +) + +(defun math-parse-schedule (sched) + (mapcar (function + (lambda (s) + (if (integerp s) + s + (if (math-vectorp s) + (math-parse-schedule (cdr s)) + (if (eq (car-safe s) 'var) + (math-var-to-calcFunc s) + (error "Improper component in rewrite schedule")))))) + sched) +) + +(defun math-rwcomp-match-vars (expr) + (if (Math-primp expr) + (if (eq (car-safe expr) 'var) + (let ((entry (assq (nth 2 expr) math-regs))) + (if entry + (math-rwcomp-register-expr (nth 1 entry)) + expr)) + expr) + (if (and (eq (car expr) 'calcFunc-quote) + (= (length expr) 2)) + (math-rwcomp-match-vars (nth 1 expr)) + (if (and (eq (car expr) 'calcFunc-plain) + (= (length expr) 2) + (not (Math-primp (nth 1 expr)))) + (list (car expr) + (cons (car (nth 1 expr)) + (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr))))) + (cons (car expr) + (mapcar 'math-rwcomp-match-vars (cdr expr)))))) +) + +(defun math-rwcomp-register-expr (num) + (let ((entry (nth (1- (- math-num-regs num)) math-regs))) + (if (nth 2 entry) + (list 'neg (list 'calcFunc-register (nth 1 entry))) + (list 'calcFunc-register (nth 1 entry)))) +) + +(defun math-rwcomp-substitute (expr old new) + (if (and (eq (car-safe old) 'var) + (memq (car-safe new) '(var calcFunc-lambda))) + (let ((old-func (math-var-to-calcFunc old)) + (new-func (math-var-to-calcFunc new))) + (math-rwcomp-subst-rec expr)) + (let ((old-func nil)) + (math-rwcomp-subst-rec expr))) +) + +(defun math-rwcomp-subst-rec (expr) + (cond ((equal expr old) new) + ((Math-primp expr) expr) + (t (if (eq (car expr) old-func) + (math-build-call new-func (mapcar 'math-rwcomp-subst-rec + (cdr expr))) + (cons (car expr) + (mapcar 'math-rwcomp-subst-rec (cdr expr)))))) +) + +(setq math-rwcomp-tracing nil) + +(defun math-rwcomp-trace (instr) + (if math-rwcomp-tracing (progn (terpri) (princ instr))) + instr +) + +(defun math-rwcomp-instr (&rest instr) + (setcdr math-prog-last + (setq math-prog-last (list (math-rwcomp-trace instr)))) +) + +(defun math-rwcomp-multi-instr (tail &rest instr) + (setcdr math-prog-last + (setq math-prog-last (list (math-rwcomp-trace (append instr tail))))) +) + +(defun math-rwcomp-bind-var (reg var) + (setcar (math-rwcomp-reg-entry reg) (nth 2 var)) + (setq math-bound-vars (cons (nth 2 var) math-bound-vars)) + (math-rwcomp-do-conditions) +) + +(defun math-rwcomp-unbind-vars (mark) + (while (not (eq math-bound-vars mark)) + (setcar (assq (car math-bound-vars) math-regs) nil) + (setq math-bound-vars (cdr math-bound-vars))) +) + +(defun math-rwcomp-do-conditions () + (let ((cond math-conds)) + (while cond + (if (math-rwcomp-all-regs-done (car cond)) + (let ((expr (car cond))) + (setq math-conds (delq (car cond) math-conds)) + (setcar cond 1) + (math-rwcomp-cond-instr expr))) + (setq cond (cdr cond)))) +) + +(defun math-rwcomp-cond-instr (expr) + (let (op arg) + (cond ((and (eq (car-safe expr) 'calcFunc-matches) + (= (length expr) 3) + (eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr)))) + 'calcFunc-register)) + (math-rwcomp-pattern (nth 2 expr) (nth 1 arg))) + ((math-numberp (setq expr (math-rwcomp-match-vars expr))) + (if (Math-zerop expr) + (math-rwcomp-instr 'backtrack))) + ((and (eq (car expr) 'calcFunc-let) + (= (length expr) 3)) + (let ((reg (math-rwcomp-reg))) + (math-rwcomp-instr 'let reg (nth 2 expr)) + (math-rwcomp-pattern (nth 1 expr) reg))) + ((and (eq (car expr) 'calcFunc-let) + (= (length expr) 2) + (eq (car-safe (nth 1 expr)) 'calcFunc-assign) + (= (length (nth 1 expr)) 3)) + (let ((reg (math-rwcomp-reg))) + (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr))) + (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg))) + ((and (setq op (cdr (assq (car-safe expr) + '( (calcFunc-integer . integer) + (calcFunc-real . real) + (calcFunc-constant . constant) + (calcFunc-negative . negative) )))) + (= (length expr) 2) + (or (and (eq (car-safe (nth 1 expr)) 'neg) + (memq op '(integer real constant)) + (setq arg (nth 1 (nth 1 expr)))) + (setq arg (nth 1 expr))) + (eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register)) + (math-rwcomp-instr op (nth 1 arg))) + ((and (assq (car-safe expr) calc-tweak-eqn-table) + (= (length expr) 3) + (eq (car-safe (nth 1 expr)) 'calcFunc-register)) + (if (math-constp (nth 2 expr)) + (let ((reg (math-rwcomp-reg))) + (setcar (nthcdr 3 (car math-regs)) (nth 2 expr)) + (math-rwcomp-instr 'rel (nth 1 (nth 1 expr)) + (car expr) reg)) + (if (eq (car (nth 2 expr)) 'calcFunc-register) + (math-rwcomp-instr 'rel (nth 1 (nth 1 expr)) + (car expr) (nth 1 (nth 2 expr))) + (math-rwcomp-instr 'cond expr)))) + ((and (eq (car-safe expr) 'calcFunc-eq) + (= (length expr) 3) + (eq (car-safe (nth 1 expr)) '%) + (eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register) + (math-constp (nth 2 (nth 1 expr))) + (math-constp (nth 2 expr))) + (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr))) + (nth 2 (nth 1 expr)) (nth 2 expr))) + ((equal expr '(var remember var-remember)) + (setq math-remembering 1)) + ((and (eq (car-safe expr) 'calcFunc-remember) + (= (length expr) 2)) + (setq math-remembering (if math-remembering + (list 'calcFunc-lor + math-remembering (nth 1 expr)) + (nth 1 expr)))) + (t (math-rwcomp-instr 'cond expr)))) +) + +(defun math-rwcomp-same-instr (reg1 reg2 neg) + (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1)) + (nth 2 (math-rwcomp-reg-entry reg2))) + neg) + 'same-neg + 'same) + reg1 reg2) +) + +(defun math-rwcomp-copy-instr (reg1 reg2 neg) + (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1)) + (nth 2 (math-rwcomp-reg-entry reg2))) + neg) + (math-rwcomp-instr 'copy-neg reg1 reg2) + (or (eq reg1 reg2) + (math-rwcomp-instr 'copy reg1 reg2))) +) + +(defun math-rwcomp-reg () + (prog1 + math-num-regs + (setq math-regs (cons (list nil math-num-regs nil 0) math-regs) + math-num-regs (1+ math-num-regs))) +) + +(defun math-rwcomp-reg-entry (num) + (nth (1- (- math-num-regs num)) math-regs) +) + + +(defun math-rwcomp-pattern (expr part &optional not-direct) + (cond ((or (math-rwcomp-no-vars expr) + (and (eq (car expr) 'calcFunc-quote) + (= (length expr) 2) + (setq expr (nth 1 expr)))) + (if (eq (car-safe expr) 'calcFunc-register) + (math-rwcomp-same-instr part (nth 1 expr) nil) + (let ((reg (math-rwcomp-reg))) + (setcar (nthcdr 3 (car math-regs)) expr) + (math-rwcomp-same-instr part reg nil)))) + ((eq (car expr) 'var) + (let ((entry (assq (nth 2 expr) math-regs))) + (if entry + (math-rwcomp-same-instr part (nth 1 entry) nil) + (if not-direct + (let ((reg (math-rwcomp-reg))) + (math-rwcomp-pattern expr reg) + (math-rwcomp-copy-instr part reg nil)) + (if (setq entry (assq (nth 2 expr) math-aliased-vars)) + (progn + (setcar (math-rwcomp-reg-entry (nth 1 entry)) + (nth 2 expr)) + (setcar entry nil) + (math-rwcomp-copy-instr part (nth 1 entry) nil)) + (math-rwcomp-bind-var part expr)))))) + ((and (eq (car expr) 'calcFunc-select) + (= (length expr) 2)) + (let ((reg (math-rwcomp-reg))) + (math-rwcomp-instr 'select part reg) + (math-rwcomp-pattern (nth 1 expr) reg))) + ((and (eq (car expr) 'calcFunc-opt) + (memq (length expr) '(2 3))) + (error "opt( ) occurs in context where it is not allowed")) + ((eq (car expr) 'neg) + (if (eq (car (nth 1 expr)) 'var) + (let ((entry (assq (nth 2 (nth 1 expr)) math-regs))) + (if entry + (math-rwcomp-same-instr part (nth 1 entry) t) + (if math-copy-neg + (let ((reg (math-rwcomp-best-reg (nth 1 expr)))) + (math-rwcomp-copy-instr part reg t) + (math-rwcomp-pattern (nth 1 expr) reg)) + (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t) + (math-rwcomp-pattern (nth 1 expr) part)))) + (if (math-rwcomp-is-algebraic (nth 1 expr)) + (math-rwcomp-cond-instr (list 'calcFunc-eq + (math-rwcomp-register-expr part) + expr)) + (let ((reg (math-rwcomp-reg))) + (math-rwcomp-instr 'func part 'neg reg) + (math-rwcomp-pattern (nth 1 expr) reg))))) + ((and (eq (car expr) 'calcFunc-apply) + (= (length expr) 3)) + (let ((reg1 (math-rwcomp-reg)) + (reg2 (math-rwcomp-reg))) + (math-rwcomp-instr 'apply part reg1 reg2) + (math-rwcomp-pattern (nth 1 expr) reg1) + (math-rwcomp-pattern (nth 2 expr) reg2))) + ((and (eq (car expr) 'calcFunc-cons) + (= (length expr) 3)) + (let ((reg1 (math-rwcomp-reg)) + (reg2 (math-rwcomp-reg))) + (math-rwcomp-instr 'cons part reg1 reg2) + (math-rwcomp-pattern (nth 1 expr) reg1) + (math-rwcomp-pattern (nth 2 expr) reg2))) + ((and (eq (car expr) 'calcFunc-rcons) + (= (length expr) 3)) + (let ((reg1 (math-rwcomp-reg)) + (reg2 (math-rwcomp-reg))) + (math-rwcomp-instr 'rcons part reg1 reg2) + (math-rwcomp-pattern (nth 1 expr) reg1) + (math-rwcomp-pattern (nth 2 expr) reg2))) + ((and (eq (car expr) 'calcFunc-condition) + (>= (length expr) 3)) + (math-rwcomp-pattern (nth 1 expr) part) + (setq expr (cdr expr)) + (while (setq expr (cdr expr)) + (let ((cond (math-flatten-lands (car expr)))) + (while cond + (if (math-rwcomp-all-regs-done (car cond)) + (math-rwcomp-cond-instr (car cond)) + (setq math-conds (cons (car cond) math-conds))) + (setq cond (cdr cond)))))) + ((and (eq (car expr) 'calcFunc-pand) + (= (length expr) 3)) + (math-rwcomp-pattern (nth 1 expr) part) + (math-rwcomp-pattern (nth 2 expr) part)) + ((and (eq (car expr) 'calcFunc-por) + (= (length expr) 3)) + (math-rwcomp-instr 'alt nil nil [nil nil 4]) + (let ((math-conds nil) + (head math-prog-last) + (mark math-bound-vars) + (math-copy-neg t)) + (math-rwcomp-pattern (nth 1 expr) part t) + (let ((amark math-aliased-vars) + (math-aliased-vars math-aliased-vars) + (tail math-prog-last) + (p math-bound-vars) + entry) + (while (not (eq p mark)) + (setq entry (assq (car p) math-regs) + math-aliased-vars (cons (list (car p) (nth 1 entry) nil) + math-aliased-vars) + p (cdr p)) + (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil)) + (setcar (cdr (car head)) (cdr head)) + (setcdr head nil) + (setq math-prog-last head) + (math-rwcomp-pattern (nth 2 expr) part) + (math-rwcomp-instr 'same 0 0) + (setcdr tail math-prog-last) + (setq p math-aliased-vars) + (while (not (eq p amark)) + (if (car (car p)) + (setcar (math-rwcomp-reg-entry (nth 1 (car p))) + (car (car p)))) + (setq p (cdr p))))) + (math-rwcomp-do-conditions)) + ((and (eq (car expr) 'calcFunc-pnot) + (= (length expr) 2)) + (math-rwcomp-instr 'alt nil nil [nil nil 4]) + (let ((head math-prog-last) + (mark math-bound-vars)) + (math-rwcomp-pattern (nth 1 expr) part) + (math-rwcomp-unbind-vars mark) + (math-rwcomp-instr 'end-alt head) + (math-rwcomp-instr 'backtrack) + (setcar (cdr (car head)) (cdr head)) + (setcdr head nil) + (setq math-prog-last head))) + (t (let ((props (get (car expr) 'math-rewrite-props))) + (if (and (eq (car expr) 'calcFunc-plain) + (= (length expr) 2) + (not (math-primp (nth 1 expr)))) + (setq expr (nth 1 expr))) ; but "props" is still nil + (if (and (memq 'algebraic props) + (math-rwcomp-is-algebraic expr)) + (math-rwcomp-cond-instr (list 'calcFunc-eq + (math-rwcomp-register-expr part) + expr)) + (if (and (memq 'commut props) + (= (length expr) 3)) + (let ((arg1 (nth 1 expr)) + (arg2 (nth 2 expr)) + try1 def code head (flip nil)) + (if (eq (car expr) '-) + (setq arg2 (math-rwcomp-neg arg2))) + (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1)) + arg2 (cons arg2 (math-rwcomp-best-reg arg2))) + (or (math-rwcomp-order arg1 arg2) + (setq def arg1 arg1 arg2 arg2 def flip t)) + (if (math-rwcomp-optional-arg (car expr) arg1) + (error "Too many opt( ) arguments in this context")) + (setq def (math-rwcomp-optional-arg (car expr) arg2) + head (if (memq (car expr) '(+ -)) + '(+ -) + (if (eq (car expr) '*) + '(* /) + (list (car expr)))) + code (if (math-rwcomp-is-constrained + (car arg1) head) + (if (math-rwcomp-is-constrained + (car arg2) head) + 0 1) + 2)) + (math-rwcomp-multi-instr (and def (list def)) + 'try part head + (vector nil nil nil code flip) + (cdr arg1)) + (setq try1 (car math-prog-last)) + (math-rwcomp-pattern (car arg1) (cdr arg1)) + (math-rwcomp-instr 'try2 try1 (cdr arg2)) + (if (and (= part 0) (not def) (not math-rewrite-whole) + (not (eq math-rhs t)) + (setq def (get (car expr) + 'math-rewrite-default))) + (let ((reg1 (math-rwcomp-reg)) + (reg2 (math-rwcomp-reg))) + (if (= (aref (nth 3 try1) 3) 0) + (aset (nth 3 try1) 3 1)) + (math-rwcomp-instr 'try (cdr arg2) + (if (equal head '(* /)) + '(*) head) + (vector nil nil nil + (if (= code 0) + 1 2) + nil) + reg1 def) + (setq try1 (car math-prog-last)) + (math-rwcomp-pattern (car arg2) reg1) + (math-rwcomp-instr 'try2 try1 reg2) + (setq math-rhs (list (if (eq (car expr) '-) + '+ (car expr)) + math-rhs + (list 'calcFunc-register + reg2)))) + (math-rwcomp-pattern (car arg2) (cdr arg2)))) + (let* ((args (mapcar (function + (lambda (x) + (cons x (math-rwcomp-best-reg x)))) + (cdr expr))) + (args2 (copy-sequence args)) + (argp (reverse args2)) + (defs nil) + (num 1)) + (while argp + (let ((def (math-rwcomp-optional-arg (car expr) + (car argp)))) + (if def + (progn + (setq args2 (delq (car argp) args2) + defs (cons (cons def (cdr (car argp))) + defs)) + (math-rwcomp-multi-instr + (mapcar 'cdr args2) + (if (or (and (memq 'unary1 props) + (= (length args2) 1) + (eq (car args2) (car args))) + (and (memq 'unary2 props) + (= (length args) 2) + (eq (car args2) (nth 1 args)))) + 'func-opt + 'func-def) + part (car expr) + defs)))) + (setq argp (cdr argp))) + (math-rwcomp-multi-instr (mapcar 'cdr args) + 'func part (car expr)) + (setq args (sort args 'math-rwcomp-order)) + (while args + (math-rwcomp-pattern (car (car args)) (cdr (car args))) + (setq num (1+ num) + args (cdr args))))))))) +) + +(defun math-rwcomp-best-reg (x) + (or (and (eq (car-safe x) 'var) + (let ((entry (assq (nth 2 x) math-aliased-vars))) + (and entry + (not (nth 2 entry)) + (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry)))) + (progn + (setcar (cdr (cdr entry)) t) + (nth 1 entry))))) + (math-rwcomp-reg)) +) + +(defun math-rwcomp-all-regs-done (expr) + (if (Math-primp expr) + (or (not (eq (car-safe expr) 'var)) + (assq (nth 2 expr) math-regs) + (eq (nth 2 expr) 'var-remember) + (math-const-var expr)) + (if (and (eq (car expr) 'calcFunc-let) + (= (length expr) 3)) + (math-rwcomp-all-regs-done (nth 2 expr)) + (if (and (eq (car expr) 'calcFunc-let) + (= (length expr) 2) + (eq (car-safe (nth 1 expr)) 'calcFunc-assign) + (= (length (nth 1 expr)) 3)) + (math-rwcomp-all-regs-done (nth 2 (nth 1 expr))) + (while (and (setq expr (cdr expr)) + (math-rwcomp-all-regs-done (car expr)))) + (null expr)))) +) + +(defun math-rwcomp-no-vars (expr) + (if (Math-primp expr) + (or (not (eq (car-safe expr) 'var)) + (math-const-var expr)) + (and (not (memq (car expr) '(calcFunc-condition + calcFunc-select calcFunc-quote + calcFunc-plain calcFunc-opt + calcFunc-por calcFunc-pand + calcFunc-pnot calcFunc-apply + calcFunc-cons calcFunc-rcons))) + (progn + (while (and (setq expr (cdr expr)) + (math-rwcomp-no-vars (car expr)))) + (null expr)))) +) + +(defun math-rwcomp-is-algebraic (expr) + (if (Math-primp expr) + (or (not (eq (car-safe expr) 'var)) + (math-const-var expr) + (assq (nth 2 expr) math-regs)) + (and (memq 'algebraic (get (car expr) 'math-rewrite-props)) + (progn + (while (and (setq expr (cdr expr)) + (math-rwcomp-is-algebraic (car expr)))) + (null expr)))) +) + +(defun math-rwcomp-is-constrained (expr not-these) + (if (Math-primp expr) + (not (eq (car-safe expr) 'var)) + (if (eq (car expr) 'calcFunc-plain) + (math-rwcomp-is-constrained (nth 1 expr) not-these) + (not (or (memq (car expr) '(neg calcFunc-select)) + (memq (car expr) not-these) + (and (memq 'commut (get (car expr) 'math-rewrite-props)) + (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt) + (eq (car-safe (nth 2 expr)) 'calcFunc-opt))))))) +) + +(defun math-rwcomp-optional-arg (head argp) + (let ((arg (car argp))) + (if (eq (car-safe arg) 'calcFunc-opt) + (and (memq (length arg) '(2 3)) + (progn + (or (eq (car-safe (nth 1 arg)) 'var) + (error "First argument of opt( ) must be a variable")) + (setcar argp (nth 1 arg)) + (if (= (length arg) 2) + (or (get head 'math-rewrite-default) + (error "opt( ) must include a default in this context")) + (nth 2 arg)))) + (and (eq (car-safe arg) 'neg) + (let* ((part (list (nth 1 arg))) + (partp (math-rwcomp-optional-arg head part))) + (and partp + (setcar argp (math-rwcomp-neg (car part))) + (math-neg partp)))))) +) + +(defun math-rwcomp-neg (expr) + (if (memq (car-safe expr) '(* /)) + (if (eq (car-safe (nth 1 expr)) 'var) + (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr)) + (if (eq (car-safe (nth 2 expr)) 'var) + (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr))) + (math-neg expr))) + (math-neg expr)) +) + +(defun math-rwcomp-assoc-args (expr) + (if (and (eq (car-safe (nth 1 expr)) (car expr)) + (= (length (nth 1 expr)) 3)) + (math-rwcomp-assoc-args (nth 1 expr)) + (setq math-args (cons (nth 1 expr) math-args))) + (if (and (eq (car-safe (nth 2 expr)) (car expr)) + (= (length (nth 2 expr)) 3)) + (math-rwcomp-assoc-args (nth 2 expr)) + (setq math-args (cons (nth 2 expr) math-args))) +) + +(defun math-rwcomp-addsub-args (expr) + (if (memq (car-safe (nth 1 expr)) '(+ -)) + (math-rwcomp-addsub-args (nth 1 expr)) + (setq math-args (cons (nth 1 expr) math-args))) + (if (eq (car expr) '-) + (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args)) + (if (eq (car-safe (nth 2 expr)) '+) + (math-rwcomp-addsub-args (nth 2 expr)) + (setq math-args (cons (nth 2 expr) math-args)))) +) + +(defun math-rwcomp-order (a b) + (< (math-rwcomp-priority (car a)) + (math-rwcomp-priority (car b))) +) + +;;; Order of priority: 0 Constants and other exact matches (first) +;;; 10 Functions (except below) +;;; 20 Meta-variables which occur more than once +;;; 30 Algebraic functions +;;; 40 Commutative/associative functions +;;; 50 Meta-variables which occur only once +;;; +100 for every "!!!" (pnot) in the pattern +;;; 10000 Optional arguments (last) + +(defun math-rwcomp-priority (expr) + (+ (math-rwcomp-count-pnots expr) + (cond ((eq (car-safe expr) 'calcFunc-opt) + 10000) + ((math-rwcomp-no-vars expr) + 0) + ((eq (car expr) 'calcFunc-quote) + 0) + ((eq (car expr) 'var) + (if (assq (nth 2 expr) math-regs) + 0 + (if (= (math-rwcomp-count-refs expr) 1) + 50 + 20))) + (t (let ((props (get (car expr) 'math-rewrite-props))) + (if (or (memq 'commut props) + (memq 'assoc props)) + 40 + (if (memq 'algebraic props) + 30 + 10)))))) +) + +(defun math-rwcomp-count-refs (var) + (let ((count (or (math-expr-contains-count math-pattern var) 0)) + (p math-conds)) + (while p + (if (eq (car-safe (car p)) 'calcFunc-let) + (if (= (length (car p)) 3) + (setq count (+ count + (or (math-expr-contains-count (nth 2 (car p)) var) + 0))) + (if (and (= (length (car p)) 2) + (eq (car-safe (nth 1 (car p))) 'calcFunc-assign) + (= (length (nth 1 (car p))) 3)) + (setq count (+ count + (or (math-expr-contains-count + (nth 2 (nth 1 (car p))) var) 0)))))) + (setq p (cdr p))) + count) +) + +(defun math-rwcomp-count-pnots (expr) + (if (Math-primp expr) + 0 + (if (eq (car expr) 'calcFunc-pnot) + 100 + (let ((count 0)) + (while (setq expr (cdr expr)) + (setq count (+ count (math-rwcomp-count-pnots (car expr))))) + count))) +) + +;;; In the current implementation, all associative functions must +;;; also be commutative. + +(put '+ 'math-rewrite-props '(algebraic assoc commut)) +(put '- 'math-rewrite-props '(algebraic assoc commut)) ; see below +(put '* 'math-rewrite-props '(algebraic assoc commut)) ; see below +(put '/ 'math-rewrite-props '(algebraic unary1)) +(put '^ 'math-rewrite-props '(algebraic unary1)) +(put '% 'math-rewrite-props '(algebraic)) +(put 'neg 'math-rewrite-props '(algebraic)) +(put 'calcFunc-idiv 'math-rewrite-props '(algebraic)) +(put 'calcFunc-abs 'math-rewrite-props '(algebraic)) +(put 'calcFunc-sign 'math-rewrite-props '(algebraic)) +(put 'calcFunc-round 'math-rewrite-props '(algebraic)) +(put 'calcFunc-rounde 'math-rewrite-props '(algebraic)) +(put 'calcFunc-roundu 'math-rewrite-props '(algebraic)) +(put 'calcFunc-trunc 'math-rewrite-props '(algebraic)) +(put 'calcFunc-floor 'math-rewrite-props '(algebraic)) +(put 'calcFunc-ceil 'math-rewrite-props '(algebraic)) +(put 'calcFunc-re 'math-rewrite-props '(algebraic)) +(put 'calcFunc-im 'math-rewrite-props '(algebraic)) +(put 'calcFunc-conj 'math-rewrite-props '(algebraic)) +(put 'calcFunc-arg 'math-rewrite-props '(algebraic)) +(put 'calcFunc-and 'math-rewrite-props '(assoc commut)) +(put 'calcFunc-or 'math-rewrite-props '(assoc commut)) +(put 'calcFunc-xor 'math-rewrite-props '(assoc commut)) +(put 'calcFunc-eq 'math-rewrite-props '(commut)) +(put 'calcFunc-neq 'math-rewrite-props '(commut)) +(put 'calcFunc-land 'math-rewrite-props '(assoc commut)) +(put 'calcFunc-lor 'math-rewrite-props '(assoc commut)) +(put 'calcFunc-beta 'math-rewrite-props '(commut)) +(put 'calcFunc-gcd 'math-rewrite-props '(assoc commut)) +(put 'calcFunc-lcm 'math-rewrite-props '(assoc commut)) +(put 'calcFunc-max 'math-rewrite-props '(algebraic assoc commut)) +(put 'calcFunc-min 'math-rewrite-props '(algebraic assoc commut)) +(put 'calcFunc-vunion 'math-rewrite-props '(assoc commut)) +(put 'calcFunc-vint 'math-rewrite-props '(assoc commut)) +(put 'calcFunc-vxor 'math-rewrite-props '(assoc commut)) + +;;; Note: "*" is not commutative for matrix args, but we pretend it is. +;;; Also, "-" is not commutative but the code tweaks things so that it is. + +(put '+ 'math-rewrite-default 0) +(put '- 'math-rewrite-default 0) +(put '* 'math-rewrite-default 1) +(put '/ 'math-rewrite-default 1) +(put '^ 'math-rewrite-default 1) +(put 'calcFunc-land 'math-rewrite-default 1) +(put 'calcFunc-lor 'math-rewrite-default 0) +(put 'calcFunc-vunion 'math-rewrite-default '(vec)) +(put 'calcFunc-vint 'math-rewrite-default '(vec)) +(put 'calcFunc-vdiff 'math-rewrite-default '(vec)) +(put 'calcFunc-vxor 'math-rewrite-default '(vec)) + +(defmacro math-rwfail (&optional back) + (list 'setq 'pc + (list 'and + (if back + '(setq btrack (cdr btrack)) + 'btrack) + ''((backtrack)))) +) + +;;; This monstrosity is necessary because the use of static vectors of +;;; registers makes rewrite rules non-reentrant. Yucko! +(defmacro math-rweval (form) + (list 'let '((orig (car rules))) + '(setcar rules (quote (nil nil nil no-phase))) + (list 'unwind-protect + form + '(setcar rules orig))) +) + +(setq math-rewrite-phase 1) + +(defun math-apply-rewrites (expr rules &optional heads ruleset) + (and + (setq rules (cdr (or (assq (car-safe expr) rules) + (assq nil rules)))) + (let ((result nil) + op regs inst part pc mark btrack + (tracing math-rwcomp-tracing) + (phase math-rewrite-phase)) + (while rules + (or + (and (setq part (nth 2 (car rules))) + heads + (not (memq part heads))) + (and (setq part (nth 3 (car rules))) + (not (memq phase part))) + (progn + (setq regs (car (car rules)) + pc (nth 1 (car rules)) + btrack nil) + (aset regs 0 expr) + (while pc + + (and tracing + (progn (terpri) (princ (car pc)) + (if (and (natnump (nth 1 (car pc))) + (< (nth 1 (car pc)) (length regs))) + (princ (format "\n part = %s" + (aref regs (nth 1 (car pc)))))))) + + (cond ((eq (setq op (car (setq inst (car pc)))) 'func) + (if (and (consp (setq part (aref regs (car (cdr inst))))) + (eq (car part) + (car (setq inst (cdr (cdr inst))))) + (progn + (while (and (setq inst (cdr inst) + part (cdr part)) + inst) + (aset regs (car inst) (car part))) + (not (or inst part)))) + (setq pc (cdr pc)) + (math-rwfail))) + + ((eq op 'same) + (if (or (equal (setq part (aref regs (nth 1 inst))) + (setq mark (aref regs (nth 2 inst)))) + (Math-equal part mark)) + (setq pc (cdr pc)) + (math-rwfail))) + + ((and (eq op 'try) + calc-matrix-mode + (not (eq calc-matrix-mode 'scalar)) + (eq (car (nth 2 inst)) '*) + (consp (setq part (aref regs (car (cdr inst))))) + (eq (car part) '*) + (not (math-known-scalarp part))) + (setq mark (nth 3 inst) + pc (cdr pc)) + (if (aref mark 4) + (progn + (aset regs (nth 4 inst) (nth 2 part)) + (aset mark 1 (cdr (cdr part)))) + (aset regs (nth 4 inst) (nth 1 part)) + (aset mark 1 (cdr part))) + (aset mark 0 (cdr part)) + (aset mark 2 0)) + + ((eq op 'try) + (if (and (consp (setq part (aref regs (car (cdr inst))))) + (memq (car part) (nth 2 inst)) + (= (length part) 3) + (or (not (eq (car part) '/)) + (Math-objectp (nth 2 part)))) + (progn + (setq op nil + mark (car (cdr (setq inst (cdr (cdr inst)))))) + (and + (memq 'assoc (get (car part) 'math-rewrite-props)) + (not (= (aref mark 3) 0)) + (while (if (and (consp (nth 1 part)) + (memq (car (nth 1 part)) (car inst))) + (setq op (cons (if (eq (car part) '-) + (math-rwapply-neg + (nth 2 part)) + (nth 2 part)) + op) + part (nth 1 part)) + (if (and (consp (nth 2 part)) + (memq (car (nth 2 part)) + (car inst)) + (not (eq (car (nth 2 part)) '-))) + (setq op (cons (nth 1 part) op) + part (nth 2 part)))))) + (setq op (cons (nth 1 part) + (cons (if (eq (car part) '-) + (math-rwapply-neg + (nth 2 part)) + (if (eq (car part) '/) + (math-rwapply-inv + (nth 2 part)) + (nth 2 part))) + op)) + btrack (cons pc btrack) + pc (cdr pc)) + (aset regs (nth 2 inst) (car op)) + (aset mark 0 op) + (aset mark 1 op) + (aset mark 2 (if (cdr (cdr op)) 1 0))) + (if (nth 5 inst) + (if (and (consp part) + (eq (car part) 'neg) + (eq (car (nth 2 inst)) '*) + (eq (nth 5 inst) 1)) + (progn + (setq mark (nth 3 inst) + pc (cdr pc)) + (aset regs (nth 4 inst) (nth 1 part)) + (aset mark 1 -1) + (aset mark 2 4)) + (setq mark (nth 3 inst) + pc (cdr pc)) + (aset regs (nth 4 inst) part) + (aset mark 2 3)) + (math-rwfail)))) + + ((eq op 'try2) + (setq part (nth 1 inst) ; try instr + mark (nth 3 part) + op (aref mark 2) + pc (cdr pc)) + (aset regs (nth 2 inst) + (cond + ((eq op 0) + (if (eq (aref mark 0) (aref mark 1)) + (nth 1 (aref mark 0)) + (car (aref mark 0)))) + ((eq op 1) + (setq mark (delq (car (aref mark 1)) + (copy-sequence (aref mark 0))) + op (car (nth 2 part))) + (if (eq op '*) + (progn + (setq mark (nreverse mark) + part (list '* (nth 1 mark) (car mark)) + mark (cdr mark)) + (while (setq mark (cdr mark)) + (setq part (list '* (car mark) part)))) + (setq part (car mark) + mark (cdr mark) + part (if (and (eq op '+) + (consp (car mark)) + (eq (car (car mark)) 'neg)) + (list '- part + (nth 1 (car mark))) + (list op part (car mark)))) + (while (setq mark (cdr mark)) + (setq part (if (and (eq op '+) + (consp (car mark)) + (eq (car (car mark)) 'neg)) + (list '- part + (nth 1 (car mark))) + (list op part (car mark)))))) + part) + ((eq op 2) + (car (aref mark 1))) + ((eq op 3) (nth 5 part)) + (t (aref mark 1))))) + + ((eq op 'select) + (setq pc (cdr pc)) + (if (and (consp (setq part (aref regs (nth 1 inst)))) + (eq (car part) 'calcFunc-select)) + (aset regs (nth 2 inst) (nth 1 part)) + (if math-rewrite-selections + (math-rwfail) + (aset regs (nth 2 inst) part)))) + + ((eq op 'same-neg) + (if (or (equal (setq part (aref regs (nth 1 inst))) + (setq mark (math-neg + (aref regs (nth 2 inst))))) + (Math-equal part mark)) + (setq pc (cdr pc)) + (math-rwfail))) + + ((eq op 'backtrack) + (setq inst (car (car btrack)) ; "try" or "alt" instr + pc (cdr (car btrack)) + mark (or (nth 3 inst) [nil nil 4]) + op (aref mark 2)) + (cond ((eq op 0) + (if (setq op (cdr (aref mark 1))) + (aset regs (nth 4 inst) (car (aset mark 1 op))) + (if (nth 5 inst) + (progn + (aset mark 2 3) + (aset regs (nth 4 inst) + (aref regs (nth 1 inst)))) + (math-rwfail t)))) + ((eq op 1) + (if (setq op (cdr (aref mark 1))) + (aset regs (nth 4 inst) (car (aset mark 1 op))) + (if (= (aref mark 3) 1) + (if (nth 5 inst) + (progn + (aset mark 2 3) + (aset regs (nth 4 inst) + (aref regs (nth 1 inst)))) + (math-rwfail t)) + (aset mark 2 2) + (aset mark 1 (cons nil (aref mark 0))) + (math-rwfail)))) + ((eq op 2) + (if (setq op (cdr (aref mark 1))) + (progn + (setq mark (delq (car (aset mark 1 op)) + (copy-sequence + (aref mark 0))) + op (car (nth 2 inst))) + (if (eq op '*) + (progn + (setq mark (nreverse mark) + part (list '* (nth 1 mark) + (car mark)) + mark (cdr mark)) + (while (setq mark (cdr mark)) + (setq part (list '* (car mark) + part)))) + (setq part (car mark) + mark (cdr mark) + part (if (and (eq op '+) + (consp (car mark)) + (eq (car (car mark)) + 'neg)) + (list '- part + (nth 1 (car mark))) + (list op part (car mark)))) + (while (setq mark (cdr mark)) + (setq part (if (and (eq op '+) + (consp (car mark)) + (eq (car (car mark)) + 'neg)) + (list '- part + (nth 1 (car mark))) + (list op part (car mark)))))) + (aset regs (nth 4 inst) part)) + (if (nth 5 inst) + (progn + (aset mark 2 3) + (aset regs (nth 4 inst) + (aref regs (nth 1 inst)))) + (math-rwfail t)))) + ((eq op 4) + (setq btrack (cdr btrack))) + (t (math-rwfail t)))) + + ((eq op 'integer) + (if (Math-integerp (setq part (aref regs (nth 1 inst)))) + (setq pc (cdr pc)) + (if (Math-primp part) + (math-rwfail) + (setq part (math-rweval (math-simplify part))) + (if (Math-integerp part) + (setq pc (cdr pc)) + (math-rwfail))))) + + ((eq op 'real) + (if (Math-realp (setq part (aref regs (nth 1 inst)))) + (setq pc (cdr pc)) + (if (Math-primp part) + (math-rwfail) + (setq part (math-rweval (math-simplify part))) + (if (Math-realp part) + (setq pc (cdr pc)) + (math-rwfail))))) + + ((eq op 'constant) + (if (math-constp (setq part (aref regs (nth 1 inst)))) + (setq pc (cdr pc)) + (if (Math-primp part) + (math-rwfail) + (setq part (math-rweval (math-simplify part))) + (if (math-constp part) + (setq pc (cdr pc)) + (math-rwfail))))) + + ((eq op 'negative) + (if (math-looks-negp (setq part (aref regs (nth 1 inst)))) + (setq pc (cdr pc)) + (if (Math-primp part) + (math-rwfail) + (setq part (math-rweval (math-simplify part))) + (if (math-looks-negp part) + (setq pc (cdr pc)) + (math-rwfail))))) + + ((eq op 'rel) + (setq part (math-compare (aref regs (nth 1 inst)) + (aref regs (nth 3 inst))) + op (nth 2 inst)) + (if (= part 2) + (setq part (math-rweval + (math-simplify + (calcFunc-sign + (math-sub (aref regs (nth 1 inst)) + (aref regs (nth 3 inst)))))))) + (if (cond ((eq op 'calcFunc-eq) + (eq part 0)) + ((eq op 'calcFunc-neq) + (memq part '(-1 1))) + ((eq op 'calcFunc-lt) + (eq part -1)) + ((eq op 'calcFunc-leq) + (memq part '(-1 0))) + ((eq op 'calcFunc-gt) + (eq part 1)) + ((eq op 'calcFunc-geq) + (memq part '(0 1)))) + (setq pc (cdr pc)) + (math-rwfail))) + + ((eq op 'func-def) + (if (and (consp (setq part (aref regs (car (cdr inst))))) + (eq (car part) + (car (setq inst (cdr (cdr inst)))))) + (progn + (setq inst (cdr inst) + mark (car inst)) + (while (and (setq inst (cdr inst) + part (cdr part)) + inst) + (aset regs (car inst) (car part))) + (if (or inst part) + (setq pc (cdr pc)) + (while (eq (car (car (setq pc (cdr pc)))) + 'func-def)) + (setq pc (cdr pc)) ; skip over "func" + (while mark + (aset regs (cdr (car mark)) (car (car mark))) + (setq mark (cdr mark))))) + (math-rwfail))) + + ((eq op 'func-opt) + (if (or (not (and (consp + (setq part (aref regs (car (cdr inst))))) + (eq (car part) (nth 2 inst)))) + (and (= (length part) 2) + (setq part (nth 1 part)))) + (progn + (setq mark (nth 3 inst)) + (aset regs (nth 4 inst) part) + (while (eq (car (car (setq pc (cdr pc)))) 'func-def)) + (setq pc (cdr pc)) ; skip over "func" + (while mark + (aset regs (cdr (car mark)) (car (car mark))) + (setq mark (cdr mark)))) + (setq pc (cdr pc)))) + + ((eq op 'mod) + (if (if (Math-zerop (setq part (aref regs (nth 1 inst)))) + (Math-zerop (nth 3 inst)) + (and (not (Math-zerop (nth 2 inst))) + (progn + (setq part (math-mod part (nth 2 inst))) + (or (Math-numberp part) + (setq part (math-rweval + (math-simplify part)))) + (Math-equal part (nth 3 inst))))) + (setq pc (cdr pc)) + (math-rwfail))) + + ((eq op 'apply) + (if (and (consp (setq part (aref regs (car (cdr inst))))) + (not (Math-objvecp part)) + (not (eq (car part) 'var))) + (progn + (aset regs (nth 2 inst) + (math-calcFunc-to-var (car part))) + (aset regs (nth 3 inst) + (cons 'vec (cdr part))) + (setq pc (cdr pc))) + (math-rwfail))) + + ((eq op 'cons) + (if (and (consp (setq part (aref regs (car (cdr inst))))) + (eq (car part) 'vec) + (cdr part)) + (progn + (aset regs (nth 2 inst) (nth 1 part)) + (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part)))) + (setq pc (cdr pc))) + (math-rwfail))) + + ((eq op 'rcons) + (if (and (consp (setq part (aref regs (car (cdr inst))))) + (eq (car part) 'vec) + (cdr part)) + (progn + (aset regs (nth 2 inst) (calcFunc-rhead part)) + (aset regs (nth 3 inst) (calcFunc-rtail part)) + (setq pc (cdr pc))) + (math-rwfail))) + + ((eq op 'cond) + (if (math-is-true + (math-rweval + (math-simplify + (math-rwapply-replace-regs (nth 1 inst))))) + (setq pc (cdr pc)) + (math-rwfail))) + + ((eq op 'let) + (aset regs (nth 1 inst) + (math-rweval + (math-normalize + (math-rwapply-replace-regs (nth 2 inst))))) + (setq pc (cdr pc))) + + ((eq op 'copy) + (aset regs (nth 2 inst) (aref regs (nth 1 inst))) + (setq pc (cdr pc))) + + ((eq op 'copy-neg) + (aset regs (nth 2 inst) + (math-rwapply-neg (aref regs (nth 1 inst)))) + (setq pc (cdr pc))) + + ((eq op 'alt) + (setq btrack (cons pc btrack) + pc (nth 1 inst))) + + ((eq op 'end-alt) + (while (and btrack (not (eq (car btrack) (nth 1 inst)))) + (setq btrack (cdr btrack))) + (setq btrack (cdr btrack) + pc (cdr pc))) + + ((eq op 'done) + (setq result (math-rwapply-replace-regs (nth 1 inst))) + (if (or (and (eq (car-safe result) '+) + (eq (nth 2 result) 0)) + (and (eq (car-safe result) '*) + (eq (nth 2 result) 1))) + (setq result (nth 1 result))) + (setq part (and (nth 2 inst) + (math-is-true + (math-rweval + (math-simplify + (math-rwapply-replace-regs + (nth 2 inst))))))) + (if (or (equal result expr) + (equal (setq result (math-normalize result)) expr)) + (setq result nil) + (if part (math-rwapply-remember expr result)) + (setq rules nil)) + (setq pc nil)) + + (t (error "%s is not a valid rewrite opcode" op)))))) + (setq rules (cdr rules))) + result)) +) + +(defun math-rwapply-neg (expr) + (if (and (consp expr) + (memq (car expr) '(* /))) + (if (Math-objectp (nth 2 expr)) + (list (car expr) (nth 1 expr) (math-neg (nth 2 expr))) + (list (car expr) + (if (Math-objectp (nth 1 expr)) + (math-neg (nth 1 expr)) + (list '* -1 (nth 1 expr))) + (nth 2 expr))) + (math-neg expr)) +) + +(defun math-rwapply-inv (expr) + (if (and (Math-integerp expr) + calc-prefer-frac) + (math-make-frac 1 expr) + (list '/ 1 expr)) +) + +(defun math-rwapply-replace-regs (expr) + (cond ((Math-primp expr) + expr) + ((eq (car expr) 'calcFunc-register) + (setq expr (aref regs (nth 1 expr))) + (if (eq (car-safe expr) '*) + (if (eq (nth 1 expr) -1) + (math-neg (nth 2 expr)) + (if (eq (nth 1 expr) 1) + (nth 2 expr) + expr)) + expr)) + ((and (eq (car expr) 'calcFunc-eval) + (= (length expr) 2)) + (calc-with-default-simplification + (math-normalize (math-rwapply-replace-regs (nth 1 expr))))) + ((and (eq (car expr) 'calcFunc-evalsimp) + (= (length expr) 2)) + (math-simplify (math-rwapply-replace-regs (nth 1 expr)))) + ((and (eq (car expr) 'calcFunc-evalextsimp) + (= (length expr) 2)) + (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr)))) + ((and (eq (car expr) 'calcFunc-apply) + (= (length expr) 3)) + (let ((func (math-rwapply-replace-regs (nth 1 expr))) + (args (math-rwapply-replace-regs (nth 2 expr))) + call) + (if (and (math-vectorp args) + (not (eq (car-safe (setq call (math-build-call + (math-var-to-calcFunc func) + (cdr args)))) + 'calcFunc-call))) + call + (list 'calcFunc-apply func args)))) + ((and (eq (car expr) 'calcFunc-cons) + (= (length expr) 3)) + (let ((head (math-rwapply-replace-regs (nth 1 expr))) + (tail (math-rwapply-replace-regs (nth 2 expr)))) + (if (math-vectorp tail) + (cons 'vec (cons head (cdr tail))) + (list 'calcFunc-cons head tail)))) + ((and (eq (car expr) 'calcFunc-rcons) + (= (length expr) 3)) + (let ((head (math-rwapply-replace-regs (nth 1 expr))) + (tail (math-rwapply-replace-regs (nth 2 expr)))) + (if (math-vectorp head) + (append head (list tail)) + (list 'calcFunc-rcons head tail)))) + ((and (eq (car expr) 'neg) + (math-rwapply-reg-looks-negp (nth 1 expr))) + (math-rwapply-reg-neg (nth 1 expr))) + ((and (eq (car expr) 'neg) + (eq (car-safe (nth 1 expr)) 'calcFunc-register) + (math-scalarp (aref regs (nth 1 (nth 1 expr))))) + (math-neg (math-rwapply-replace-regs (nth 1 expr)))) + ((and (eq (car expr) '+) + (math-rwapply-reg-looks-negp (nth 1 expr))) + (list '- (math-rwapply-replace-regs (nth 2 expr)) + (math-rwapply-reg-neg (nth 1 expr)))) + ((and (eq (car expr) '+) + (math-rwapply-reg-looks-negp (nth 2 expr))) + (list '- (math-rwapply-replace-regs (nth 1 expr)) + (math-rwapply-reg-neg (nth 2 expr)))) + ((and (eq (car expr) '-) + (math-rwapply-reg-looks-negp (nth 2 expr))) + (list '+ (math-rwapply-replace-regs (nth 1 expr)) + (math-rwapply-reg-neg (nth 2 expr)))) + ((eq (car expr) '*) + (cond ((eq (nth 1 expr) -1) + (if (math-rwapply-reg-looks-negp (nth 2 expr)) + (math-rwapply-reg-neg (nth 2 expr)) + (math-neg (math-rwapply-replace-regs (nth 2 expr))))) + ((eq (nth 1 expr) 1) + (math-rwapply-replace-regs (nth 2 expr))) + ((eq (nth 2 expr) -1) + (if (math-rwapply-reg-looks-negp (nth 1 expr)) + (math-rwapply-reg-neg (nth 1 expr)) + (math-neg (math-rwapply-replace-regs (nth 1 expr))))) + ((eq (nth 2 expr) 1) + (math-rwapply-replace-regs (nth 1 expr))) + (t + (let ((arg1 (math-rwapply-replace-regs (nth 1 expr))) + (arg2 (math-rwapply-replace-regs (nth 2 expr)))) + (cond ((and (eq (car-safe arg1) '/) + (eq (nth 1 arg1) 1)) + (list '/ arg2 (nth 2 arg1))) + ((and (eq (car-safe arg2) '/) + (eq (nth 1 arg2) 1)) + (list '/ arg1 (nth 2 arg2))) + (t (list '* arg1 arg2))))))) + ((eq (car expr) '/) + (let ((arg1 (math-rwapply-replace-regs (nth 1 expr))) + (arg2 (math-rwapply-replace-regs (nth 2 expr)))) + (if (eq (car-safe arg2) '/) + (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2)) + (list '/ arg1 arg2)))) + ((and (eq (car expr) 'calcFunc-plain) + (= (length expr) 2)) + (if (Math-primp (nth 1 expr)) + (nth 1 expr) + (if (eq (car (nth 1 expr)) 'calcFunc-register) + (aref regs (nth 1 (nth 1 expr))) + (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs + (cdr (nth 1 expr))))))) + (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr))))) +) + +(defun math-rwapply-reg-looks-negp (expr) + (if (eq (car-safe expr) 'calcFunc-register) + (math-looks-negp (aref regs (nth 1 expr))) + (if (memq (car-safe expr) '(* /)) + (or (math-rwapply-reg-looks-negp (nth 1 expr)) + (math-rwapply-reg-looks-negp (nth 2 expr))))) +) + +(defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp + (if (eq (car expr) 'calcFunc-register) + (math-neg (math-rwapply-replace-regs expr)) + (if (math-rwapply-reg-looks-negp (nth 1 expr)) + (math-rwapply-replace-regs (list (car expr) + (math-rwapply-reg-neg (nth 1 expr)) + (nth 2 expr))) + (math-rwapply-replace-regs (list (car expr) + (nth 1 expr) + (math-rwapply-reg-neg (nth 2 expr)))))) +) + +(defun math-rwapply-remember (old new) + (let ((varval (symbol-value (nth 2 (car ruleset)))) + (rules (assq (car-safe old) ruleset))) + (if (and (eq (car-safe varval) 'vec) + (not (memq (car-safe old) '(nil schedule + -))) + rules) + (progn + (setcdr varval (cons (list 'calcFunc-assign + (if (math-rwcomp-no-vars old) + old + (list 'calcFunc-quote old)) + new) + (cdr varval))) + (setcdr rules (cons (list (vector nil old) + (list (list 'same 0 1) + (list 'done new nil)) + nil nil) + (cdr rules)))))) +) + + + + diff --git a/lisp/calc/calc-rules.el b/lisp/calc/calc-rules.el new file mode 100644 index 0000000000..b6b3d3c094 --- /dev/null +++ b/lisp/calc/calc-rules.el @@ -0,0 +1,444 @@ +;; Calculator for GNU Emacs, part II [calc-rules.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-rules () nil) + + +(defun calc-compile-rule-set (name rules) + (prog2 + (message "Preparing rule set %s..." name) + (math-read-plain-expr rules t) + (message "Preparing rule set %s...done" name)) +) + +(defun calc-CommuteRules () + "CommuteRules" + (calc-compile-rule-set + "CommuteRules" "[ +iterations(1), +select(plain(a + b)) := select(plain(b + a)), +select(plain(a - b)) := select(plain((-b) + a)), +select(plain((1/a) * b)) := select(b / a), +select(plain(a * b)) := select(b * a), +select((1/a) / b) := select((1/b) / a), +select(a / b) := select((1/b) * a), +select((a^b) ^ c) := select((a^c) ^ b), +select(log(a, b)) := select(1 / log(b, a)), +select(plain(a && b)) := select(b && a), +select(plain(a || b)) := select(b || a), +select(plain(a = b)) := select(b = a), +select(plain(a != b)) := select(b != a), +select(a < b) := select(b > a), +select(a > b) := select(b < a), +select(a <= b) := select(b >= a), +select(a >= b) := select(b <= a) ]") +) + +(defun calc-JumpRules () + "JumpRules" + (calc-compile-rule-set + "JumpRules" "[ +iterations(1), +plain(select(x) = y) := 0 = select(-x) + y, +plain(a + select(x) = y) := a = select(-x) + y, +plain(a - select(x) = y) := a = select(x) + y, +plain(select(x) + a = y) := a = select(-x) + y, +plain(a * select(x) = y) := a = y / select(x), +plain(a / select(x) = y) := a = select(x) * y, +plain(select(x) / a = y) := 1/a = y / select(x), +plain(a ^ select(2) = y) := a = select(sqrt(y)), +plain(a ^ select(x) = y) := a = y ^ select(1/x), +plain(select(x) ^ a = y) := a = log(y, select(x)), +plain(log(a, select(x)) = y) := a = select(x) ^ y, +plain(log(select(x), a) = y) := a = select(x) ^ (1/y), +plain(y = select(x)) := y - select(x) = 0, +plain(y = a + select(x)) := y - select(x) = a, +plain(y = a - select(x)) := y + select(x) = a, +plain(y = select(x) + a) := y - select(x) = a, +plain(y = a * select(x)) := y / select(x) = a, +plain(y = a / select(x)) := y * select(x) = a, +plain(y = select(x) / a) := y / select(x) = 1/a, +plain(y = a ^ select(2)) := select(sqrt(y)) = a, +plain(y = a ^ select(x)) := y ^ select(1/x) = a, +plain(y = select(x) ^ a) := log(y, select(x)) = a, +plain(y = log(a, select(x))) := select(x) ^ y = a, +plain(y = log(select(x), a)) := select(x) ^ (1/y) = a ]") +) + +(defun calc-DistribRules () + "DistribRules" + (calc-compile-rule-set + "DistribRules" "[ +iterations(1), +x * select(a + b) := x*select(a) + x*b, +x * select(sum(a,b,c,d)) := sum(x*select(a),b,c,d), +x / select(a + b) := 1 / (select(a)/x + b/x), +select(a + b) / x := select(a)/x + b/x, +sum(select(a),b,c,d) / x := sum(select(a)/x,b,c,d), +x ^ select(a + b) := x^select(a) * x^b, +x ^ select(sum(a,b,c,d)) := prod(x^select(a),b,c,d), +x ^ select(a * b) := (x^a)^select(b), +x ^ select(a / b) := (x^a)^select(1/b), +select(a + b) ^ n := select(x) + :: integer(n) :: n >= 2 + :: let(x, expandpow(a+b,n)) + :: quote(matches(x,y+z)), +select(a + b) ^ x := a*select(a+b)^(x-1) + b*select(a+b)^(x-1), +select(a * b) ^ x := a^x * select(b)^x, +select(prod(a,b,c,d)) ^ x := prod(select(a)^x,b,c,d), +select(a / b) ^ x := select(a)^x / b^x, +select(- a) ^ x := (-1)^x * select(a)^x, +plain(-select(a + b)) := select(-a) - b, +plain(-select(sum(a,b,c,d))) := sum(select(-a),b,c,d), +plain(-select(a * b)) := select(-a) * b, +plain(-select(a / b)) := select(-a) / b, +sqrt(select(a * b)) := sqrt(select(a)) * sqrt(b), +sqrt(select(prod(a,b,c,d))) := prod(sqrt(select(a)),b,c,d), +sqrt(select(a / b)) := sqrt(select(a)) / sqrt(b), +sqrt(select(- a)) := sqrt(-1) sqrt(select(a)), +exp(select(a + b)) := exp(select(a)) / exp(-b) :: negative(b), +exp(select(a + b)) := exp(select(a)) * exp(b), +exp(select(sum(a,b,c,d))) := prod(exp(select(a)),b,c,d), +exp(select(a * b)) := exp(select(a)) ^ b :: constant(b), +exp(select(a * b)) := exp(select(a)) ^ b, +exp(select(a / b)) := exp(select(a)) ^ (1/b), +ln(select(a * b)) := ln(select(a)) + ln(b), +ln(select(prod(a,b,c,d))) := sum(ln(select(a)),b,c,d), +ln(select(a / b)) := ln(select(a)) - ln(b), +ln(select(a ^ b)) := ln(select(a)) * b, +log10(select(a * b)) := log10(select(a)) + log10(b), +log10(select(prod(a,b,c,d))) := sum(log10(select(a)),b,c,d), +log10(select(a / b)) := log10(select(a)) - log10(b), +log10(select(a ^ b)) := log10(select(a)) * b, +log(select(a * b), x) := log(select(a), x) + log(b,x), +log(select(prod(a,b,c,d)),x) := sum(log(select(a),x),b,c,d), +log(select(a / b), x) := log(select(a), x) - log(b,x), +log(select(a ^ b), x) := log(select(a), x) * b, +log(a, select(b)) := ln(a) / select(ln(b)), +sin(select(a + b)) := sin(select(a)) cos(b) + cos(a) sin(b), +sin(select(2 a)) := 2 sin(select(a)) cos(a), +sin(select(n a)) := 2sin((n-1) select(a)) cos(a) - sin((n-2) a) + :: integer(n) :: n > 2, +cos(select(a + b)) := cos(select(a)) cos(b) - sin(a) sin(b), +cos(select(2 a)) := 2 cos(select(a))^2 - 1, +cos(select(n a)) := 2cos((n-1) select(a)) cos(a) - cos((n-2) a) + :: integer(n) :: n > 2, +tan(select(a + b)) := (tan(select(a)) + tan(b)) / + (1 - tan(a) tan(b)), +tan(select(2 a)) := 2 tan(select(a)) / (1 - tan(a)^2), +tan(select(n a)) := (tan((n-1) select(a)) + tan(a)) / + (1 - tan((n-1) a) tan(a)) + :: integer(n) :: n > 2, +sinh(select(a + b)) := sinh(select(a)) cosh(b) + cosh(a) sinh(b), +cosh(select(a + b)) := cosh(select(a)) cosh(b) + sinh(a) sinh(b), +tanh(select(a + b)) := (tanh(select(a)) + tanh(b)) / + (1 + tanh(a) tanh(b)), +x && select(a || b) := (x && select(a)) || (x && b), +select(a || b) && x := (select(a) && x) || (b && x), +! select(a && b) := (!a) || (!b), +! select(a || b) := (!a) && (!b) ]") +) + +(defun calc-MergeRules () + "MergeRules" + (calc-compile-rule-set + "MergeRules" "[ +iterations(1), + (x*opt(a)) + select(x*b) := x * (a + select(b)), + (x*opt(a)) - select(x*b) := x * (a - select(b)), +sum(select(x)*a,b,c,d) := x * sum(select(a),b,c,d), + (a/x) + select(b/x) := (a + select(b)) / x, + (a/x) - select(b/x) := (a - select(b)) / x, +sum(a/select(x),b,c,d) := sum(select(a),b,c,d) / x, + (a/opt(b)) + select(c/d) := ((select(a)*d) + (b*c)) / (b*d), + (a/opt(b)) - select(c/d) := ((select(a)*d) - (b*c)) / (b*d), + (x^opt(a)) * select(x^b) := x ^ (a + select(b)), + (x^opt(a)) / select(x^b) := x ^ (a - select(b)), +select(x^a) / (x^opt(b)) := x ^ (select(a) - b), +prod(select(x)^a,b,c,d) := x ^ sum(select(a),b,c,d), +select(x^a) / (x^opt(b)) := x ^ (select(a) - b), + (a^x) * select(b^x) := select((a * b) ^x), + (a^x) / select(b^x) := select((b / b) ^ x), +select(a^x) / (b^x) := select((a / b) ^ x), +prod(a^select(x),b,c,d) := select(prod(a,b,c,d) ^ x), + (a^x) * select(b^y) := select((a * b^(y-x)) ^x), + (a^x) / select(b^y) := select((b / b^(y-x)) ^ x), +select(a^x) / (b^y) := select((a / b^(y-x)) ^ x), +select(x^a) ^ b := x ^ select(a * b), + (x^a) ^ select(b) := x ^ select(a * b), +select(sqrt(a)) ^ b := select(a ^ (b / 2)), +sqrt(a) ^ select(b) := select(a ^ (b / 2)), +sqrt(select(a) ^ b) := select(a ^ (b / 2)), +sqrt(a ^ select(b)) := select(a ^ (b / 2)), +sqrt(a) * select(sqrt(b)) := select(sqrt(a * b)), +sqrt(a) / select(sqrt(b)) := select(sqrt(a / b)), +select(sqrt(a)) / sqrt(b) := select(sqrt(a / b)), +prod(select(sqrt(a)),b,c,d) := select(sqrt(prod(a,b,c,d))), +exp(a) * select(exp(b)) := select(exp(a + b)), +exp(a) / select(exp(b)) := select(exp(a - b)), +select(exp(a)) / exp(b) := select(exp(a - b)), +prod(select(exp(a)),b,c,d) := select(exp(sum(a,b,c,d))), +select(exp(a)) ^ b := select(exp(a * b)), +exp(a) ^ select(b) := select(exp(a * b)), +ln(a) + select(ln(b)) := select(ln(a * b)), +ln(a) - select(ln(b)) := select(ln(a / b)), +select(ln(a)) - ln(b) := select(ln(a / b)), +sum(select(ln(a)),b,c,d) := select(ln(prod(a,b,c,d))), +b * select(ln(a)) := select(ln(a ^ b)), +select(b) * ln(a) := select(ln(a ^ b)), +select(ln(a)) / ln(b) := select(log(a, b)), +ln(a) / select(ln(b)) := select(log(a, b)), +select(ln(a)) / b := select(ln(a ^ (1/b))), +ln(a) / select(b) := select(ln(a ^ (1/b))), +log10(a) + select(log10(b)) := select(log10(a * b)), +log10(a) - select(log10(b)) := select(log10(a / b)), +select(log10(a)) - log10(b) := select(log10(a / b)), +sum(select(log10(a)),b,c,d) := select(log10(prod(a,b,c,d))), +b * select(log10(a)) := select(log10(a ^ b)), +select(b) * log10(a) := select(log10(a ^ b)), +select(log10(a)) / log10(b) := select(log(a, b)), +log10(a) / select(log10(b)) := select(log(a, b)), +select(log10(a)) / b := select(log10(a ^ (1/b))), +log10(a) / select(b) := select(log10(a ^ (1/b))), +log(a,x) + select(log(b,x)) := select(log(a * b,x)), +log(a,x) - select(log(b,x)) := select(log(a / b,x)), +select(log(a,x)) - log(b,x) := select(log(a / b,x)), +sum(select(log(a,x)),b,c,d) := select(log(prod(a,b,c,d),x)), +b * select(log(a,x)) := select(log(a ^ b,x)), +select(b) * log(a,x) := select(log(a ^ b,x)), +select(log(a,x)) / log(b,x) := select(log(a, b)), +log(a,x) / select(log(b,x)) := select(log(a, b)), +select(log(a,x)) / b := select(log(a ^ (1/b),x)), +log(a,x) / select(b) := select(log(a ^ (1/b),x)), +select(x && a) || (x && opt(b)) := x && (select(a) || b) ]") +) + +(defun calc-NegateRules () + "NegateRules" + (calc-compile-rule-set + "NegateRules" "[ +iterations(1), +a + select(x) := a - select(-x), +a - select(x) := a + select(-x), +sum(select(x),b,c,d) := -sum(select(-x),b,c,d), +a * select(x) := -a * select(-x), +a / select(x) := -a / select(-x), +select(x) / a := -select(-x) / a, +prod(select(x),b,c,d) := (-1)^(d-c+1) * prod(select(-x),b,c,d), +select(x) ^ n := select(-x) ^ a :: integer(n) :: n%2 = 0, +select(x) ^ n := -(select(-x) ^ a) :: integer(n) :: n%2 = 1, +select(x) ^ a := (-select(-x)) ^ a, +a ^ select(x) := (1 / a)^select(-x), +abs(select(x)) := abs(select(-x)), +i sqrt(select(x)) := -sqrt(select(-x)), +sqrt(select(x)) := i sqrt(select(-x)), +re(select(x)) := -re(select(-x)), +im(select(x)) := -im(select(-x)), +conj(select(x)) := -conj(select(-x)), +trunc(select(x)) := -trunc(select(-x)), +round(select(x)) := -round(select(-x)), +floor(select(x)) := -ceil(select(-x)), +ceil(select(x)) := -floor(select(-x)), +ftrunc(select(x)) := -ftrunc(select(-x)), +fround(select(x)) := -fround(select(-x)), +ffloor(select(x)) := -fceil(select(-x)), +fceil(select(x)) := -ffloor(select(-x)), +exp(select(x)) := 1 / exp(select(-x)), +sin(select(x)) := -sin(select(-x)), +cos(select(x)) := cos(select(-x)), +tan(select(x)) := -tan(select(-x)), +arcsin(select(x)) := -arcsin(select(-x)), +arccos(select(x)) := 4 arctan(1) - arccos(select(-x)), +arctan(select(x)) := -arctan(select(-x)), +sinh(select(x)) := -sinh(select(-x)), +cosh(select(x)) := cosh(select(-x)), +tanh(select(x)) := -tanh(select(-x)), +arcsinh(select(x)) := -arcsinh(select(-x)), +arctanh(select(x)) := -arctanh(select(-x)), +select(x) = a := select(-x) = -a, +select(x) != a := select(-x) != -a, +select(x) < a := select(-x) > -a, +select(x) > a := select(-x) < -a, +select(x) <= a := select(-x) >= -a, +select(x) >= a := select(-x) <= -a, +a < select(x) := -a > select(-x), +a > select(x) := -a < select(-x), +a <= select(x) := -a >= select(-x), +a >= select(x) := -a <= select(-x), +select(x) := -select(-x) ]") +) + +(defun calc-InvertRules () + "InvertRules" + (calc-compile-rule-set + "InvertRules" "[ +iterations(1), +a * select(x) := a / select(1/x), +a / select(x) := a * select(1/x), +select(x) / a := 1 / (select(1/x) a), +prod(select(x),b,c,d) := 1 / prod(select(1/x),b,c,d), +abs(select(x)) := 1 / abs(select(1/x)), +sqrt(select(x)) := 1 / sqrt(select(1/x)), +ln(select(x)) := -ln(select(1/x)), +log10(select(x)) := -log10(select(1/x)), +log(select(x), a) := -log(select(1/x), a), +log(a, select(x)) := -log(a, select(1/x)), +arctan(select(x)) := simplify(2 arctan(1))-arctan(select(1/x)), +select(x) = a := select(1/x) = 1/a, +select(x) != a := select(1/x) != 1/a, +select(x) < a := select(1/x) > 1/a, +select(x) > a := select(1/x) < 1/a, +select(x) <= a := select(1/x) >= 1/a, +select(x) >= a := select(1/x) <= 1/a, +a < select(x) := 1/a > select(1/x), +a > select(x) := 1/a < select(1/x), +a <= select(x) := 1/a >= select(1/x), +a >= select(x) := 1/a <= select(1/x), +select(x) := 1 / select(1/x) ]") +) + + +(defun calc-FactorRules () + "FactorRules" + (calc-compile-rule-set + "FactorRules" "[ +thecoefs(x, [z, a+b, c]) := thefactors(x, [d x + d a/c, (c/d) x + (b/d)]) + :: z = a b/c :: let(d := pgcd(pcont(c), pcont(b))), +thecoefs(x, [z, a, c]) := thefactors(x, [(r x + a/(2 r))^2]) + :: z = (a/2)^2/c :: let(r := esimplify(sqrt(c))) + :: !matches(r, sqrt(rr)), +thecoefs(x, [z, 0, c]) := thefactors(x, [rc x + rz, rc x - rz]) + :: negative(z) + :: let(rz := esimplify(sqrt(-z))) :: !matches(rz, sqrt(rzz)) + :: let(rc := esimplify(sqrt(c))) :: !matches(rc, sqrt(rcc)), +thecoefs(x, [z, 0, c]) := thefactors(x, [rz + rc x, rz - rc x]) + :: negative(c) + :: let(rz := esimplify(sqrt(z))) :: !matches(rz, sqrt(rzz)) + :: let(rc := esimplify(sqrt(-c))) :: !matches(rc, sqrt(rcc)) + ]") +) +;;(setq var-FactorRules 'calc-FactorRules) + + +(defun calc-IntegAfterRules () + "IntegAfterRules" + (calc-compile-rule-set + "IntegAfterRules" "[ + opt(a) ln(x) + opt(b) ln(y) := 2 a esimplify(arctanh(x-1)) + :: a + b = 0 :: nrat(x + y) = 2 || nrat(x - y) = 2, + a * (b + c) := a b + a c :: constant(a) + ]") +) + +;;(setq var-IntegAfterRules 'calc-IntegAfterRules) + + +(defun calc-FitRules () + "FitRules" + (calc-compile-rule-set + "FitRules" "[ + +schedule(1,2,3,4), +iterations(inf), + +phase(1), +e^x := exp(x), +x^y := exp(y ln(x)) :: !istrue(constant(y)), +x/y := x fitinv(y), +fitinv(x y) := fitinv(x) fitinv(y), +exp(a) exp(b) := exp(a + b), +a exp(b) := exp(ln(a) + b) :: !hasfitvars(a), +fitinv(exp(a)) := exp(-a), +ln(a b) := ln(a) + ln(b), +ln(fitinv(a)) := -ln(a), +log10(a b) := log10(a) + log10(b), +log10(fitinv(a)) := -log10(a), +log(a,b) := ln(a)/ln(b), +ln(exp(a)) := a, +a*(b+c) := a*b + a*c, +(a+b)^n := x :: integer(n) :: n >= 2 + :: let(x, expandpow(a+b,n)) + :: quote(matches(x,y+z)), + +phase(1,2), +fitmodel(y = x) := fitmodel(0, y - x), +fitmodel(y, x+c) := fitmodel(y-c, x) :: !hasfitparams(c), +fitmodel(y, x c) := fitmodel(y/c, x) :: !hasfitparams(c), +fitmodel(y, x/(c opt(d))) := fitmodel(y c, x/d) :: !hasfitparams(c), +fitmodel(y, apply(f,[x])) := fitmodel(yy, x) + :: hasfitparams(x) + :: let(FTemp() = yy, + solve(apply(f,[FTemp()]) = y, + FTemp())), +fitmodel(y, apply(f,[x,c])) := fitmodel(yy, x) + :: !hasfitparams(c) + :: let(FTemp() = yy, + solve(apply(f,[FTemp(),c]) = y, + FTemp())), +fitmodel(y, apply(f,[c,x])) := fitmodel(yy, x) + :: !hasfitparams(c) + :: let(FTemp() = yy, + solve(apply(f,[c,FTemp()]) = y, + FTemp())), + +phase(2,3), +fitmodel(y, x) := fitsystem(y, [], [], fitpart(1,1,x)), +fitpart(a,b,plain(x + y)) := fitpart(a,b,x) + fitpart(a,b,y), +fitpart(a,b,plain(x - y)) := fitpart(a,b,x) + fitpart(-a,b,y), +fitpart(a,b,plain(-x)) := fitpart(-a,b,x), +fitpart(a,b,x opt(c)) := fitpart(a,x b,c) :: !hasfitvars(x), +fitpart(a,x opt(b),c) := fitpart(x a,b,c) :: !hasfitparams(x), +fitpart(a,x y + x opt(z),c) := fitpart(a,x*(y+z),c), +fitpart(a,b,c) := fitpart2(a,b,c), + +phase(3), +fitpart2(a1,b1,x) + fitpart2(a2,b2,x) := fitpart(1, a1 b1 + a2 b2, x), +fitpart2(a1,x,c1) + fitpart2(a2,x,c2) := fitpart2(1, x, a1 c1 + a2 c2), + +phase(4), +fitinv(x) := 1 / x, +exp(x + ln(y)) := y exp(x), +exp(x ln(y)) := y^x, +ln(x) + ln(y) := ln(x y), +ln(x) - ln(y) := ln(x/y), +x*y + x*z := x*(y+z), +fitsystem(y, xv, pv, fitpart2(a,fitparam(b),c) + opt(d)) + := fitsystem(y, rcons(xv, a c), + rcons(pv, fitdummy(b) = fitparam(b)), d) + :: b = vlen(pv)+1, +fitsystem(y, xv, pv, fitpart2(a,b,c) + opt(d)) + := fitsystem(y, rcons(xv, a c), + rcons(pv, fitdummy(vlen(pv)+1) = b), d), +fitsystem(y, xv, pv, 0) := fitsystem(y, xv, cons(fvh,fvt)) + :: !hasfitparams(xv) + :: let(cons(fvh,fvt), + solve(pv, table(fitparam(j), j, 1, + hasfitparams(pv)))), +fitparam(n) = x := x ]") +) + diff --git a/lisp/calc/calc-sel.el b/lisp/calc/calc-sel.el new file mode 100644 index 0000000000..ab7a3879f1 --- /dev/null +++ b/lisp/calc/calc-sel.el @@ -0,0 +1,867 @@ +;; Calculator for GNU Emacs, part II [calc-sel.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-sel () nil) + + +;;; Selection commands. + +(defun calc-select-here (num &optional once keep) + (interactive "P") + (calc-wrapper + (calc-prepare-selection) + (let ((found (calc-find-selected-part)) + (entry calc-selection-cache-entry)) + (or (and keep (nth 2 entry)) + (progn + (if once (progn + (setq calc-keep-selection nil) + (message "(Selection will apply to next command only)"))) + (calc-change-current-selection + (if found + (if (and num (> (setq num (prefix-numeric-value num)) 0)) + (progn + (while (and (>= (setq num (1- num)) 0) + (not (eq found (car entry)))) + (setq found (calc-find-assoc-parent-formula + (car entry) found))) + found) + (calc-grow-assoc-formula (car entry) found)) + (car entry))))))) +) + +(defun calc-select-once (num) + (interactive "P") + (calc-select-here num t) +) + +(defun calc-select-here-maybe (num) + (interactive "P") + (calc-select-here num nil t) +) + +(defun calc-select-once-maybe (num) + (interactive "P") + (calc-select-here num t t) +) + +(defun calc-select-additional () + (interactive) + (calc-wrapper + (let (calc-keep-selection) + (calc-prepare-selection)) + (let ((found (calc-find-selected-part)) + (entry calc-selection-cache-entry)) + (calc-change-current-selection + (if found + (let ((sel (nth 2 entry))) + (if sel + (progn + (while (not (or (eq sel (car entry)) + (calc-find-sub-formula sel found))) + (setq sel (calc-find-assoc-parent-formula + (car entry) sel))) + sel) + (calc-grow-assoc-formula (car entry) found))) + (car entry))))) +) + +(defun calc-select-more (num) + (interactive "P") + (calc-wrapper + (calc-prepare-selection) + (let ((entry calc-selection-cache-entry)) + (if (nth 2 entry) + (let ((sel (nth 2 entry))) + (while (and (not (eq sel (car entry))) + (>= (setq num (1- (prefix-numeric-value num))) 0)) + (setq sel (calc-find-assoc-parent-formula (car entry) sel))) + (calc-change-current-selection sel)) + (calc-select-here num)))) +) + +(defun calc-select-less (num) + (interactive "p") + (calc-wrapper + (calc-prepare-selection) + (let ((found (calc-find-selected-part)) + (entry calc-selection-cache-entry)) + (calc-change-current-selection + (and found + (let ((sel (nth 2 entry)) + old index op) + (while (and sel + (not (eq sel found)) + (>= (setq num (1- num)) 0)) + (setq old sel + index (calc-find-sub-formula sel found)) + (and (setq sel (and index (nth index old))) + calc-assoc-selections + (setq op (assq (car-safe sel) calc-assoc-ops)) + (memq (car old) (nth index op)) + (setq num (1+ num)))) + sel))))) +) + +(defun calc-select-part (num) + (interactive "P") + (or num (setq num (- last-command-char ?0))) + (calc-wrapper + (calc-prepare-selection) + (let ((sel (calc-find-nth-part (or (nth 2 calc-selection-cache-entry) + (car calc-selection-cache-entry)) + num))) + (if sel + (calc-change-current-selection sel) + (error "%d is not a valid sub-formula index" num)))) +) + +(defun calc-find-nth-part (expr num) + (if (and calc-assoc-selections + (assq (car-safe expr) calc-assoc-ops)) + (let (op) + (calc-find-nth-part-rec expr)) + (if (eq (car-safe expr) 'intv) + (and (>= num 1) (<= num 2) (nth (1+ num) expr)) + (and (not (Math-primp expr)) (>= num 1) (< num (length expr)) + (nth num expr)))) +) + +(defun calc-find-nth-part-rec (expr) ; uses num, op + (or (if (and (setq op (assq (car-safe (nth 1 expr)) calc-assoc-ops)) + (memq (car expr) (nth 1 op))) + (calc-find-nth-part-rec (nth 1 expr)) + (and (= (setq num (1- num)) 0) + (nth 1 expr))) + (if (and (setq op (assq (car-safe (nth 2 expr)) calc-assoc-ops)) + (memq (car expr) (nth 2 op))) + (calc-find-nth-part-rec (nth 2 expr)) + (and (= (setq num (1- num)) 0) + (nth 2 expr)))) +) + +(defun calc-select-next (num) + (interactive "p") + (if (< num 0) + (calc-select-previous (- num)) + (calc-wrapper + (calc-prepare-selection) + (let* ((entry calc-selection-cache-entry) + (sel (nth 2 entry))) + (if sel + (progn + (while (>= (setq num (1- num)) 0) + (let* ((parent (calc-find-parent-formula (car entry) sel)) + (p parent) + op) + (and (eq p t) (setq p nil)) + (while (and (setq p (cdr p)) + (not (eq (car p) sel)))) + (if (cdr p) + (setq sel (or (and calc-assoc-selections + (setq op (assq (car-safe (nth 1 p)) + calc-assoc-ops)) + (memq (car parent) (nth 2 op)) + (nth 1 (nth 1 p))) + (nth 1 p))) + (if (and calc-assoc-selections + (setq op (assq (car-safe parent) calc-assoc-ops)) + (consp (setq p (calc-find-parent-formula + (car entry) parent))) + (eq (nth 1 p) parent) + (memq (car p) (nth 1 op))) + (setq sel (nth 2 p)) + (error "No \"next\" sub-formula"))))) + (calc-change-current-selection sel)) + (if (Math-primp (car entry)) + (calc-change-current-selection (car entry)) + (calc-select-part num)))))) +) + +(defun calc-select-previous (num) + (interactive "p") + (if (< num 0) + (calc-select-next (- num)) + (calc-wrapper + (calc-prepare-selection) + (let* ((entry calc-selection-cache-entry) + (sel (nth 2 entry))) + (if sel + (progn + (while (>= (setq num (1- num)) 0) + (let* ((parent (calc-find-parent-formula (car entry) sel)) + (p (cdr-safe parent)) + (prev nil) + op) + (if (eq (car-safe parent) 'intv) (setq p (cdr p))) + (while (and (not (eq (car p) sel)) + (setq prev (car p) + p (cdr p)))) + (if prev + (setq sel (or (and calc-assoc-selections + (setq op (assq (car-safe prev) + calc-assoc-ops)) + (memq (car parent) (nth 1 op)) + (nth 2 prev)) + prev)) + (if (and calc-assoc-selections + (setq op (assq (car-safe parent) calc-assoc-ops)) + (consp (setq p (calc-find-parent-formula + (car entry) parent))) + (eq (nth 2 p) parent) + (memq (car p) (nth 2 op))) + (setq sel (nth 1 p)) + (error "No \"previous\" sub-formula"))))) + (calc-change-current-selection sel)) + (if (Math-primp (car entry)) + (calc-change-current-selection (car entry)) + (let ((len (if (and calc-assoc-selections + (assq (car (car entry)) calc-assoc-ops)) + (let (op (num 0)) + (calc-find-nth-part-rec (car entry)) + (- 1 num)) + (length (car entry))))) + (calc-select-part (- len num)))))))) +) + +(defun calc-find-parent-formula (expr part) + (cond ((eq expr part) t) + ((Math-primp expr) nil) + (t + (let ((p expr) res) + (while (and (setq p (cdr p)) + (not (setq res (calc-find-parent-formula + (car p) part))))) + (and p + (if (eq res t) expr res))))) +) + + +(defun calc-find-assoc-parent-formula (expr part) + (calc-grow-assoc-formula expr (calc-find-parent-formula expr part)) +) + +(defun calc-grow-assoc-formula (expr part) + (if calc-assoc-selections + (let ((op (assq (car-safe part) calc-assoc-ops))) + (if op + (let (new) + (while (and (consp (setq new (calc-find-parent-formula + expr part))) + (memq (car new) + (nth (calc-find-sub-formula new part) op))) + (setq part new)))) + part) + part) +) + +(defun calc-find-sub-formula (expr part) + (cond ((eq expr part) t) + ((Math-primp expr) nil) + (t + (let ((num 1)) + (while (and (setq expr (cdr expr)) + (not (calc-find-sub-formula (car expr) part))) + (setq num (1+ num))) + (and expr num)))) +) + +(defun calc-unselect (num) + (interactive "P") + (calc-wrapper + (calc-prepare-selection num) + (calc-change-current-selection nil)) +) + +(defun calc-clear-selections () + (interactive) + (calc-wrapper + (let ((limit (calc-stack-size)) + (n 1)) + (while (<= n limit) + (if (calc-top n 'sel) + (progn + (calc-prepare-selection n) + (calc-change-current-selection nil))) + (setq n (1+ n)))) + (calc-clear-command-flag 'position-point)) +) + +(defun calc-show-selections (arg) + (interactive "P") + (calc-wrapper + (calc-preserve-point) + (setq calc-show-selections (if arg + (> (prefix-numeric-value arg) 0) + (not calc-show-selections))) + (let ((p calc-stack)) + (while (and p + (or (null (nth 2 (car p))) + (equal (car p) calc-selection-cache-entry))) + (setq p (cdr p))) + (or (and p + (let ((calc-selection-cache-default-entry + calc-selection-cache-entry)) + (calc-do-refresh))) + (and calc-selection-cache-entry + (let ((sel (nth 2 calc-selection-cache-entry))) + (setcar (nthcdr 2 calc-selection-cache-entry) nil) + (calc-change-current-selection sel))))) + (message (if calc-show-selections + "Displaying only selected part of formulas" + "Displaying all but selected part of formulas"))) +) + +(defun calc-preserve-point () + (or (looking-at "\\.\n+\\'") + (progn + (setq calc-final-point-line (+ (count-lines (point-min) (point)) + (if (bolp) 1 0)) + calc-final-point-column (current-column)) + (calc-set-command-flag 'position-point))) +) + +(defun calc-enable-selections (arg) + (interactive "P") + (calc-wrapper + (calc-preserve-point) + (setq calc-use-selections (if arg + (> (prefix-numeric-value arg) 0) + (not calc-use-selections))) + (calc-set-command-flag 'renum-stack) + (message (if calc-use-selections + "Commands operate only on selected sub-formulas" + "Selections of sub-formulas have no effect"))) +) + +(defun calc-break-selections (arg) + (interactive "P") + (calc-wrapper + (calc-preserve-point) + (setq calc-assoc-selections (if arg + (<= (prefix-numeric-value arg) 0) + (not calc-assoc-selections))) + (message (if calc-assoc-selections + "Selection treats a+b+c as a sum of three terms" + "Selection treats a+b+c as (a+b)+c"))) +) + +(defun calc-prepare-selection (&optional num) + (or num (setq num (calc-locate-cursor-element (point)))) + (setq calc-selection-true-num num + calc-keep-selection t) + (or (> num 0) (setq num 1)) + ;; (if (or (< num 1) (> num (calc-stack-size))) + ;; (error "Cursor must be positioned on a stack element")) + (let* ((entry (calc-top num 'entry)) + ww w) + (or (equal entry calc-selection-cache-entry) + (progn + (setcar entry (calc-encase-atoms (car entry))) + (setq calc-selection-cache-entry entry + calc-selection-cache-num num + calc-selection-cache-comp + (let ((math-comp-tagged t)) + (math-compose-expr (car entry) 0)) + calc-selection-cache-offset + (+ (car (math-stack-value-offset calc-selection-cache-comp)) + (length calc-left-label) + (if calc-line-numbering 4 0)))))) + (calc-preserve-point) +) +(setq calc-selection-cache-entry nil) + +;;; The following ensures that no two subformulas will be "eq" to each other! +(defun calc-encase-atoms (x) + (if (or (not (consp x)) + (equal x '(float 0 0))) + (list 'cplx x 0) + (calc-encase-atoms-rec x) + x) +) + +(defun calc-encase-atoms-rec (x) + (or (Math-primp x) + (progn + (if (eq (car x) 'intv) + (setq x (cdr x))) + (while (setq x (cdr x)) + (if (or (not (consp (car x))) + (equal (car x) '(float 0 0))) + (setcar x (list 'cplx (car x) 0)) + (calc-encase-atoms-rec (car x)))))) +) + +(defun calc-find-selected-part () + (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset)) + toppt + (lcount 0) + (spaces 0) + (math-comp-sel-vpos (save-excursion + (beginning-of-line) + (let ((line (point))) + (calc-cursor-stack-index + calc-selection-cache-num) + (setq toppt (point)) + (while (< (point) line) + (forward-line 1) + (setq spaces (+ spaces + (current-indentation)) + lcount (1+ lcount))) + (- lcount (math-comp-ascent + calc-selection-cache-comp) -1)))) + (math-comp-sel-cpos (- (point) toppt calc-selection-cache-offset + spaces lcount)) + (math-comp-sel-tag nil)) + (and (>= math-comp-sel-hpos 0) + (> calc-selection-true-num 0) + (math-composition-to-string calc-selection-cache-comp 1000000)) + (nth 1 math-comp-sel-tag)) +) + +(defun calc-change-current-selection (sub-expr) + (or (eq sub-expr (nth 2 calc-selection-cache-entry)) + (let ((calc-prepared-composition calc-selection-cache-comp) + (buffer-read-only nil) + top) + (calc-set-command-flag 'renum-stack) + (setcar (nthcdr 2 calc-selection-cache-entry) sub-expr) + (calc-cursor-stack-index calc-selection-cache-num) + (setq top (point)) + (calc-cursor-stack-index (1- calc-selection-cache-num)) + (delete-region top (point)) + (let ((calc-selection-cache-default-entry calc-selection-cache-entry)) + (insert (math-format-stack-value calc-selection-cache-entry) + "\n")))) +) + +(defun calc-top-selected (&optional n m) + (and calc-any-selections + calc-use-selections + (progn + (or n (setq n 1)) + (or m (setq m 1)) + (calc-check-stack (+ n m -1)) + (let ((top (nthcdr (+ m calc-stack-top -1) calc-stack)) + (sel nil)) + (while (>= (setq n (1- n)) 0) + (if (nth 2 (car top)) + (setq sel (if sel t (nth 2 (car top))))) + (setq top (cdr top))) + sel))) +) + +(defun calc-replace-sub-formula (expr old new) + (setq new (calc-encase-atoms new)) + (calc-replace-sub-formula-rec expr) +) + +(defun calc-replace-sub-formula-rec (expr) + (cond ((eq expr old) new) + ((Math-primp expr) expr) + (t + (cons (car expr) + (mapcar 'calc-replace-sub-formula-rec (cdr expr))))) +) + +(defun calc-sel-error () + (error "Illegal operation on sub-formulas") +) + +(defun calc-replace-selections (n vals m) + (if (calc-top-selected n m) + (let ((num (length vals))) + (calc-preserve-point) + (cond + ((= n num) + (let* ((old (calc-top-list n m 'entry)) + (new nil) + (sel nil) + val) + (while old + (if (nth 2 (car old)) + (setq val (calc-encase-atoms (car vals)) + new (cons (calc-replace-sub-formula (car (car old)) + (nth 2 (car old)) + val) + new) + sel (cons val sel)) + (setq new (cons (car vals) new) + sel (cons nil sel))) + (setq vals (cdr vals) + old (cdr old))) + (calc-pop-stack n m t) + (calc-push-list (nreverse new) + m (and calc-keep-selection (nreverse sel))))) + ((= num 1) + (let* ((old (calc-top-list n m 'entry)) + more) + (while (and old (not (nth 2 (car old)))) + (setq old (cdr old))) + (setq more old) + (while (and (setq more (cdr more)) (not (nth 2 (car more))))) + (and more + (calc-sel-error)) + (calc-pop-stack n m t) + (if old + (let ((val (calc-encase-atoms (car vals)))) + (calc-push-list (list (calc-replace-sub-formula + (car (car old)) + (nth 2 (car old)) + val)) + m (and calc-keep-selection (list val)))) + (calc-push-list vals)))) + (t (calc-sel-error)))) + (calc-pop-stack n m t) + (calc-push-list vals m)) +) +(setq calc-keep-selection t) + +(defun calc-delete-selection (n) + (let ((entry (calc-top n 'entry))) + (if (nth 2 entry) + (if (eq (nth 2 entry) (car entry)) + (progn + (calc-pop-stack 1 n t) + (calc-push-list '(0) n)) + (let ((parent (calc-find-parent-formula (car entry) (nth 2 entry))) + (repl nil)) + (calc-preserve-point) + (calc-pop-stack 1 n t) + (cond ((or (memq (car parent) '(* / %)) + (and (eq (car parent) '^) + (eq (nth 2 parent) (nth 2 entry)))) + (setq repl 1)) + ((memq (car parent) '(vec calcFunc-min calcFunc-max))) + ((and (assq (car parent) calc-tweak-eqn-table) + (= (length parent) 3)) + (setq repl 'del)) + (t + (setq repl 0))) + (cond + ((eq repl 'del) + (calc-push-list (list + (calc-normalize + (calc-replace-sub-formula + (car entry) + parent + (if (eq (nth 2 entry) (nth 1 parent)) + (nth 2 parent) + (nth 1 parent))))) + n)) + (repl + (calc-push-list (list + (calc-normalize + (calc-replace-sub-formula (car entry) + (nth 2 entry) + repl))) + n)) + (t + (calc-push-list (list + (calc-normalize + (calc-replace-sub-formula (car entry) + parent + (delq (nth 2 entry) + (copy-sequence + parent))))) + n))))) + (calc-pop-stack 1 n t))) +) + +(defun calc-roll-down-with-selections (n m) + (let ((vals (append (calc-top-list m 1) + (calc-top-list (- n m) (1+ m)))) + (sels (append (calc-top-list m 1 'sel) + (calc-top-list (- n m) (1+ m) 'sel)))) + (calc-pop-push-list n vals 1 sels)) +) + +(defun calc-roll-up-with-selections (n m) + (let ((vals (append (calc-top-list (- n m) 1) + (calc-top-list m (- n m -1)))) + (sels (append (calc-top-list (- n m) 1 'sel) + (calc-top-list m (- n m -1) 'sel)))) + (calc-pop-push-list n vals 1 sels)) +) + +(defun calc-auto-selection (entry) + (or (nth 2 entry) + (progn + (and (boundp 'reselect) (setq reselect nil)) + (calc-prepare-selection) + (calc-grow-assoc-formula (car entry) (calc-find-selected-part)))) +) + +(defun calc-copy-selection () + (interactive) + (calc-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (entry (calc-top num 'entry))) + (calc-push (or (calc-auto-selection entry) (car entry))))) +) + +(defun calc-del-selection () + (interactive) + (calc-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (entry (calc-top num 'entry)) + (sel (calc-auto-selection entry))) + (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel)) + (calc-delete-selection num))) +) + +(defun calc-enter-selection () + (interactive) + (calc-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (expr (car entry)) + (sel (or (calc-auto-selection entry) expr)) + alg) + (let ((calc-dollar-values (list sel)) + (calc-dollar-used 0)) + (setq alg (calc-do-alg-entry "" "Replace selection with: ")) + (and alg + (progn + (setq alg (calc-encase-atoms (car alg))) + (calc-pop-push-record-list 1 "repl" + (list (calc-replace-sub-formula + expr sel alg)) + num + (list (and reselect alg)))))) + (calc-handle-whys))) +) + +(defun calc-edit-selection () + (interactive) + (calc-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (expr (car entry)) + (sel (or (calc-auto-selection entry) expr)) + alg) + (let ((str (math-showing-full-precision + (math-format-nice-expr sel (screen-width))))) + (calc-edit-mode (list 'calc-finish-selection-edit + num (list 'quote sel) reselect)) + (insert str "\n")))) + (calc-show-edit-buffer) +) + +(defun calc-finish-selection-edit (num sel reselect) + (let ((buf (current-buffer)) + (str (buffer-substring (point) (point-max))) + (start (point))) + (switch-to-buffer calc-original-buffer) + (let ((val (math-read-expr str))) + (if (eq (car-safe val) 'error) + (progn + (switch-to-buffer buf) + (goto-char (+ start (nth 1 val))) + (error (nth 2 val)))) + (calc-wrapper + (calc-preserve-point) + (if disp-trail + (calc-trail-display 1 t)) + (setq val (calc-encase-atoms (calc-normalize val))) + (let ((expr (calc-top num 'full))) + (if (calc-find-sub-formula expr sel) + (calc-pop-push-record-list 1 "edit" + (list (calc-replace-sub-formula + expr sel val)) + num + (list (and reselect val))) + (calc-push val) + (error "Original selection has been lost")))))) +) + +(defun calc-sel-evaluate (arg) + (interactive "p") + (calc-slow-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (sel (or (calc-auto-selection entry) (car entry)))) + (calc-with-default-simplification + (let ((math-simplify-only nil)) + (calc-modify-simplify-mode arg) + (let ((val (calc-encase-atoms (calc-normalize sel)))) + (calc-pop-push-record-list 1 "jsmp" + (list (calc-replace-sub-formula + (car entry) sel val)) + num + (list (and reselect val)))))) + (calc-handle-whys))) +) + +(defun calc-sel-expand-formula (arg) + (interactive "p") + (calc-slow-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (sel (or (calc-auto-selection entry) (car entry)))) + (calc-with-default-simplification + (let ((math-simplify-only nil)) + (calc-modify-simplify-mode arg) + (let* ((math-expand-formulas (> arg 0)) + (val (calc-normalize sel)) + top) + (and (<= arg 0) + (setq top (math-expand-formula val)) + (setq val (calc-normalize top))) + (setq val (calc-encase-atoms val)) + (calc-pop-push-record-list 1 "jexf" + (list (calc-replace-sub-formula + (car entry) sel val)) + num + (list (and reselect val)))))) + (calc-handle-whys))) +) + +(defun calc-sel-mult-both-sides (no-simp &optional divide) + (interactive "P") + (calc-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (expr (car entry)) + (sel (or (calc-auto-selection entry) expr)) + (func (car-safe sel)) + alg lhs rhs) + (setq alg (calc-with-default-simplification + (car (calc-do-alg-entry "" + (if divide + "Divide both sides by: " + "Multiply both sides by: "))))) + (and alg + (progn + (if (and (or (eq func '/) + (assq func calc-tweak-eqn-table)) + (= (length sel) 3)) + (progn + (or (memq func '(/ calcFunc-eq calcFunc-neq)) + (if (math-known-nonposp alg) + (progn + (setq func (nth 1 (assq func + calc-tweak-eqn-table))) + (or (math-known-negp alg) + (message "Assuming this factor is nonzero"))) + (or (math-known-posp alg) + (if (math-known-nonnegp alg) + (message "Assuming this factor is nonzero") + (message "Assuming this factor is positive"))))) + (setq lhs (list (if divide '/ '*) (nth 1 sel) alg) + rhs (list (if divide '/ '*) (nth 2 sel) alg)) + (or no-simp + (progn + (setq lhs (math-simplify lhs) + rhs (math-simplify rhs)) + (and (eq func '/) + (or (Math-equal (nth 1 sel) 1) + (Math-equal (nth 1 sel) -1) + (and (memq (car-safe (nth 2 sel)) '(+ -)) + (memq (car-safe alg) '(+ -)))) + (setq rhs (math-expand-term rhs))))) + (setq alg (calc-encase-atoms + (calc-normalize (list func lhs rhs))))) + (setq rhs (list (if divide '* '/) sel alg)) + (or no-simp + (setq rhs (math-simplify rhs))) + (setq alg (calc-encase-atoms + (calc-normalize (if divide + (list '/ rhs alg) + (list '* alg rhs)))))) + (calc-pop-push-record-list 1 (if divide "div" "mult") + (list (calc-replace-sub-formula + expr sel alg)) + num + (list (and reselect alg))))) + (calc-handle-whys))) +) + +(defun calc-sel-div-both-sides (no-simp) + (interactive "P") + (calc-sel-mult-both-sides no-simp t) +) + +(defun calc-sel-add-both-sides (no-simp &optional subtract) + (interactive "P") + (calc-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (expr (car entry)) + (sel (or (calc-auto-selection entry) expr)) + (func (car-safe sel)) + alg lhs rhs) + (setq alg (calc-with-default-simplification + (car (calc-do-alg-entry "" + (if subtract + "Subtract from both sides: " + "Add to both sides: "))))) + (and alg + (progn + (if (and (assq func calc-tweak-eqn-table) + (= (length sel) 3)) + (progn + (setq lhs (list (if subtract '- '+) (nth 1 sel) alg) + rhs (list (if subtract '- '+) (nth 2 sel) alg)) + (or no-simp + (setq lhs (math-simplify lhs) + rhs (math-simplify rhs))) + (setq alg (calc-encase-atoms + (calc-normalize (list func lhs rhs))))) + (setq rhs (list (if subtract '+ '-) sel alg)) + (or no-simp + (setq rhs (math-simplify rhs))) + (setq alg (calc-encase-atoms + (calc-normalize (list (if subtract '- '+) alg rhs))))) + (calc-pop-push-record-list 1 (if subtract "sub" "add") + (list (calc-replace-sub-formula + expr sel alg)) + num + (list (and reselect alg))))) + (calc-handle-whys))) +) + +(defun calc-sel-sub-both-sides (no-simp) + (interactive "P") + (calc-sel-add-both-sides no-simp t) +) + diff --git a/lisp/calc/calc-stat.el b/lisp/calc/calc-stat.el new file mode 100644 index 0000000000..155be891c5 --- /dev/null +++ b/lisp/calc/calc-stat.el @@ -0,0 +1,629 @@ +;; Calculator for GNU Emacs, part II [calc-stat.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-stat () nil) + + +;;; Statistical operations on vectors. + +(defun calc-vector-count (arg) + (interactive "P") + (calc-slow-wrapper + (calc-vector-op "coun" 'calcFunc-vcount arg)) +) + +(defun calc-vector-sum (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-vector-op "vprd" 'calcFunc-vprod arg) + (calc-vector-op "vsum" 'calcFunc-vsum arg))) +) + +(defun calc-vector-product (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-vector-sum arg) +) + +(defun calc-vector-max (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-vector-op "vmin" 'calcFunc-vmin arg) + (calc-vector-op "vmax" 'calcFunc-vmax arg))) +) + +(defun calc-vector-min (arg) + (interactive "P") + (calc-invert-func) + (calc-vector-max arg) +) + +(defun calc-vector-mean (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (if (calc-is-inverse) + (calc-vector-op "harm" 'calcFunc-vhmean arg) + (calc-vector-op "medn" 'calcFunc-vmedian arg)) + (if (calc-is-inverse) + (calc-vector-op "meae" 'calcFunc-vmeane arg) + (calc-vector-op "mean" 'calcFunc-vmean arg)))) +) + +(defun calc-vector-mean-error (arg) + (interactive "P") + (calc-invert-func) + (calc-vector-mean arg) +) + +(defun calc-vector-median (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-vector-mean arg) +) + +(defun calc-vector-harmonic-mean (arg) + (interactive "P") + (calc-invert-func) + (calc-hyperbolic-func) + (calc-vector-mean arg) +) + +(defun calc-vector-geometric-mean (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (calc-binary-op "geom" 'calcFunc-agmean arg) + (calc-vector-op "geom" 'calcFunc-vgmean arg))) +) + +(defun calc-vector-sdev (arg) + (interactive "P") + (calc-slow-wrapper + (if (calc-is-hyperbolic) + (if (calc-is-inverse) + (calc-vector-op "pvar" 'calcFunc-vpvar arg) + (calc-vector-op "var" 'calcFunc-vvar arg)) + (if (calc-is-inverse) + (calc-vector-op "psdv" 'calcFunc-vpsdev arg) + (calc-vector-op "sdev" 'calcFunc-vsdev arg)))) +) + +(defun calc-vector-pop-sdev (arg) + (interactive "P") + (calc-invert-func) + (calc-vector-sdev arg) +) + +(defun calc-vector-variance (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-vector-sdev arg) +) + +(defun calc-vector-pop-variance (arg) + (interactive "P") + (calc-invert-func) + (calc-hyperbolic-func) + (calc-vector-sdev arg) +) + +(defun calc-vector-covariance (arg) + (interactive "P") + (calc-slow-wrapper + (let ((n (if (eq arg 1) 1 2))) + (if (calc-is-hyperbolic) + (calc-enter-result n "corr" (cons 'calcFunc-vcorr + (calc-top-list-n n))) + (if (calc-is-inverse) + (calc-enter-result n "pcov" (cons 'calcFunc-vpcov + (calc-top-list-n n))) + (calc-enter-result n "cov" (cons 'calcFunc-vcov + (calc-top-list-n n))))))) +) + +(defun calc-vector-pop-covariance (arg) + (interactive "P") + (calc-invert-func) + (calc-vector-covariance arg) +) + +(defun calc-vector-correlation (arg) + (interactive "P") + (calc-hyperbolic-func) + (calc-vector-covariance arg) +) + +(defun calc-vector-op (name func arg) + (setq calc-aborted-prefix name + arg (prefix-numeric-value arg)) + (if (< arg 0) + (error "Negative arguments not allowed")) + (calc-enter-result arg name (cons func (calc-top-list-n arg))) +) + + + + +;;; Useful statistical functions + +;;; Sum, product, etc., of one or more values or vectors. +;;; Each argument must be either a number or a vector. Vectors +;;; are flattened, but variables inside are assumed to represent +;;; non-vectors. + +(defun calcFunc-vsum (&rest vecs) + (math-reduce-many-vecs 'calcFunc-add 'calcFunc-vsum vecs 0) +) + +(defun calcFunc-vprod (&rest vecs) + (math-reduce-many-vecs 'calcFunc-mul 'calcFunc-vprod vecs 1) +) + +(defun calcFunc-vmax (&rest vecs) + (if (eq (car-safe (car vecs)) 'sdev) + '(var inf var-inf) + (if (eq (car-safe (car vecs)) 'intv) + (nth 3 (math-fix-int-intv (car vecs))) + (math-reduce-many-vecs 'calcFunc-max 'calcFunc-vmax vecs + '(neg (var inf var-inf))))) +) + +(defun calcFunc-vmin (&rest vecs) + (if (eq (car-safe (car vecs)) 'sdev) + '(neg (var inf var-inf)) + (if (eq (car-safe (car vecs)) 'intv) + (nth 2 (math-fix-int-intv (car vecs))) + (math-reduce-many-vecs 'calcFunc-min 'calcFunc-vmin vecs + '(var inf var-inf)))) +) + +(defun math-reduce-many-vecs (func whole-func vecs ident) + (let ((const-part nil) + (symb-part nil) + val vec) + (let ((calc-internal-prec (+ calc-internal-prec 2))) + (while vecs + (setq val (car vecs)) + (and (eq (car-safe val) 'var) + (eq (car-safe (calc-var-value (nth 2 val))) 'vec) + (setq val (symbol-value (nth 2 val)))) + (cond ((Math-vectorp val) + (setq vec (append (and const-part (list const-part)) + (math-flatten-vector val))) + (setq const-part (if vec + (calcFunc-reducer + (math-calcFunc-to-var func) + (cons 'vec vec)) + ident))) + ((or (Math-objectp val) (math-infinitep val)) + (setq const-part (if const-part + (funcall func const-part val) + val))) + (t + (setq symb-part (nconc symb-part (list val))))) + (setq vecs (cdr vecs)))) + (if const-part + (progn + (setq const-part (math-normalize const-part)) + (if symb-part + (funcall func const-part (cons whole-func symb-part)) + const-part)) + (if symb-part (cons whole-func symb-part) ident))) +) + + +;;; Return the number of data elements among the arguments. +(defun calcFunc-vcount (&rest vecs) + (let ((count 0)) + (while vecs + (setq count (if (Math-vectorp (car vecs)) + (+ count (math-count-elements (car vecs))) + (if (Math-objectp (car vecs)) + (1+ count) + (if (and (eq (car-safe (car vecs)) 'var) + (eq (car-safe (calc-var-value + (nth 2 (car vecs)))) + 'vec)) + (+ count (math-count-elements + (symbol-value (nth 2 (car vecs))))) + (math-reject-arg (car vecs) 'numvecp)))) + vecs (cdr vecs))) + count) +) + +(defun math-count-elements (vec) + (let ((count 0)) + (while (setq vec (cdr vec)) + (setq count (if (Math-vectorp (car vec)) + (+ count (math-count-elements (car vec))) + (1+ count)))) + count) +) + + +(defun math-flatten-many-vecs (vecs) + (let ((p vecs) + (vec (list 'vec))) + (while p + (setq vec (nconc vec + (if (Math-vectorp (car p)) + (math-flatten-vector (car p)) + (if (Math-objectp (car p)) + (list (car p)) + (if (and (eq (car-safe (car p)) 'var) + (eq (car-safe (calc-var-value + (nth 2 (car p)))) 'vec)) + (math-flatten-vector (symbol-value + (nth 2 (car p)))) + (math-reject-arg (car p) 'numvecp))))) + p (cdr p))) + vec) +) + +(defun calcFunc-vflat (&rest vecs) + (math-flatten-many-vecs vecs) +) + +(defun math-split-sdev-vec (vec zero-ok) + (let ((means (list 'vec)) + (wts (list 'vec)) + (exact nil) + (p vec)) + (while (and (setq p (cdr p)) + (not (and (consp (car p)) + (eq (car (car p)) 'sdev))))) + (if (null p) + (list vec nil) + (while (setq vec (cdr vec)) + (if (and (consp (setq p (car vec))) + (eq (car p) 'sdev)) + (or exact + (setq means (cons (nth 1 p) means) + wts (cons (nth 2 p) wts))) + (if zero-ok + (setq means (cons (nth 1 p) means) + wts (cons 0 wts)) + (or exact + (setq means (list 'vec) + wts nil + exact t)) + (setq means (cons p means))))) + (list (nreverse means) + (and wts (nreverse wts))))) +) + + +;;; Return the arithmetic mean of the argument numbers or vectors. +;;; (If numbers are error forms, computes the weighted mean.) +(defun calcFunc-vmean (&rest vecs) + (let* ((split (math-split-sdev-vec (math-flatten-many-vecs vecs) nil)) + (means (car split)) + (wts (nth 1 split)) + (len (1- (length means)))) + (if (= len 0) + (math-reject-arg nil "*Must be at least 1 argument") + (if (and (= len 1) (eq (car-safe (nth 1 means)) 'intv)) + (let ((x (math-fix-int-intv (nth 1 means)))) + (calcFunc-vmean (nth 2 x) (nth 3 x))) + (math-with-extra-prec 2 + (if (and wts (> len 1)) + (let* ((sqrwts (calcFunc-map '(var mul var-mul) wts wts)) + (suminvsqrwts (calcFunc-reduce + '(var add var-add) + (calcFunc-map '(var div var-div) + 1 sqrwts)))) + (math-div (calcFunc-reduce '(var add var-add) + (calcFunc-map '(var div var-div) + means sqrwts)) + suminvsqrwts)) + (math-div (calcFunc-reduce '(var add var-add) means) len)))))) +) + +(defun math-fix-int-intv (x) + (if (math-floatp x) + x + (list 'intv 3 + (if (memq (nth 1 x) '(2 3)) (nth 2 x) (math-add (nth 2 x) 1)) + (if (memq (nth 1 x) '(1 3)) (nth 3 x) (math-sub (nth 3 x) 1)))) +) + +;;; Compute the mean with an error estimate. +(defun calcFunc-vmeane (&rest vecs) + (let* ((split (math-split-sdev-vec (math-flatten-many-vecs vecs) nil)) + (means (car split)) + (wts (nth 1 split)) + (len (1- (length means)))) + (if (= len 0) + (math-reject-arg nil "*Must be at least 1 argument") + (math-with-extra-prec 2 + (if wts + (let* ((sqrwts (calcFunc-map '(var mul var-mul) wts wts)) + (suminvsqrwts (calcFunc-reduce + '(var add var-add) + (calcFunc-map '(var div var-div) + 1 sqrwts)))) + (math-make-sdev + (math-div (calcFunc-reduce '(var add var-add) + (calcFunc-map '(var div var-div) + means sqrwts)) + suminvsqrwts) + (list 'calcFunc-sqrt (math-div 1 suminvsqrwts)))) + (let ((mean (math-div (calcFunc-reduce '(var add var-add) means) + len))) + (math-make-sdev + mean + (list 'calcFunc-sqrt + (math-div (calcFunc-reducer + '(var add var-add) + (calcFunc-map '(var pow var-pow) + (calcFunc-map '(var abs var-abs) + (calcFunc-map + '(var add var-add) + means + (math-neg mean))) + 2)) + (math-mul len (1- len)))))))))) +) + + +;;; Compute the median of a list of values. +(defun calcFunc-vmedian (&rest vecs) + (let* ((flat (copy-sequence (cdr (math-flatten-many-vecs vecs)))) + (p flat) + (len (length flat)) + (hlen (/ len 2))) + (if (= len 0) + (math-reject-arg nil "*Must be at least 1 argument") + (if (and (= len 1) (memq (car-safe (car flat)) '(sdev intv))) + (calcFunc-vmean (car flat)) + (while p + (if (eq (car-safe (car p)) 'sdev) + (setcar p (nth 1 (car p)))) + (or (Math-anglep (car p)) + (math-reject-arg (car p) 'anglep)) + (setq p (cdr p))) + (setq flat (sort flat 'math-lessp)) + (if (= (% len 2) 0) + (math-div (math-add (nth (1- hlen) flat) (nth hlen flat)) 2) + (nth hlen flat))))) +) + + +(defun calcFunc-vgmean (&rest vecs) + (let* ((flat (math-flatten-many-vecs vecs)) + (len (1- (length flat)))) + (if (= len 0) + (math-reject-arg nil "*Must be at least 1 argument") + (math-with-extra-prec 2 + (let ((x (calcFunc-reduce '(var mul math-mul) flat))) + (if (= len 2) + (math-sqrt x) + (math-pow x (list 'frac 1 len))))))) +) + + +(defun calcFunc-agmean (a b) + (cond ((Math-equal a b) a) + ((math-zerop a) a) + ((math-zerop b) b) + (calc-symbolic-mode (math-inexact-result)) + ((not (Math-realp a)) (math-reject-arg a 'realp)) + ((not (Math-realp b)) (math-reject-arg b 'realp)) + (t + (math-with-extra-prec 2 + (setq a (math-float (math-abs a)) + b (math-float (math-abs b))) + (let (mean) + (while (not (math-nearly-equal-float a b)) + (setq mean (math-mul-float (math-add-float a b) '(float 5 -1)) + b (math-sqrt-float (math-mul-float a b)) + a mean)) + a)))) +) + + +(defun calcFunc-vhmean (&rest vecs) + (let* ((flat (math-flatten-many-vecs vecs)) + (len (1- (length flat)))) + (if (= len 0) + (math-reject-arg nil "*Must be at least 1 argument") + (math-with-extra-prec 2 + (math-div len + (calcFunc-reduce '(var add math-add) + (calcFunc-map '(var inv var-inv) flat)))))) +) + + + +;;; Compute the sample variance or standard deviation of numbers or vectors. +;;; (If the numbers are error forms, only the mean part of them is used.) +(defun calcFunc-vvar (&rest vecs) + (if (and (= (length vecs) 1) + (memq (car-safe (car vecs)) '(sdev intv))) + (if (eq (car-safe (car vecs)) 'intv) + (math-intv-variance (car vecs) nil) + (math-sqr (nth 2 (car vecs)))) + (math-covariance vecs nil nil 0)) +) + +(defun calcFunc-vsdev (&rest vecs) + (if (and (= (length vecs) 1) + (memq (car-safe (car vecs)) '(sdev intv))) + (if (eq (car-safe (car vecs)) 'intv) + (if (math-floatp (car vecs)) + (math-div (math-sub (nth 3 (car vecs)) (nth 2 (car vecs))) + (math-sqrt-12)) + (math-sqrt (calcFunc-vvar (car vecs)))) + (nth 2 (car vecs))) + (math-sqrt (math-covariance vecs nil nil 0))) +) + +;;; Compute the population variance or std deviation of numbers or vectors. +(defun calcFunc-vpvar (&rest vecs) + (if (and (= (length vecs) 1) + (memq (car-safe (car vecs)) '(sdev intv))) + (if (eq (car-safe (car vecs)) 'intv) + (math-intv-variance (car vecs) t) + (math-sqr (nth 2 (car vecs)))) + (math-covariance vecs nil t 0)) +) + +(defun calcFunc-vpsdev (&rest vecs) + (if (and (= (length vecs) 1) + (memq (car-safe (car vecs)) '(sdev intv))) + (if (eq (car-safe (car vecs)) 'intv) + (if (math-floatp (car vecs)) + (math-div (math-sub (nth 3 (car vecs)) (nth 2 (car vecs))) + (math-sqrt-12)) + (math-sqrt (calcFunc-vpvar (car vecs)))) + (nth 2 (car vecs))) + (math-sqrt (math-covariance vecs nil t 0))) +) + +(defun math-intv-variance (x pop) + (or (math-constp x) (math-reject-arg x 'constp)) + (if (math-floatp x) + (math-div (math-sqr (math-sub (nth 3 x) (nth 2 x))) 12) + (let* ((x (math-fix-int-intv x)) + (len (math-sub (nth 3 x) (nth 2 x))) + (hlen (math-quotient len 2))) + (math-div (if (math-evenp len) + (calcFunc-sum '(^ (var X var-X) 2) '(var X var-X) + (math-neg hlen) hlen) + (calcFunc-sum '(^ (- (var X var-X) (/ 1 2)) 2) + '(var X var-X) + (math-neg hlen) (math-add hlen 1))) + (if pop (math-add len 1) len)))) +) + +;;; Compute the covariance and linear correlation coefficient. +(defun calcFunc-vcov (vec1 &optional vec2) + (math-covariance (list vec1) (list vec2) nil 1) +) + +(defun calcFunc-vpcov (vec1 &optional vec2) + (math-covariance (list vec1) (list vec2) t 1) +) + +(defun calcFunc-vcorr (vec1 &optional vec2) + (math-covariance (list vec1) (list vec2) nil 2) +) + + +(defun math-covariance (vec1 vec2 pop mode) + (or (car vec2) (= mode 0) + (progn + (if (and (eq (car-safe (car vec1)) 'var) + (eq (car-safe (calc-var-value (nth 2 (car vec1)))) 'vec)) + (setq vec1 (symbol-value (nth 2 (car vec1)))) + (setq vec1 (car vec1))) + (or (math-matrixp vec1) (math-dimension-error)) + (or (= (length (nth 1 vec1)) 3) (math-dimension-error)) + (setq vec2 (list (math-mat-col vec1 2)) + vec1 (list (math-mat-col vec1 1))))) + (math-with-extra-prec 2 + (let* ((split1 (math-split-sdev-vec (math-flatten-many-vecs vec1) nil)) + (means1 (car split1)) + (wts1 (nth 1 split1)) + split2 means2 (wts2 nil) + (sqrwts nil) + suminvsqrwts + (len (1- (length means1)))) + (if (< len (if pop 1 2)) + (math-reject-arg nil (if pop + "*Must be at least 1 argument" + "*Must be at least 2 arguments"))) + (if (or wts1 wts2) + (setq sqrwts (math-add + (if wts1 + (calcFunc-map '(var mul var-mul) wts1 wts1) + 0) + (if wts2 + (calcFunc-map '(var mul var-mul) wts2 wts2) + 0)) + suminvsqrwts (calcFunc-reduce + '(var add var-add) + (calcFunc-map '(var div var-div) 1 sqrwts)))) + (or (= mode 0) + (progn + (setq split2 (math-split-sdev-vec (math-flatten-many-vecs vec2) + nil) + means2 (car split2) + wts2 (nth 2 split1)) + (or (= len (1- (length means2))) (math-dimension-error)))) + (let* ((diff1 (calcFunc-map + '(var add var-add) + means1 + (if sqrwts + (math-div (calcFunc-reduce + '(var add var-add) + (calcFunc-map '(var div var-div) + means1 sqrwts)) + (math-neg suminvsqrwts)) + (math-div (calcFunc-reducer '(var add var-add) means1) + (- len))))) + (diff2 (if (= mode 0) + diff1 + (calcFunc-map + '(var add var-add) + means2 + (if sqrwts + (math-div (calcFunc-reduce + '(var add var-add) + (calcFunc-map '(var div var-div) + means2 sqrwts)) + (math-neg suminvsqrwts)) + (math-div (calcFunc-reducer '(var add var-add) means2) + (- len)))))) + (covar (calcFunc-map '(var mul var-mul) diff1 diff2))) + (if sqrwts + (setq covar (calcFunc-map '(var div var-div) covar sqrwts))) + (math-div + (calcFunc-reducer '(var add var-add) covar) + (if (= mode 2) + (let ((var1 (calcFunc-map '(var mul var-mul) diff1 diff1)) + (var2 (calcFunc-map '(var mul var-mul) diff2 diff2))) + (if sqrwts + (setq var1 (calcFunc-map '(var div var-div) var1 sqrwts) + var2 (calcFunc-map '(var div var-div) var2 sqrwts))) + (math-sqrt + (math-mul (calcFunc-reducer '(var add var-add) var1) + (calcFunc-reducer '(var add var-add) var2)))) + (if sqrwts + (if pop + suminvsqrwts + (math-div (math-mul suminvsqrwts (1- len)) len)) + (if pop len (1- len)))))))) +) + + + + diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el new file mode 100644 index 0000000000..425cad4750 --- /dev/null +++ b/lisp/calc/calc-store.el @@ -0,0 +1,663 @@ +;; Calculator for GNU Emacs, part II [calc-store.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-store () nil) + + +;;; Memory commands. + +(defun calc-store (&optional var) + (interactive) + (let ((calc-store-keep t)) + (calc-store-into var)) +) +(setq calc-store-keep nil) + +(defun calc-store-into (&optional var) + (interactive) + (calc-wrapper + (let ((calc-given-value nil) + (calc-given-value-flag 1)) + (or var (setq var (calc-read-var-name "Store: " t))) + (if var + (let ((found (assq var '( ( + . calc-store-plus ) + ( - . calc-store-minus ) + ( * . calc-store-times ) + ( / . calc-store-div ) + ( ^ . calc-store-power ) + ( | . calc-store-concat ) )))) + (if found + (funcall (cdr found)) + (calc-store-value var (or calc-given-value (calc-top 1)) + "" calc-given-value-flag) + (message "Stored to variable \"%s\"" (calc-var-name var)))) + (setq var (calc-is-assignments (calc-top 1))) + (if var + (while var + (calc-store-value (car (car var)) (cdr (car var)) + (if (not (cdr var)) "") + (if (not (cdr var)) 1)) + (setq var (cdr var))))))) +) + +(defun calc-store-plus (&optional var) + (interactive) + (calc-store-binary var "+" '+) +) + +(defun calc-store-minus (&optional var) + (interactive) + (calc-store-binary var "-" '-) +) + +(defun calc-store-times (&optional var) + (interactive) + (calc-store-binary var "*" '*) +) + +(defun calc-store-div (&optional var) + (interactive) + (calc-store-binary var "/" '/) +) + +(defun calc-store-power (&optional var) + (interactive) + (calc-store-binary var "^" '^) +) + +(defun calc-store-concat (&optional var) + (interactive) + (calc-store-binary var "|" '|) +) + +(defun calc-store-neg (n &optional var) + (interactive "p") + (calc-store-binary var "n" '/ (- n)) +) + +(defun calc-store-inv (n &optional var) + (interactive "p") + (calc-store-binary var "&" '^ (- n)) +) + +(defun calc-store-incr (n &optional var) + (interactive "p") + (calc-store-binary var "n" '- (- n)) +) + +(defun calc-store-decr (n &optional var) + (interactive "p") + (calc-store-binary var "n" '- n) +) + +(defun calc-store-value (var value tag &optional pop) + (if var + (let ((old (calc-var-value var))) + (set var value) + (if pop (or calc-store-keep (calc-pop-stack pop))) + (calc-record-undo (list 'store (symbol-name var) old)) + (if tag + (let ((calc-full-trail-vectors nil)) + (calc-record value (format ">%s%s" tag (calc-var-name var))))) + (and (memq var '(var-e var-i var-pi var-phi var-gamma)) + (eq (car-safe old) 'special-const) + (message "(Note: Built-in definition of %s has been lost)" var)) + (and (memq var '(var-inf var-uinf var-nan)) + (null old) + (message "(Note: %s has built-in meanings which may interfere)" + var)) + (calc-refresh-evaltos var))) +) + +(defun calc-var-name (var) + (if (symbolp var) (setq var (symbol-name var))) + (if (string-match "\\`var-." var) + (substring var 4) + var) +) + +(defun calc-store-binary (var tag func &optional val) + (calc-wrapper + (let ((calc-simplify-mode (if (eq calc-simplify-mode 'none) + 'num calc-simplify-mode)) + (value (or val (calc-top 1)))) + (or var (setq var (calc-read-var-name (format "Store %s: " tag)))) + (if var + (let ((old (calc-var-value var))) + (or old + (error "No such variable: \"%s\"" (calc-var-name var))) + (if (stringp old) + (setq old (math-read-expr old))) + (if (eq (car-safe old) 'error) + (error "Bad format in variable contents: %s" (nth 2 old))) + (calc-store-value var + (calc-normalize (if (calc-is-inverse) + (list func value old) + (list func old value))) + tag (and (not val) 1)) + (message "Stored to variable \"%s\"" (calc-var-name var)))))) +) + +(defun calc-read-var-name (prompt &optional calc-store-opers) + (setq calc-given-value nil + calc-aborted-prefix nil) + (let ((var (let ((minibuffer-completion-table obarray) + (minibuffer-completion-predicate 'boundp) + (minibuffer-completion-confirm t)) + (read-from-minibuffer prompt "var-" calc-var-name-map nil)))) + (setq calc-aborted-prefix "") + (and (not (equal var "")) + (not (equal var "var-")) + (if (string-match "\\`\\([-a-zA-Z0-9]+\\) *:?=" var) + (if (null calc-given-value-flag) + (error "Assignment is not allowed in this command") + (let ((svar (intern (substring var 0 (match-end 1))))) + (setq calc-given-value-flag 0 + calc-given-value (math-read-expr + (substring var (match-end 0)))) + (if (eq (car-safe calc-given-value) 'error) + (error "Bad format: %s" (nth 2 calc-given-value))) + (setq calc-given-value (math-evaluate-expr calc-given-value)) + svar)) + (intern var)))) +) +(setq calc-given-value-flag nil) + +(defvar calc-var-name-map nil "Keymap for reading Calc variable names.") +(if calc-var-name-map + () + (setq calc-var-name-map (copy-keymap minibuffer-local-completion-map)) + (define-key calc-var-name-map " " 'self-insert-command) + (mapcar (function + (lambda (x) + (define-key calc-var-name-map (char-to-string x) + 'calcVar-digit))) + "0123456789") + (mapcar (function + (lambda (x) + (define-key calc-var-name-map (char-to-string x) + 'calcVar-oper))) + "+-*/^|") +) + +(defun calcVar-digit () + (interactive) + (if (calc-minibuffer-contains "var-\\'") + (if (eq calc-store-opers 0) + (beep) + (insert "q") + (self-insert-and-exit)) + (self-insert-command 1)) +) + +(defun calcVar-oper () + (interactive) + (if (and (eq calc-store-opers t) + (calc-minibuffer-contains "var-\\'")) + (progn + (erase-buffer) + (self-insert-and-exit)) + (self-insert-command 1)) +) + +(defun calc-store-map (&optional oper var) + (interactive) + (calc-wrapper + (let* ((sel-mode nil) + (calc-dollar-values (mapcar 'calc-get-stack-element + (nthcdr calc-stack-top calc-stack))) + (calc-dollar-used 0) + (oper (or oper (calc-get-operator "Store Mapping"))) + (nargs (car oper))) + (or var (setq var (calc-read-var-name (format "Store Mapping %s: " + (nth 2 oper))))) + (if var + (let ((old (or (calc-var-value var) + (error "No such variable: \"%s\"" + (calc-var-name var)))) + (calc-simplify-mode (if (eq calc-simplify-mode 'none) + 'num calc-simplify-mode)) + (values (and (> nargs 1) + (calc-top-list (1- nargs) (1+ calc-dollar-used))))) + (message "Working...") + (calc-set-command-flag 'clear-message) + (if (stringp old) + (setq old (math-read-expr old))) + (if (eq (car-safe old) 'error) + (error "Bad format in variable contents: %s" (nth 2 old))) + (setq values (if (calc-is-inverse) + (append values (list old)) + (append (list old) values))) + (calc-store-value var + (calc-normalize (cons (nth 1 oper) values)) + (nth 2 oper) + (+ calc-dollar-used (1- nargs))))))) +) + +(defun calc-store-exchange (&optional var) + (interactive) + (calc-wrapper + (let ((calc-given-value nil) + (calc-given-value-flag 1) + top) + (or var (setq var (calc-read-var-name "Exchange with: "))) + (if var + (let ((value (calc-var-value var))) + (or value + (error "No such variable: \"%s\"" (calc-var-name var))) + (if (eq (car-safe value) 'special-const) + (error "%s is a special constant" var)) + (setq top (or calc-given-value (calc-top 1))) + (calc-store-value var top nil) + (calc-pop-push-record calc-given-value-flag + (concat "<>" (calc-var-name var)) value))))) +) + +(defun calc-unstore (&optional var) + (interactive) + (calc-wrapper + (or var (setq var (calc-read-var-name "Unstore: "))) + (if var + (progn + (and (memq var '(var-e var-i var-pi var-phi var-gamma)) + (eq (car-safe (calc-var-value var)) 'special-const) + (message "(Note: Built-in definition of %s has been lost)" var)) + (if (and (boundp var) (symbol-value var)) + (message "Unstored variable \"%s\"" (calc-var-name var)) + (message "Variable \"%s\" remains unstored" (calc-var-name var))) + (makunbound var) + (calc-refresh-evaltos var)))) +) + +(defun calc-let (&optional var) + (interactive) + (calc-wrapper + (let* ((calc-given-value nil) + (calc-given-value-flag 1) + thing value) + (or var (setq var (calc-read-var-name "Let variable: "))) + (if calc-given-value + (setq value calc-given-value + thing (calc-top 1)) + (setq value (calc-top 1) + thing (calc-top 2))) + (setq var (if var + (list (cons var value)) + (calc-is-assignments value))) + (if var + (calc-pop-push-record + (1+ calc-given-value-flag) + (concat "=" (calc-var-name (car (car var)))) + (let ((saved-val (mapcar (function + (lambda (v) + (and (boundp (car v)) + (symbol-value (car v))))) + var))) + (unwind-protect + (let ((vv var)) + (while vv + (set (car (car vv)) (calc-normalize (cdr (car vv)))) + (calc-refresh-evaltos (car (car vv))) + (setq vv (cdr vv))) + (math-evaluate-expr thing)) + (while saved-val + (if (car saved-val) + (set (car (car var)) (car saved-val)) + (makunbound (car (car var)))) + (setq saved-val (cdr saved-val) + var (cdr var))) + (calc-handle-whys))))))) +) + +(defun calc-is-assignments (value) + (if (memq (car-safe value) '(calcFunc-eq calcFunc-assign)) + (and (eq (car-safe (nth 1 value)) 'var) + (list (cons (nth 2 (nth 1 value)) (nth 2 value)))) + (if (eq (car-safe value) 'vec) + (let ((vv nil)) + (while (and (setq value (cdr value)) + (memq (car-safe (car value)) + '(calcFunc-eq calcFunc-assign)) + (eq (car-safe (nth 1 (car value))) 'var)) + (setq vv (cons (cons (nth 2 (nth 1 (car value))) + (nth 2 (car value))) + vv))) + (and (not value) + vv)))) +) + +(defun calc-recall (&optional var) + (interactive) + (calc-wrapper + (or var (setq var (calc-read-var-name "Recall: "))) + (if var + (let ((value (calc-var-value var))) + (or value + (error "No such variable: \"%s\"" (calc-var-name var))) + (if (stringp value) + (setq value (math-read-expr value))) + (if (eq (car-safe value) 'error) + (error "Bad format in variable contents: %s" (nth 2 value))) + (setq value (calc-normalize value)) + (let ((calc-full-trail-vectors nil)) + (calc-record value (concat "<" (calc-var-name var)))) + (calc-push value)))) +) + +(defun calc-store-quick () + (interactive) + (calc-store (intern (format "var-q%c" last-command-char))) +) + +(defun calc-store-into-quick () + (interactive) + (calc-store-into (intern (format "var-q%c" last-command-char))) +) + +(defun calc-recall-quick () + (interactive) + (calc-recall (intern (format "var-q%c" last-command-char))) +) + +(defun calc-copy-variable (&optional var1 var2) + (interactive) + (calc-wrapper + (or var1 (setq var1 (calc-read-var-name "Copy variable: "))) + (if var1 + (let ((value (calc-var-value var1))) + (or value + (error "No such variable: \"%s\"" (calc-var-name var))) + (or var2 (setq var2 (calc-read-var-name + (format "Copy variable: %s, to: " var1)))) + (if var2 + (calc-store-value var2 value ""))))) +) + +(defun calc-edit-variable (&optional var) + (interactive) + (calc-wrapper + (or var (setq var (calc-read-var-name + (if calc-last-edited-variable + (format "Edit: (default %s) " + (calc-var-name calc-last-edited-variable)) + "Edit: ")))) + (or var (setq var calc-last-edited-variable)) + (if var + (let* ((value (calc-var-value var))) + (if (eq (car-safe value) 'special-const) + (error "%s is a special constant" var)) + (setq calc-last-edited-variable var) + (calc-edit-mode (list 'calc-finish-stack-edit (list 'quote var)) + t + (concat "Editing " (calc-var-name var))) + (and value + (insert (math-format-nice-expr value (screen-width)) "\n"))))) + (calc-show-edit-buffer) +) +(setq calc-last-edited-variable nil) + +(defun calc-edit-Decls () + (interactive) + (calc-edit-variable 'var-Decls) +) + +(defun calc-edit-EvalRules () + (interactive) + (calc-edit-variable 'var-EvalRules) +) + +(defun calc-edit-FitRules () + (interactive) + (calc-edit-variable 'var-FitRules) +) + +(defun calc-edit-GenCount () + (interactive) + (calc-edit-variable 'var-GenCount) +) + +(defun calc-edit-Holidays () + (interactive) + (calc-edit-variable 'var-Holidays) +) + +(defun calc-edit-IntegLimit () + (interactive) + (calc-edit-variable 'var-IntegLimit) +) + +(defun calc-edit-LineStyles () + (interactive) + (calc-edit-variable 'var-LineStyles) +) + +(defun calc-edit-PointStyles () + (interactive) + (calc-edit-variable 'var-PointStyles) +) + +(defun calc-edit-PlotRejects () + (interactive) + (calc-edit-variable 'var-PlotRejects) +) + +(defun calc-edit-AlgSimpRules () + (interactive) + (calc-edit-variable 'var-AlgSimpRules) +) + +(defun calc-edit-TimeZone () + (interactive) + (calc-edit-variable 'var-TimeZone) +) + +(defun calc-edit-Units () + (interactive) + (calc-edit-variable 'var-Units) +) + +(defun calc-edit-ExtSimpRules () + (interactive) + (calc-edit-variable 'var-ExtSimpRules) +) + +(defun calc-declare-variable (&optional var) + (interactive) + (calc-wrapper + (or var (setq var (calc-read-var-name "Declare: " 0))) + (or var (setq var 'var-All)) + (let* (dp decl def row rp) + (or (and (calc-var-value 'var-Decls) + (eq (car-safe var-Decls) 'vec)) + (setq var-Decls (list 'vec))) + (setq dp var-Decls) + (while (and (setq dp (cdr dp)) + (or (not (eq (car-safe (car dp)) 'vec)) + (/= (length (car dp)) 3) + (progn + (setq row (nth 1 (car dp)) + rp row) + (if (eq (car-safe row) 'vec) + (progn + (while + (and (setq rp (cdr rp)) + (or (not (eq (car-safe (car rp)) 'var)) + (not (eq (nth 2 (car rp)) var))))) + (setq rp (car rp))) + (if (or (not (eq (car-safe row) 'var)) + (not (eq (nth 2 row) var))) + (setq rp nil))) + (not rp))))) + (calc-unread-command ?\C-a) + (setq decl (read-string (format "Declare: %s to be: " var) + (and rp + (math-format-flat-expr (nth 2 (car dp)) 0)))) + (setq decl (and (string-match "[^ \t]" decl) + (math-read-exprs decl))) + (if (eq (car-safe decl) 'error) + (error "Bad format in declaration: %s" (nth 2 decl))) + (if (cdr decl) + (setq decl (cons 'vec decl)) + (setq decl (car decl))) + (and (eq (car-safe decl) 'vec) + (= (length decl) 2) + (setq decl (nth 1 decl))) + (calc-record (append '(vec) (list (math-build-var-name var)) + (and decl (list decl))) + "decl") + (setq var-Decls (copy-sequence var-Decls)) + (if (eq (car-safe row) 'vec) + (progn + (setcdr row (delq rp (cdr row))) + (or (cdr row) + (setq var-Decls (delq (car dp) var-Decls)))) + (setq var-Decls (delq (car dp) var-Decls))) + (if decl + (progn + (setq dp (and (not (eq var 'var-All)) var-Decls)) + (while (and (setq dp (cdr dp)) + (or (not (eq (car-safe (car dp)) 'vec)) + (/= (length (car dp)) 3) + (not (equal (nth 2 (car dp)) decl))))) + (if dp + (setcar (cdr (car dp)) + (append (if (eq (car-safe (nth 1 (car dp))) 'vec) + (nth 1 (car dp)) + (list 'vec (nth 1 (car dp)))) + (list (math-build-var-name var)))) + (setq var-Decls (append var-Decls + (list (list 'vec + (math-build-var-name var) + decl))))))) + (calc-refresh-evaltos 'var-Decls))) +) + +(defun calc-permanent-variable (&optional var) + (interactive) + (calc-wrapper + (or var (setq var (calc-read-var-name "Save variable (default=all): "))) + (let (pos) + (and var (or (and (boundp var) (symbol-value var)) + (error "No such variable"))) + (set-buffer (find-file-noselect (substitute-in-file-name + calc-settings-file))) + (if var + (calc-insert-permanent-variable var) + (mapatoms (function + (lambda (x) + (and (string-match "\\`var-" (symbol-name x)) + (not (memq x calc-dont-insert-variables)) + (calc-var-value x) + (not (eq (car-safe (symbol-value x)) 'special-const)) + (calc-insert-permanent-variable x)))))) + (save-buffer))) +) +(defvar calc-dont-insert-variables '(var-FitRules var-FactorRules + var-CommuteRules var-JumpRules + var-DistribRules var-MergeRules + var-NegateRules var-InvertRules + var-IntegAfterRules + var-TimeZone var-PlotRejects + var-PlotData1 var-PlotData2 + var-PlotData3 var-PlotData4 + var-PlotData5 var-PlotData6 + var-DUMMY +)) + +(defun calc-insert-permanent-variable (var) + (goto-char (point-min)) + (if (search-forward (concat "(setq " (symbol-name var) " '") nil t) + (progn + (setq pos (point-marker)) + (forward-line -1) + (if (looking-at ";;; Variable .* stored by Calc on ") + (progn + (delete-region (match-end 0) (progn (end-of-line) (point))) + (insert (current-time-string)))) + (goto-char (- pos 8 (length (symbol-name var)))) + (forward-sexp 1) + (backward-char 1) + (delete-region pos (point))) + (goto-char (point-max)) + (insert "\n;;; Variable \"" + (symbol-name var) + "\" stored by Calc on " + (current-time-string) + "\n(setq " + (symbol-name var) + " ')\n") + (backward-char 2)) + (insert (prin1-to-string (calc-var-value var))) + (forward-line 1) +) + +(defun calc-insert-variables (buf) + (interactive "bBuffer in which to save variable values: ") + (save-excursion + (set-buffer buf) + (mapatoms (function + (lambda (x) + (and (string-match "\\`var-" (symbol-name x)) + (not (memq x calc-dont-insert-variables)) + (calc-var-value x) + (not (eq (car-safe (symbol-value x)) 'special-const)) + (or (not (eq x 'var-Decls)) + (not (equal var-Decls '(vec)))) + (or (not (eq x 'var-Holidays)) + (not (equal var-Holidays '(vec (var sat var-sat) + (var sun var-sun))))) + (insert "(setq " + (symbol-name x) + " " + (prin1-to-string + (let ((calc-language + (if (memq calc-language '(nil big)) + 'flat + calc-language))) + (math-format-value (symbol-value x) 100000))) + ")\n")))))) +) + +(defun calc-assign (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op ":=" 'calcFunc-assign arg)) +) + +(defun calc-evalto (arg) + (interactive "P") + (calc-slow-wrapper + (calc-unary-op "=>" 'calcFunc-evalto arg)) +) + +(defun calc-subscript (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "sub" 'calcFunc-subscr arg)) +) + diff --git a/lisp/calc/calc-stuff.el b/lisp/calc/calc-stuff.el new file mode 100644 index 0000000000..e2a42d9282 --- /dev/null +++ b/lisp/calc/calc-stuff.el @@ -0,0 +1,300 @@ +;; Calculator for GNU Emacs, part II [calc-stuff.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-stuff () nil) + + +(defun calc-num-prefix (n) + "Use the number at the top of stack as the numeric prefix for the next command. +With a prefix, push that prefix as a number onto the stack." + (interactive "P") + (calc-wrapper + (if n + (calc-enter-result 0 "" (prefix-numeric-value n)) + (let ((num (calc-top 1))) + (if (math-messy-integerp num) + (setq num (math-trunc num))) + (or (integerp num) + (error "Argument must be a small integer")) + (calc-pop-stack 1) + (setq prefix-arg num) + (message "%d-" num)))) ; a (lame) simulation of the real thing... +) + + +(defun calc-more-recursion-depth (n) + (interactive "P") + (calc-wrapper + (if (calc-is-inverse) + (calc-less-recursion-depth n) + (let ((n (if n (prefix-numeric-value n) 2))) + (if (> n 1) + (setq max-specpdl-size (* max-specpdl-size n) + max-lisp-eval-depth (* max-lisp-eval-depth n)))) + (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth))) +) + +(defun calc-less-recursion-depth (n) + (interactive "P") + (let ((n (if n (prefix-numeric-value n) 2))) + (if (> n 1) + (setq max-specpdl-size + (max (/ max-specpdl-size n) 600) + max-lisp-eval-depth + (max (/ max-lisp-eval-depth n) 200)))) + (message "max-lisp-eval-depth is now %d" max-lisp-eval-depth) +) + + +(defun calc-explain-why (why &optional more) + (if (eq (car why) '*) + (setq why (cdr why))) + (let* ((pred (car why)) + (arg (nth 1 why)) + (msg (cond ((not pred) "Wrong type of argument") + ((stringp pred) pred) + ((eq pred 'integerp) "Integer expected") + ((eq pred 'natnump) + (if (and arg (Math-objvecp arg) (not (Math-integerp arg))) + "Integer expected" + "Nonnegative integer expected")) + ((eq pred 'posintp) + (if (and arg (Math-objvecp arg) (not (Math-integerp arg))) + "Integer expected" + "Positive integer expected")) + ((eq pred 'fixnump) + (if (and arg (Math-integerp arg)) + "Small integer expected" + "Integer expected")) + ((eq pred 'fixnatnump) + (if (and arg (Math-natnump arg)) + "Small integer expected" + (if (and arg (Math-objvecp arg) + (not (Math-integerp arg))) + "Integer expected" + "Nonnegative integer expected"))) + ((eq pred 'fixposintp) + (if (and arg (Math-integerp arg) (Math-posp arg)) + "Small integer expected" + (if (and arg (Math-objvecp arg) + (not (Math-integerp arg))) + "Integer expected" + "Positive integer expected"))) + ((eq pred 'posp) "Positive number expected") + ((eq pred 'negp) "Negative number expected") + ((eq pred 'nonzerop) "Nonzero number expected") + ((eq pred 'realp) "Real number expected") + ((eq pred 'anglep) "Real number expected") + ((eq pred 'hmsp) "HMS form expected") + ((eq pred 'datep) + (if (and arg (Math-objectp arg) + (not (Math-realp arg))) + "Real number or date form expected" + "Date form expected")) + ((eq pred 'numberp) "Number expected") + ((eq pred 'scalarp) "Number expected") + ((eq pred 'vectorp) "Vector or matrix expected") + ((eq pred 'numvecp) "Number or vector expected") + ((eq pred 'matrixp) "Matrix expected") + ((eq pred 'square-matrixp) + (if (and arg (math-matrixp arg)) + "Square matrix expected" + "Matrix expected")) + ((eq pred 'objectp) "Number expected") + ((eq pred 'constp) "Constant expected") + ((eq pred 'range) "Argument out of range") + (t (format "%s expected" pred)))) + (punc ": ") + (calc-can-abbrev-vectors t)) + (while (setq why (cdr why)) + (and (car why) + (setq msg (concat msg punc (if (stringp (car why)) + (car why) + (math-format-flat-expr (car why) 0))) + punc ", "))) + (message "%s%s" msg (if more " [w=more]" ""))) +) + +(defun calc-why () + (interactive) + (if (not (eq this-command last-command)) + (if (eq last-command calc-last-why-command) + (setq calc-which-why (cdr calc-why)) + (setq calc-which-why calc-why))) + (if calc-which-why + (progn + (calc-explain-why (car calc-which-why) (cdr calc-which-why)) + (setq calc-which-why (cdr calc-which-why))) + (if calc-why + (progn + (message "(No further explanations available)") + (setq calc-which-why calc-why)) + (message "No explanations available"))) +) +(setq calc-which-why nil) +(setq calc-last-why-command nil) + + +(defun calc-version () + (interactive) + (message "Calc %s, installed %s" calc-version calc-installed-date)) + + +(defun calc-flush-caches () + (interactive) + (calc-wrapper + (setq math-lud-cache nil + math-log2-cache nil + math-radix-digits-cache nil + math-radix-float-cache-tag nil + math-random-cache nil + math-max-digits-cache nil + math-checked-rewrites nil + math-integral-cache nil + math-units-table nil + math-decls-cache-tag nil + math-eval-rules-cache-tag t + math-graph-var-cache nil + math-graph-data-cache nil + math-format-date-cache nil + math-holidays-cache-tag t) + (mapcar (function (lambda (x) (set x -100))) math-cache-list) + (message "All internal calculator caches have been reset.")) +) + + +;;; Conversions. + +(defun calc-clean (n) + (interactive "P") + (calc-slow-wrapper + (calc-with-default-simplification + (let ((func (if (calc-is-hyperbolic) 'calcFunc-clean 'calcFunc-pclean))) + (calc-enter-result 1 "cln" + (if n + (let ((n (prefix-numeric-value n))) + (list func + (calc-top-n 1) + (if (<= n 0) + (+ n calc-internal-prec) + n))) + (list func (calc-top-n 1))))))) +) + +(defun calc-clean-num (num) + (interactive "P") + (calc-clean (- (if num + (prefix-numeric-value num) + (if (and (>= last-command-char ?0) + (<= last-command-char ?9)) + (- last-command-char ?0) + (error "Number required"))))) +) + + +(defun calcFunc-clean (a &optional prec) ; [X X S] [Public] + (if prec + (cond ((Math-messy-integerp prec) + (calcFunc-clean a (math-trunc prec))) + ((or (not (integerp prec)) + (< prec 3)) + (calc-record-why "*Precision must be an integer 3 or above") + (list 'calcFunc-clean a prec)) + ((not (Math-objvecp a)) + (list 'calcFunc-clean a prec)) + (t (let ((calc-internal-prec prec) + (math-chopping-small t)) + (calcFunc-clean (math-normalize a))))) + (cond ((eq (car-safe a) 'polar) + (let ((theta (math-mod (nth 2 a) + (if (eq calc-angle-mode 'rad) + (math-two-pi) + 360)))) + (math-neg + (math-neg + (math-normalize + (list 'polar + (calcFunc-clean (nth 1 a)) + (calcFunc-clean theta))))))) + ((memq (car-safe a) '(vec date hms)) + (cons (car a) (mapcar 'calcFunc-clean (cdr a)))) + ((memq (car-safe a) '(cplx mod sdev intv)) + (math-normalize (cons (car a) (mapcar 'calcFunc-clean (cdr a))))) + ((eq (car-safe a) 'float) + (if math-chopping-small + (if (or (> (nth 2 a) (- calc-internal-prec)) + (Math-lessp (- calc-internal-prec) (calcFunc-xpon a))) + (if (and (math-num-integerp a) + (math-lessp (calcFunc-xpon a) calc-internal-prec)) + (math-trunc a) + a) + 0) + a)) + ((Math-objectp a) a) + ((math-infinitep a) a) + (t (list 'calcFunc-clean a)))) +) +(setq math-chopping-small nil) + +(defun calcFunc-pclean (a &optional prec) + (math-map-over-constants (function (lambda (x) (calcFunc-clean x prec))) + a) +) + +(defun calcFunc-pfloat (a) + (math-map-over-constants 'math-float a) +) + +(defun calcFunc-pfrac (a &optional tol) + (math-map-over-constants (function (lambda (x) (calcFunc-frac x tol))) + a) +) + +(defun math-map-over-constants (func expr) + (math-map-over-constants-rec expr) +) + +(defun math-map-over-constants-rec (expr) + (cond ((or (Math-primp expr) + (memq (car expr) '(intv sdev))) + (or (and (Math-objectp expr) + (funcall func expr)) + expr)) + ((and (memq (car expr) '(^ calcFunc-subscr)) + (eq func 'math-float) + (= (length expr) 3) + (Math-integerp (nth 2 expr))) + (list (car expr) + (math-map-over-constants-rec (nth 1 expr)) + (nth 2 expr))) + (t (cons (car expr) (mapcar 'math-map-over-constants-rec (cdr expr))))) +) + + + + diff --git a/lisp/calc/calc-trail.el b/lisp/calc/calc-trail.el new file mode 100644 index 0000000000..e208140f99 --- /dev/null +++ b/lisp/calc/calc-trail.el @@ -0,0 +1,190 @@ +;; Calculator for GNU Emacs, part II [calc-trail.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-trail () nil) + + +;;; Trail commands. + +(defun calc-trail-in () + (interactive) + (let ((win (get-buffer-window (calc-trail-display t)))) + (and win (select-window win))) +) + +(defun calc-trail-out () + (interactive) + (calc-select-buffer) + (let ((win (get-buffer-window (current-buffer)))) + (if win + (progn + (select-window win) + (calc-align-stack-window)) + (calc))) +) + +(defun calc-trail-next (n) + (interactive "p") + (calc-with-trail-buffer + (forward-line n) + (calc-trail-here)) +) + +(defun calc-trail-previous (n) + (interactive "p") + (calc-with-trail-buffer + (forward-line (- n)) + (calc-trail-here)) +) + +(defun calc-trail-first (n) + (interactive "p") + (calc-with-trail-buffer + (goto-char (point-min)) + (forward-line n) + (calc-trail-here)) +) + +(defun calc-trail-last (n) + (interactive "p") + (calc-with-trail-buffer + (goto-char (point-max)) + (forward-line (- n)) + (calc-trail-here)) +) + +(defun calc-trail-scroll-left (n) + (interactive "P") + (let ((curwin (selected-window))) + (calc-with-trail-buffer + (unwind-protect + (progn + (select-window (get-buffer-window (current-buffer))) + (calc-scroll-left n)) + (select-window curwin)))) +) + +(defun calc-trail-scroll-right (n) + (interactive "P") + (let ((curwin (selected-window))) + (calc-with-trail-buffer + (unwind-protect + (progn + (select-window (get-buffer-window (current-buffer))) + (calc-scroll-right n)) + (select-window curwin)))) +) + +(defun calc-trail-forward (n) + (interactive "p") + (calc-with-trail-buffer + (forward-line (* n (1- (window-height)))) + (calc-trail-here)) +) + +(defun calc-trail-backward (n) + (interactive "p") + (calc-with-trail-buffer + (forward-line (- (* n (1- (window-height))))) + (calc-trail-here)) +) + +(defun calc-trail-isearch-forward () + (interactive) + (calc-with-trail-buffer + (save-window-excursion + (select-window (get-buffer-window (current-buffer))) + (let ((search-exit-char ?\r)) + (isearch-forward))) + (calc-trail-here)) +) + +(defun calc-trail-isearch-backward () + (interactive) + (calc-with-trail-buffer + (save-window-excursion + (select-window (get-buffer-window (current-buffer))) + (let ((search-exit-char ?\r)) + (isearch-backward))) + (calc-trail-here)) +) + +(defun calc-trail-yank (arg) + (interactive "P") + (calc-wrapper + (or arg (calc-set-command-flag 'hold-trail)) + (calc-enter-result 0 "yank" + (calc-with-trail-buffer + (if arg + (forward-line (- (prefix-numeric-value arg)))) + (if (or (looking-at "Emacs Calc") + (looking-at "----") + (looking-at " ? ? ?[^ \n]* *$") + (looking-at "..?.?$")) + (error "Can't yank that line")) + (if (looking-at ".*, \\.\\.\\., ") + (error "Can't yank (vector was abbreviated)")) + (forward-char 4) + (search-forward " ") + (let* ((next (save-excursion (forward-line 1) (point))) + (str (buffer-substring (point) (1- next))) + (val (save-excursion + (set-buffer save-buf) + (math-read-plain-expr str)))) + (if (eq (car-safe val) 'error) + (error "Can't yank that line: %s" (nth 2 val)) + val))))) +) + +(defun calc-trail-marker (str) + (interactive "sText to insert in trail: ") + (calc-with-trail-buffer + (forward-line 1) + (let ((buffer-read-only nil)) + (insert "---- " str "\n")) + (forward-line -1) + (calc-trail-here)) +) + +(defun calc-trail-kill (n) + (interactive "p") + (calc-with-trail-buffer + (let ((buffer-read-only nil)) + (save-restriction + (narrow-to-region ; don't delete "Emacs Trail" header + (save-excursion + (goto-char (point-min)) + (forward-line 1) + (point)) + (point-max)) + (kill-line n))) + (calc-trail-here)) +) + + + diff --git a/lisp/calc/calc-undo.el b/lisp/calc/calc-undo.el new file mode 100644 index 0000000000..52ef7d48cd --- /dev/null +++ b/lisp/calc/calc-undo.el @@ -0,0 +1,159 @@ +;; Calculator for GNU Emacs, part II [calc-undo.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-undo () nil) + + +;;; Undo. + +(defun calc-undo (n) + (interactive "p") + (and calc-executing-macro + (error "Use C-x e, not X, to run a keyboard macro that uses Undo.")) + (if (<= n 0) + (if (< n 0) + (calc-redo (- n)) + (calc-last-args 1)) + (calc-wrapper + (if (null (nthcdr (1- n) calc-undo-list)) + (error "No further undo information available")) + (setq calc-undo-list + (prog1 + (nthcdr n calc-undo-list) + (let ((saved-stack-top calc-stack-top)) + (let ((calc-stack-top 0)) + (calc-handle-undos calc-undo-list n)) + (setq calc-stack-top saved-stack-top)))) + (message "Undo!"))) +) + +(defun calc-handle-undos (cl n) + (if (> n 0) + (progn + (let ((old-redo calc-redo-list)) + (setq calc-undo-list nil) + (calc-handle-undo (car cl)) + (setq calc-redo-list (append calc-undo-list old-redo))) + (calc-handle-undos (cdr cl) (1- n)))) +) + +(defun calc-handle-undo (list) + (and list + (let ((action (car list))) + (cond + ((eq (car action) 'push) + (calc-pop-stack 1 (nth 1 action) t)) + ((eq (car action) 'pop) + (calc-push-list (nth 2 action) (nth 1 action))) + ((eq (car action) 'set) + (calc-record-undo (list 'set (nth 1 action) + (symbol-value (nth 1 action)))) + (set (nth 1 action) (nth 2 action))) + ((eq (car action) 'store) + (let ((v (intern (nth 1 action)))) + (calc-record-undo (list 'store (nth 1 action) + (and (boundp v) (symbol-value v)))) + (if (y-or-n-p (format "Un-store variable %s? " (nth 1 action))) + (progn + (if (nth 2 action) + (set v (nth 2 action)) + (makunbound v)) + (calc-refresh-evaltos v))))) + ((eq (car action) 'eval) + (calc-record-undo (append (list 'eval (nth 2 action) (nth 1 action)) + (cdr (cdr (cdr action))))) + (apply (nth 1 action) (cdr (cdr (cdr action)))))) + (calc-handle-undo (cdr list)))) +) + +(defun calc-redo (n) + (interactive "p") + (and calc-executing-macro + (error "Use C-x e, not X, to run a keyboard macro that uses Redo.")) + (if (<= n 0) + (calc-undo (- n)) + (calc-wrapper + (if (null (nthcdr (1- n) calc-redo-list)) + (error "Unable to redo")) + (setq calc-redo-list + (prog1 + (nthcdr n calc-redo-list) + (let ((saved-stack-top calc-stack-top)) + (let ((calc-stack-top 0)) + (calc-handle-redos calc-redo-list n)) + (setq calc-stack-top saved-stack-top)))) + (message "Redo!"))) +) + +(defun calc-handle-redos (cl n) + (if (> n 0) + (progn + (let ((old-undo calc-undo-list)) + (setq calc-undo-list nil) + (calc-handle-undo (car cl)) + (setq calc-undo-list (append calc-undo-list old-undo))) + (calc-handle-redos (cdr cl) (1- n)))) +) + +(defun calc-last-args (n) + (interactive "p") + (and calc-executing-macro + (error "Use C-x e, not X, to run a keyboard macro that uses last-args.")) + (calc-wrapper + (let ((urec (calc-find-last-x calc-undo-list n))) + (if urec + (calc-handle-last-x urec) + (error "Not enough undo information available")))) +) + +(defun calc-handle-last-x (list) + (and list + (let ((action (car list))) + (if (eq (car action) 'pop) + (calc-pop-push-record-list 0 "larg" + (delq 'top-of-stack (nth 2 action)))) + (calc-handle-last-x (cdr list)))) +) + +(defun calc-find-last-x (ul n) + (and ul + (if (calc-undo-does-pushes (car ul)) + (if (<= n 1) + (car ul) + (calc-find-last-x (cdr ul) (1- n))) + (calc-find-last-x (cdr ul) n))) +) + +(defun calc-undo-does-pushes (list) + (and list + (or (eq (car (car list)) 'pop) + (calc-undo-does-pushes (cdr list)))) +) + + + diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el new file mode 100644 index 0000000000..80c30622b3 --- /dev/null +++ b/lisp/calc/calc-units.el @@ -0,0 +1,1352 @@ +;; Calculator for GNU Emacs, part II [calc-units.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-units () nil) + + +;;; Units commands. + +(defun calc-base-units () + (interactive) + (calc-slow-wrapper + (let ((calc-autorange-units nil)) + (calc-enter-result 1 "bsun" (math-simplify-units + (math-to-standard-units (calc-top-n 1) + nil))))) +) + +(defun calc-quick-units () + (interactive) + (calc-slow-wrapper + (let* ((num (- last-command-char ?0)) + (pos (if (= num 0) 10 num)) + (units (calc-var-value 'var-Units)) + (expr (calc-top-n 1))) + (or (and (>= num 0) (<= num 9)) + (error "Bad unit number")) + (or (math-vectorp units) + (error "No \"quick units\" are defined")) + (or (< pos (length units)) + (error "Unit number %d not defined" pos)) + (if (math-units-in-expr-p expr nil) + (calc-enter-result 1 (format "cun%d" num) + (math-convert-units expr (nth pos units))) + (calc-enter-result 1 (format "*un%d" num) + (math-simplify-units + (math-mul expr (nth pos units))))))) +) + +(defun calc-convert-units (&optional old-units new-units) + (interactive) + (calc-slow-wrapper + (let ((expr (calc-top-n 1)) + (uoldname nil) + unew) + (or (math-units-in-expr-p expr t) + (let ((uold (or old-units + (progn + (setq uoldname (read-string "Old units: ")) + (if (equal uoldname "") + (progn + (setq uoldname "1") + 1) + (if (string-match "\\` */" uoldname) + (setq uoldname (concat "1" uoldname))) + (math-read-expr uoldname)))))) + (if (eq (car-safe uold) 'error) + (error "Bad format in units expression: %s" (nth 1 uold))) + (setq expr (math-mul expr uold)))) + (or new-units + (setq new-units (read-string (if uoldname + (concat "Old units: " + uoldname + ", new units: ") + "New units: ")))) + (if (string-match "\\` */" new-units) + (setq new-units (concat "1" new-units))) + (setq units (math-read-expr new-units)) + (if (eq (car-safe units) 'error) + (error "Bad format in units expression: %s" (nth 2 units))) + (let ((unew (math-units-in-expr-p units t)) + (std (and (eq (car-safe units) 'var) + (assq (nth 1 units) math-standard-units-systems)))) + (if std + (calc-enter-result 1 "cvun" (math-simplify-units + (math-to-standard-units expr + (nth 1 std)))) + (or unew + (error "No units specified")) + (calc-enter-result 1 "cvun" + (math-convert-units + expr units + (and uoldname (not (equal uoldname "1"))))))))) +) + +(defun calc-autorange-units (arg) + (interactive "P") + (calc-wrapper + (calc-change-mode 'calc-autorange-units arg nil t) + (message (if calc-autorange-units + "Adjusting target unit prefix automatically." + "Using target units exactly."))) +) + +(defun calc-convert-temperature (&optional old-units new-units) + (interactive) + (calc-slow-wrapper + (let ((expr (calc-top-n 1)) + (uold nil) + (uoldname nil) + unew) + (setq uold (or old-units + (let ((units (math-single-units-in-expr-p expr))) + (if units + (if (consp units) + (list 'var (car units) + (intern (concat "var-" + (symbol-name + (car units))))) + (error "Not a pure temperature expression")) + (math-read-expr + (setq uoldname (read-string + "Old temperature units: "))))))) + (if (eq (car-safe uold) 'error) + (error "Bad format in units expression: %s" (nth 2 uold))) + (or (math-units-in-expr-p expr nil) + (setq expr (math-mul expr uold))) + (setq unew (or new-units + (math-read-expr + (read-string (if uoldname + (concat "Old temperature units: " + uoldname + ", new units: ") + "New temperature units: "))))) + (if (eq (car-safe unew) 'error) + (error "Bad format in units expression: %s" (nth 2 unew))) + (calc-enter-result 1 "cvtm" (math-simplify-units + (math-convert-temperature expr uold unew + uoldname))))) +) + +(defun calc-remove-units () + (interactive) + (calc-slow-wrapper + (calc-enter-result 1 "rmun" (math-simplify-units + (math-remove-units (calc-top-n 1))))) +) + +(defun calc-extract-units () + (interactive) + (calc-slow-wrapper + (calc-enter-result 1 "rmun" (math-simplify-units + (math-extract-units (calc-top-n 1))))) +) + +(defun calc-explain-units () + (interactive) + (calc-wrapper + (let ((num-units nil) + (den-units nil)) + (calc-explain-units-rec (calc-top-n 1) 1) + (and den-units (string-match "^[^(].* .*[^)]$" den-units) + (setq den-units (concat "(" den-units ")"))) + (if num-units + (if den-units + (message "%s per %s" num-units den-units) + (message "%s" num-units)) + (if den-units + (message "1 per %s" den-units) + (message "No units in expression"))))) +) + +(defun calc-explain-units-rec (expr pow) + (let ((u (math-check-unit-name expr)) + pos) + (if (and u (not (math-zerop pow))) + (let ((name (or (nth 2 u) (symbol-name (car u))))) + (if (eq (aref name 0) ?\*) + (setq name (substring name 1))) + (if (string-match "[^a-zA-Z0-9']" name) + (if (string-match "^[a-zA-Z0-9' ()]*$" name) + (while (setq pos (string-match "[ ()]" name)) + (setq name (concat (substring name 0 pos) + (if (eq (aref name pos) 32) "-" "") + (substring name (1+ pos))))) + (setq name (concat "(" name ")")))) + (or (eq (nth 1 expr) (car u)) + (setq name (concat (nth 2 (assq (aref (symbol-name + (nth 1 expr)) 0) + math-unit-prefixes)) + (if (and (string-match "[^a-zA-Z0-9']" name) + (not (memq (car u) '(mHg gf)))) + (concat "-" name) + (downcase name))))) + (cond ((or (math-equal-int pow 1) + (math-equal-int pow -1))) + ((or (math-equal-int pow 2) + (math-equal-int pow -2)) + (if (equal (nth 4 u) '((m . 1))) + (setq name (concat "Square-" name)) + (setq name (concat name "-squared")))) + ((or (math-equal-int pow 3) + (math-equal-int pow -3)) + (if (equal (nth 4 u) '((m . 1))) + (setq name (concat "Cubic-" name)) + (setq name (concat name "-cubed")))) + (t + (setq name (concat name "^" + (math-format-number (math-abs pow)))))) + (if (math-posp pow) + (setq num-units (if num-units + (concat num-units " " name) + name)) + (setq den-units (if den-units + (concat den-units " " name) + name)))) + (cond ((eq (car-safe expr) '*) + (calc-explain-units-rec (nth 1 expr) pow) + (calc-explain-units-rec (nth 2 expr) pow)) + ((eq (car-safe expr) '/) + (calc-explain-units-rec (nth 1 expr) pow) + (calc-explain-units-rec (nth 2 expr) (- pow))) + ((memq (car-safe expr) '(neg + -)) + (calc-explain-units-rec (nth 1 expr) pow)) + ((and (eq (car-safe expr) '^) + (math-realp (nth 2 expr))) + (calc-explain-units-rec (nth 1 expr) + (math-mul pow (nth 2 expr))))))) +) + +(defun calc-simplify-units () + (interactive) + (calc-slow-wrapper + (calc-with-default-simplification + (calc-enter-result 1 "smun" (math-simplify-units (calc-top-n 1))))) +) + +(defun calc-view-units-table (n) + (interactive "P") + (and n (setq math-units-table-buffer-valid nil)) + (let ((win (get-buffer-window "*Units Table*"))) + (if (and win + math-units-table + math-units-table-buffer-valid) + (progn + (bury-buffer (window-buffer win)) + (let ((curwin (selected-window))) + (select-window win) + (switch-to-buffer nil) + (select-window curwin))) + (math-build-units-table-buffer nil))) +) + +(defun calc-enter-units-table (n) + (interactive "P") + (and n (setq math-units-table-buffer-valid nil)) + (math-build-units-table-buffer t) + (message (substitute-command-keys "Type \\[calc] to return to the Calculator.")) +) + +(defun calc-define-unit (uname desc) + (interactive "SDefine unit name: \nsDescription: ") + (calc-wrapper + (let ((form (calc-top-n 1)) + (unit (assq uname math-additional-units))) + (or unit + (setq math-additional-units + (cons (setq unit (list uname nil nil)) + math-additional-units) + math-units-table nil)) + (setcar (cdr unit) (and (not (and (eq (car-safe form) 'var) + (eq (nth 1 form) uname))) + (not (math-equal-int form 1)) + (math-format-flat-expr form 0))) + (setcar (cdr (cdr unit)) (and (not (equal desc "")) + desc)))) + (calc-invalidate-units-table) +) + +(defun calc-undefine-unit (uname) + (interactive "SUndefine unit name: ") + (calc-wrapper + (let ((unit (assq uname math-additional-units))) + (or unit + (if (assq uname math-standard-units) + (error "\"%s\" is a predefined unit name" uname) + (error "Unit name \"%s\" not found" uname))) + (setq math-additional-units (delq unit math-additional-units) + math-units-table nil))) + (calc-invalidate-units-table) +) + +(defun calc-invalidate-units-table () + (setq math-units-table nil) + (let ((buf (get-buffer "*Units Table*"))) + (and buf + (save-excursion + (set-buffer buf) + (save-excursion + (goto-char (point-min)) + (if (looking-at "Calculator Units Table") + (let ((buffer-read-only nil)) + (insert "(Obsolete) "))))))) +) + +(defun calc-get-unit-definition (uname) + (interactive "SGet definition for unit: ") + (calc-wrapper + (math-build-units-table) + (let ((unit (assq uname math-units-table))) + (or unit + (error "Unit name \"%s\" not found" uname)) + (let ((msg (nth 2 unit))) + (if (stringp msg) + (if (string-match "^\\*" msg) + (setq msg (substring msg 1))) + (setq msg (symbol-name uname))) + (if (nth 1 unit) + (progn + (calc-enter-result 0 "ugdf" (nth 1 unit)) + (message "Derived unit: %s" msg)) + (calc-enter-result 0 "ugdf" (list 'var uname + (intern + (concat "var-" + (symbol-name uname))))) + (message "Base unit: %s" msg))))) +) + +(defun calc-permanent-units () + (interactive) + (calc-wrapper + (let (pos) + (set-buffer (find-file-noselect (substitute-in-file-name + calc-settings-file))) + (goto-char (point-min)) + (if (and (search-forward ";;; Custom units stored by Calc" nil t) + (progn + (beginning-of-line) + (setq pos (point)) + (search-forward "\n;;; End of custom units" nil t))) + (progn + (beginning-of-line) + (forward-line 1) + (delete-region pos (point))) + (goto-char (point-max)) + (insert "\n\n") + (forward-char -1)) + (insert ";;; Custom units stored by Calc on " (current-time-string) "\n") + (if math-additional-units + (progn + (insert "(setq math-additional-units '(\n") + (let ((list math-additional-units)) + (while list + (insert " (" (symbol-name (car (car list))) " " + (if (nth 1 (car list)) + (if (stringp (nth 1 (car list))) + (prin1-to-string (nth 1 (car list))) + (prin1-to-string (math-format-flat-expr + (nth 1 (car list)) 0))) + "nil") + " " + (prin1-to-string (nth 2 (car list))) + ")\n") + (setq list (cdr list)))) + (insert "))\n")) + (insert ";;; (no custom units defined)\n")) + (insert ";;; End of custom units\n") + (save-buffer))) +) + + + + + +;;; Units operations. + +;;; Units table last updated 9-Jan-91 by Ulrich Mueller ([email protected]) +;;; with some additions by Przemek Klosowski ([email protected]) + +(defvar math-standard-units + '( ;; Length + ( m nil "*Meter" ) + ( in "2.54 cm" "Inch" ) + ( ft "12 in" "Foot" ) + ( yd "3 ft" "Yard" ) + ( mi "5280 ft" "Mile" ) + ( au "1.495979e11 m" "Astronomical Unit" ) + ( lyr "9460536207068016 m" "Light Year" ) + ( pc "206264.80625 au" "Parsec" ) + ( nmi "1852 m" "Nautical Mile" ) + ( fath "6 ft" "Fathom" ) + ( u "1 um" "Micron" ) + ( mil "in/1000" "Mil" ) + ( point "in/72" "Point (1/72 inch)" ) + ( tpt "in/72.27" "Point (TeX conventions)" ) + ( Ang "1e-10 m" "Angstrom" ) + ( mfi "mi+ft+in" "Miles + feet + inches" ) + + ;; Area + ( hect "10000 m^2" "*Hectare" ) + ( acre "mi^2 / 640" "Acre" ) + ( b "1e-28 m^2" "Barn" ) + + ;; Volume + ( l "1e-3 m^3" "*Liter" ) + ( L "1e-3 m^3" "Liter" ) + ( gal "4 qt" "US Gallon" ) + ( qt "2 pt" "Quart" ) + ( pt "2 cup" "Pint" ) + ( cup "8 ozfl" "Cup" ) + ( ozfl "2 tbsp" "Fluid Ounce" ) + ( floz "2 tbsp" "Fluid Ounce" ) + ( tbsp "3 tsp" "Tablespoon" ) + ( tsp "4.92892159375 ml" "Teaspoon" ) + ( vol "tsp+tbsp+ozfl+cup+pt+qt+gal" "Gallons + ... + teaspoons" ) + ( galC "4.54609 l" "Canadian Gallon" ) + ( galUK "4.546092 l" "UK Gallon" ) + + ;; Time + ( s nil "*Second" ) + ( sec "s" "Second" ) + ( min "60 s" "Minute" ) + ( hr "60 min" "Hour" ) + ( day "24 hr" "Day" ) + ( wk "7 day" "Week" ) + ( hms "wk+day+hr+min+s" "Hours, minutes, seconds" ) + ( yr "365.25 day" "Year" ) + ( Hz "1/s" "Hertz" ) + + ;; Speed + ( mph "mi/hr" "*Miles per hour" ) + ( kph "km/hr" "Kilometers per hour" ) + ( knot "nmi/hr" "Knot" ) + ( c "2.99792458e8 m/s" "Speed of light" ) + + ;; Acceleration + ( ga "9.80665 m/s^2" "*\"g\" acceleration" ) + + ;; Mass + ( g nil "*Gram" ) + ( lb "16 oz" "Pound (mass)" ) + ( oz "28.349523125 g" "Ounce (mass)" ) + ( ton "2000 lb" "Ton" ) + ( tpo "ton+lb+oz" "Tons + pounds + ounces (mass)" ) + ( t "1000 kg" "Metric ton" ) + ( tonUK "1016.0469088 kg" "UK ton" ) + ( lbt "12 ozt" "Troy pound" ) + ( ozt "31.103475 g" "Troy ounce" ) + ( ct ".2 g" "Carat" ) + ( amu "1.6605402e-24 g" "Unified atomic mass" ) + + ;; Force + ( N "m kg/s^2" "*Newton" ) + ( dyn "1e-5 N" "Dyne" ) + ( gf "ga g" "Gram (force)" ) + ( lbf "4.44822161526 N" "Pound (force)" ) + ( kip "1000 lbf" "Kilopound (force)" ) + ( pdl "0.138255 N" "Poundal" ) + + ;; Energy + ( J "N m" "*Joule" ) + ( erg "1e-7 J" "Erg" ) + ( cal "4.1868 J" "International Table Calorie" ) + ( Btu "1055.05585262 J" "International Table Btu" ) + ( eV "ech V" "Electron volt" ) + ( ev "eV" "Electron volt" ) + ( therm "105506000 J" "EEC therm" ) + ( invcm "h c/cm" "Energy in inverse centimeters" ) + ( Kayser "invcm" "Kayser (inverse centimeter energy)" ) + ( men "100/invcm" "Inverse energy in meters" ) + ( Hzen "h Hz" "Energy in Hertz") + ( Ken "k K" "Energy in Kelvins") + ;; ( invcm "eV / 8065.47835185" "Energy in inverse centimeters" ) + ;; ( Hzen "eV / 2.41796958004e14" "Energy in Hertz") + ;; ( Ken "eV / 11604.7967327" "Energy in Kelvins") + + ;; Power + ( W "J/s" "*Watt" ) + ( hp "745.7 W" "Horsepower" ) + + ;; Temperature + ( K nil "*Degree Kelvin" K ) + ( dK "K" "Degree Kelvin" K ) + ( degK "K" "Degree Kelvin" K ) + ( dC "K" "Degree Celsius" C ) + ( degC "K" "Degree Celsius" C ) + ( dF "(5/9) K" "Degree Fahrenheit" F ) + ( degF "(5/9) K" "Degree Fahrenheit" F ) + + ;; Pressure + ( Pa "N/m^2" "*Pascal" ) + ( bar "1e5 Pa" "Bar" ) + ( atm "101325 Pa" "Standard atmosphere" ) + ( torr "atm/760" "Torr" ) + ( mHg "1000 torr" "Meter of mercury" ) + ( inHg "25.4 mmHg" "Inch of mercury" ) + ( inH2O "248.84 Pa" "Inch of water" ) + ( psi "6894.75729317 Pa" "Pound per square inch" ) + + ;; Viscosity + ( P "0.1 Pa s" "*Poise" ) + ( St "1e-4 m^2/s" "Stokes" ) + + ;; Electromagnetism + ( A nil "*Ampere" ) + ( C "A s" "Coulomb" ) + ( Fdy "ech Nav" "Faraday" ) + ( e "1.60217733e-19 C" "Elementary charge" ) + ( ech "1.60217733e-19 C" "Elementary charge" ) + ( V "W/A" "Volt" ) + ( ohm "V/A" "Ohm" ) + ( mho "A/V" "Mho" ) + ( S "A/V" "Siemens" ) + ( F "C/V" "Farad" ) + ( H "Wb/A" "Henry" ) + ( T "Wb/m^2" "Tesla" ) + ( G "1e-4 T" "Gauss" ) + ( Wb "V s" "Weber" ) + + ;; Luminous intensity + ( cd nil "*Candela" ) + ( sb "1e4 cd/m^2" "Stilb" ) + ( lm "cd sr" "Lumen" ) + ( lx "lm/m^2" "Lux" ) + ( ph "1e4 lx" "Phot" ) + ( fc "10.76 lx" "Footcandle" ) + ( lam "1e4 lm/m^2" "Lambert" ) + ( flam "1.07639104e-3 lam" "Footlambert" ) + + ;; Radioactivity + ( Bq "1/s" "*Becquerel" ) + ( Ci "3.7e10 Bq" "Curie" ) + ( Gy "J/kg" "Gray" ) + ( Sv "Gy" "Sievert" ) + ( R "2.58e-4 C/kg" "Roentgen" ) + ( rd ".01 Gy" "Rad" ) + ( rem "rd" "Rem" ) + + ;; Amount of substance + ( mol nil "*Mole" ) + + ;; Plane angle + ( rad nil "*Radian" ) + ( circ "2 pi rad" "Full circle" ) + ( rev "circ" "Full revolution" ) + ( deg "circ/360" "Degree" ) + ( arcmin "deg/60" "Arc minute" ) + ( arcsec "arcmin/60" "Arc second" ) + ( grad "circ/400" "Grade" ) + ( rpm "rev/min" "Revolutions per minute" ) + + ;; Solid angle + ( sr nil "*Steradian" ) + + ;; Other physical quantities (Physics Letters B239, 1 (1990)) + ( h "6.6260755e-34 J s" "*Planck's constant" ) + ( hbar "h / 2 pi" "Planck's constant" ) + ( mu0 "4 pi 1e-7 H/m" "Permeability of vacuum" ) + ( Grav "6.67259e-11 N m^2/kg^2" "Gravitational constant" ) + ( Nav "6.0221367e23 / mol" "Avagadro's constant" ) + ( me "0.51099906 MeV/c^2" "Electron rest mass" ) + ( mp "1.007276470 amu" "Proton rest mass" ) + ( mn "1.008664904 amu" "Neutron rest mass" ) + ( mu "0.113428913 amu" "Muon rest mass" ) + ( Ryd "1.0973731571e5 invcm" "Rydberg's constant" ) + ( k "1.3806513e-23 J/K" "Boltzmann's constant" ) + ( fsc "1 / 137.0359895" "Fine structure constant" ) + ( muB "5.78838263e-11 MeV/T" "Bohr magneton" ) + ( muN "3.15245166e-14 MeV/T" "Nuclear magneton" ) + ( mue "1.001159652193 muB" "Electron magnetic moment" ) + ( mup "2.792847386 muN" "Proton magnetic moment" ) + ( R0 "Nav k" "Molar gas constant" ) + ( V0 "22.413992 L/mol" "Standard volume of ideal gas" ) +)) + + +(defvar math-additional-units nil + "*Additional units table for user-defined units. +Must be formatted like math-standard-units. +If this is changed, be sure to set math-units-table to nil to ensure +that the combined units table will be rebuilt.") + +(defvar math-unit-prefixes + '( ( ?E (float 1 18) "Exa" ) + ( ?P (float 1 15) "Peta" ) + ( ?T (float 1 12) "Tera" ) + ( ?G (float 1 9) "Giga" ) + ( ?M (float 1 6) "Mega" ) + ( ?k (float 1 3) "Kilo" ) + ( ?K (float 1 3) "Kilo" ) + ( ?h (float 1 2) "Hecto" ) + ( ?H (float 1 2) "Hecto" ) + ( ?D (float 1 1) "Deka" ) + ( 0 (float 1 0) nil ) + ( ?d (float 1 -1) "Deci" ) + ( ?c (float 1 -2) "Centi" ) + ( ?m (float 1 -3) "Milli" ) + ( ?u (float 1 -6) "Micro" ) + ( ?n (float 1 -9) "Nano" ) + ( ?p (float 1 -12) "Pico" ) + ( ?f (float 1 -15) "Femto" ) + ( ?a (float 1 -18) "Atto" ) +)) + +(defvar math-standard-units-systems + '( ( base nil ) + ( si ( ( g '(* (var kg var-kg) (float 1 -3)) ) ) ) + ( mks ( ( g '(* (var kg var-kg) (float 1 -3)) ) ) ) + ( cgs ( ( m '(* (var cm var-cm) 100 ) ) ) ) +)) + +(defvar math-units-table nil + "Internal units table derived from math-defined-units. +Entries are (SYMBOL EXPR DOC-STRING TEMP-TYPE BASE-UNITS).") + +(defvar math-units-table-buffer-valid nil) + + +(defun math-build-units-table () + (or math-units-table + (let* ((combined-units (append math-additional-units + math-standard-units)) + (unit-list (mapcar 'car combined-units)) + tab) + (message "Building units table...") + (setq math-units-table-buffer-valid nil) + (setq tab (mapcar (function + (lambda (x) + (list (car x) + (and (nth 1 x) + (if (stringp (nth 1 x)) + (let ((exp (math-read-plain-expr + (nth 1 x)))) + (if (eq (car-safe exp) 'error) + (error "Format error in definition of %s in units table: %s" + (car x) (nth 2 exp)) + exp)) + (nth 1 x))) + (nth 2 x) + (nth 3 x) + (and (not (nth 1 x)) + (list (cons (car x) 1)))))) + combined-units)) + (let ((math-units-table tab)) + (mapcar 'math-find-base-units tab)) + (message "Building units table...done") + (setq math-units-table tab))) +) + +(defun math-find-base-units (entry) + (if (eq (nth 4 entry) 'boom) + (error "Circular definition involving unit %s" (car entry))) + (or (nth 4 entry) + (let (base) + (setcar (nthcdr 4 entry) 'boom) + (math-find-base-units-rec (nth 1 entry) 1) + '(or base + (error "Dimensionless definition for unit %s" (car entry))) + (while (eq (cdr (car base)) 0) + (setq base (cdr base))) + (let ((b base)) + (while (cdr b) + (if (eq (cdr (car (cdr b))) 0) + (setcdr b (cdr (cdr b))) + (setq b (cdr b))))) + (setq base (sort base 'math-compare-unit-names)) + (setcar (nthcdr 4 entry) base) + base)) +) + +(defun math-compare-unit-names (a b) + (memq (car b) (cdr (memq (car a) unit-list))) +) + +(defun math-find-base-units-rec (expr pow) + (let ((u (math-check-unit-name expr))) + (cond (u + (let ((ulist (math-find-base-units u))) + (while ulist + (let ((p (* (cdr (car ulist)) pow)) + (old (assq (car (car ulist)) base))) + (if old + (setcdr old (+ (cdr old) p)) + (setq base (cons (cons (car (car ulist)) p) base)))) + (setq ulist (cdr ulist))))) + ((math-scalarp expr)) + ((and (eq (car expr) '^) + (integerp (nth 2 expr))) + (math-find-base-units-rec (nth 1 expr) (* pow (nth 2 expr)))) + ((eq (car expr) '*) + (math-find-base-units-rec (nth 1 expr) pow) + (math-find-base-units-rec (nth 2 expr) pow)) + ((eq (car expr) '/) + (math-find-base-units-rec (nth 1 expr) pow) + (math-find-base-units-rec (nth 2 expr) (- pow))) + ((eq (car expr) 'neg) + (math-find-base-units-rec (nth 1 expr) pow)) + ((eq (car expr) '+) + (math-find-base-units-rec (nth 1 expr) pow)) + ((eq (car expr) 'var) + (or (eq (nth 1 expr) 'pi) + (error "Unknown name %s in defining expression for unit %s" + (nth 1 expr) (car entry)))) + (t (error "Malformed defining expression for unit %s" (car entry))))) +) + + +(defun math-units-in-expr-p (expr sub-exprs) + (and (consp expr) + (if (eq (car expr) 'var) + (math-check-unit-name expr) + (and (or sub-exprs + (memq (car expr) '(* / ^))) + (or (math-units-in-expr-p (nth 1 expr) sub-exprs) + (math-units-in-expr-p (nth 2 expr) sub-exprs))))) +) + +(defun math-only-units-in-expr-p (expr) + (and (consp expr) + (if (eq (car expr) 'var) + (math-check-unit-name expr) + (if (memq (car expr) '(* /)) + (and (math-only-units-in-expr-p (nth 1 expr)) + (math-only-units-in-expr-p (nth 2 expr))) + (and (eq (car expr) '^) + (and (math-only-units-in-expr-p (nth 1 expr)) + (math-realp (nth 2 expr))))))) +) + +(defun math-single-units-in-expr-p (expr) + (cond ((math-scalarp expr) nil) + ((eq (car expr) 'var) + (math-check-unit-name expr)) + ((eq (car expr) '*) + (let ((u1 (math-single-units-in-expr-p (nth 1 expr))) + (u2 (math-single-units-in-expr-p (nth 2 expr)))) + (or (and u1 u2 'wrong) + u1 + u2))) + ((eq (car expr) '/) + (if (math-units-in-expr-p (nth 2 expr) nil) + 'wrong + (math-single-units-in-expr-p (nth 1 expr)))) + (t 'wrong)) +) + +(defun math-check-unit-name (v) + (and (eq (car-safe v) 'var) + (or (assq (nth 1 v) (or math-units-table (math-build-units-table))) + (let ((name (symbol-name (nth 1 v)))) + (and (> (length name) 1) + (assq (aref name 0) math-unit-prefixes) + (or (assq (intern (substring name 1)) math-units-table) + (and (eq (aref name 0) ?M) + (> (length name) 3) + (eq (aref name 1) ?e) + (eq (aref name 2) ?g) + (assq (intern (substring name 3)) + math-units-table))))))) +) + + +(defun math-to-standard-units (expr which-standard) + (math-to-standard-rec expr) +) + +(defun math-to-standard-rec (expr) + (if (eq (car-safe expr) 'var) + (let ((u (math-check-unit-name expr)) + (base (nth 1 expr))) + (if u + (progn + (if (nth 1 u) + (setq expr (math-to-standard-rec (nth 1 u))) + (let ((st (assq (car u) which-standard))) + (if st + (setq expr (nth 1 st)) + (setq expr (list 'var (car u) + (intern (concat "var-" + (symbol-name + (car u))))))))) + (or (null u) + (eq base (car u)) + (setq expr (list '* + (nth 1 (assq (aref (symbol-name base) 0) + math-unit-prefixes)) + expr))) + expr) + (if (eq base 'pi) + (math-pi) + expr))) + (if (Math-primp expr) + expr + (cons (car expr) + (mapcar 'math-to-standard-rec (cdr expr))))) +) + +(defun math-apply-units (expr units ulist &optional pure) + (if ulist + (let ((new 0) + value) + (setq expr (math-simplify-units expr)) + (or (math-numberp expr) + (error "Incompatible units")) + (while (cdr ulist) + (setq value (math-div expr (nth 1 (car ulist))) + value (math-floor (let ((calc-internal-prec + (1- calc-internal-prec))) + (math-normalize value))) + new (math-add new (math-mul value (car (car ulist)))) + expr (math-sub expr (math-mul value (nth 1 (car ulist)))) + ulist (cdr ulist))) + (math-add new (math-mul (math-div expr (nth 1 (car ulist))) + (car (car ulist))))) + (math-simplify-units (if pure + expr + (list '* expr units)))) +) + +(defun math-decompose-units (units) + (let ((u (math-check-unit-name units))) + (and u (eq (car-safe (nth 1 u)) '+) + (setq units (nth 1 u)))) + (setq units (calcFunc-expand units)) + (and (eq (car-safe units) '+) + (let ((entry (list units calc-internal-prec calc-prefer-frac))) + (or (equal entry (car math-decompose-units-cache)) + (let ((ulist nil) + (utemp units) + qty unit) + (while (eq (car-safe utemp) '+) + (setq ulist (cons (math-decompose-unit-part (nth 2 utemp)) + ulist) + utemp (nth 1 utemp))) + (setq ulist (cons (math-decompose-unit-part utemp) ulist) + utemp ulist) + (while (setq utemp (cdr utemp)) + (or (equal (nth 2 (car utemp)) (nth 2 (car ulist))) + (error "Inconsistent units in sum"))) + (setq math-decompose-units-cache + (cons entry + (sort ulist + (function + (lambda (x y) + (not (Math-lessp (nth 1 x) + (nth 1 y)))))))))) + (cdr math-decompose-units-cache))) +) +(setq math-decompose-units-cache nil) + +(defun math-decompose-unit-part (unit) + (cons unit + (math-is-multiple (math-simplify-units (math-to-standard-units + unit nil)) + t)) +) + +(defun math-find-compatible-unit (expr unit) + (let ((u (math-check-unit-name unit))) + (if u + (math-find-compatible-unit-rec expr 1))) +) + +(defun math-find-compatible-unit-rec (expr pow) + (cond ((eq (car-safe expr) '*) + (or (math-find-compatible-unit-rec (nth 1 expr) pow) + (math-find-compatible-unit-rec (nth 2 expr) pow))) + ((eq (car-safe expr) '/) + (or (math-find-compatible-unit-rec (nth 1 expr) pow) + (math-find-compatible-unit-rec (nth 2 expr) (- pow)))) + ((and (eq (car-safe expr) '^) + (integerp (nth 2 expr))) + (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr)))) + (t + (let ((u2 (math-check-unit-name expr))) + (if (equal (nth 4 u) (nth 4 u2)) + (cons expr pow))))) +) + +(defun math-convert-units (expr new-units &optional pure) + (math-with-extra-prec 2 + (let ((compat (and (not pure) (math-find-compatible-unit expr new-units))) + (unit-list nil) + (math-combining-units nil)) + (if compat + (math-simplify-units + (math-mul (math-mul (math-simplify-units + (math-div expr (math-pow (car compat) + (cdr compat)))) + (math-pow new-units (cdr compat))) + (math-simplify-units + (math-to-standard-units + (math-pow (math-div (car compat) new-units) + (cdr compat)) + nil)))) + (if (setq unit-list (math-decompose-units new-units)) + (setq new-units (nth 2 (car unit-list)))) + (if (eq (car-safe expr) '+) + (setq expr (math-simplify-units expr))) + (if (math-units-in-expr-p expr t) + (math-convert-units-rec expr) + (math-apply-units (math-to-standard-units + (list '/ expr new-units) nil) + new-units unit-list pure))))) +) + +(defun math-convert-units-rec (expr) + (if (math-units-in-expr-p expr nil) + (math-apply-units (math-to-standard-units (list '/ expr new-units) nil) + new-units unit-list pure) + (if (Math-primp expr) + expr + (cons (car expr) + (mapcar 'math-convert-units-rec (cdr expr))))) +) + +(defun math-convert-temperature (expr old new &optional pure) + (let* ((units (math-single-units-in-expr-p expr)) + (uold (if old + (if (or (null units) + (equal (nth 1 old) (car units))) + (math-check-unit-name old) + (error "Inconsistent temperature units")) + units)) + (unew (math-check-unit-name new))) + (or (and (consp unew) (nth 3 unew)) + (error "Not a valid temperature unit")) + (or (and (consp uold) (nth 3 uold)) + (error "Not a pure temperature expression")) + (let ((v (car uold))) + (setq expr (list '/ expr (list 'var v + (intern (concat "var-" + (symbol-name v))))))) + (or (eq (nth 3 uold) (nth 3 unew)) + (cond ((eq (nth 3 uold) 'K) + (setq expr (list '- expr '(float 27315 -2))) + (if (eq (nth 3 unew) 'F) + (setq expr (list '+ (list '* expr '(frac 9 5)) 32)))) + ((eq (nth 3 uold) 'C) + (if (eq (nth 3 unew) 'F) + (setq expr (list '+ (list '* expr '(frac 9 5)) 32)) + (setq expr (list '+ expr '(float 27315 -2))))) + (t + (setq expr (list '* (list '- expr 32) '(frac 5 9))) + (if (eq (nth 3 unew) 'K) + (setq expr (list '+ expr '(float 27315 -2))))))) + (if pure + expr + (list '* expr new))) +) + + + +(defun math-simplify-units (a) + (let ((math-simplifying-units t) + (calc-matrix-mode 'scalar)) + (math-simplify a)) +) +(fset 'calcFunc-usimplify (symbol-function 'math-simplify-units)) + +(math-defsimplify (+ -) + (and math-simplifying-units + (math-units-in-expr-p (nth 1 expr) nil) + (let* ((units (math-extract-units (nth 1 expr))) + (ratio (math-simplify (math-to-standard-units + (list '/ (nth 2 expr) units) nil)))) + (if (math-units-in-expr-p ratio nil) + (progn + (calc-record-why "*Inconsistent units" expr) + expr) + (list '* (math-add (math-remove-units (nth 1 expr)) + (if (eq (car expr) '-) (math-neg ratio) ratio)) + units)))) +) + +(math-defsimplify * + (math-simplify-units-prod) +) + +(defun math-simplify-units-prod () + (and math-simplifying-units + calc-autorange-units + (Math-realp (nth 1 expr)) + (let* ((num (math-float (nth 1 expr))) + (xpon (calcFunc-xpon num)) + (unitp (cdr (cdr expr))) + (unit (car unitp)) + (pow (if (eq (car expr) '*) 1 -1)) + u) + (and (eq (car-safe unit) '*) + (setq unitp (cdr unit) + unit (car unitp))) + (and (eq (car-safe unit) '^) + (integerp (nth 2 unit)) + (setq pow (* pow (nth 2 unit)) + unitp (cdr unit) + unit (car unitp))) + (and (setq u (math-check-unit-name unit)) + (integerp xpon) + (or (< xpon 0) + (>= xpon (if (eq (car u) 'm) 1 3))) + (let* ((uxpon 0) + (pref (if (< pow 0) + (reverse math-unit-prefixes) + math-unit-prefixes)) + (p pref) + pxpon pname) + (or (eq (car u) (nth 1 unit)) + (setq uxpon (* pow + (nth 2 (nth 1 (assq + (aref (symbol-name + (nth 1 unit)) 0) + math-unit-prefixes)))))) + (setq xpon (+ xpon uxpon)) + (while (and p + (or (memq (car (car p)) '(?d ?D ?h ?H)) + (and (eq (car (car p)) ?c) + (not (eq (car u) 'm))) + (< xpon (setq pxpon (* (nth 2 (nth 1 (car p))) + pow))) + (progn + (setq pname (math-build-var-name + (if (eq (car (car p)) 0) + (car u) + (concat (char-to-string + (car (car p))) + (symbol-name + (car u)))))) + (and (/= (car (car p)) 0) + (assq (nth 1 pname) + math-units-table))))) + (setq p (cdr p))) + (and p + (/= pxpon uxpon) + (or (not (eq p pref)) + (< xpon (+ pxpon (* (math-abs pow) 3)))) + (progn + (setcar (cdr expr) + (let ((calc-prefer-frac nil)) + (calcFunc-scf (nth 1 expr) + (- uxpon pxpon)))) + (setcar unitp pname) + expr)))))) +) + +(math-defsimplify / + (and math-simplifying-units + (let ((np (cdr expr)) + (try-cancel-units 0) + n nn) + (setq n (if (eq (car-safe (nth 2 expr)) '*) + (cdr (nth 2 expr)) + (nthcdr 2 expr))) + (if (math-realp (car n)) + (progn + (setcar (cdr expr) (math-mul (nth 1 expr) + (let ((calc-prefer-frac nil)) + (math-div 1 (car n))))) + (setcar n 1))) + (while (eq (car-safe (setq n (car np))) '*) + (math-simplify-units-divisor (cdr n) (cdr (cdr expr))) + (setq np (cdr (cdr n)))) + (math-simplify-units-divisor np (cdr (cdr expr))) + (if (eq try-cancel-units 0) + (let* ((math-simplifying-units nil) + (base (math-simplify (math-to-standard-units expr nil)))) + (if (Math-numberp base) + (setq expr base)))) + (if (eq (car-safe expr) '/) + (math-simplify-units-prod)) + expr)) +) + +(defun math-simplify-units-divisor (np dp) + (let ((n (car np)) + d dd temp) + (while (eq (car-safe (setq d (car dp))) '*) + (if (setq temp (math-simplify-units-quotient n (nth 1 d))) + (progn + (setcar np (setq n temp)) + (setcar (cdr d) 1))) + (setq dp (cdr (cdr d)))) + (if (setq temp (math-simplify-units-quotient n d)) + (progn + (setcar np (setq n temp)) + (setcar dp 1)))) +) + +;; Simplify, e.g., "in / cm" to "2.54" in a units expression. +(defun math-simplify-units-quotient (n d) + (let ((pow1 1) + (pow2 1)) + (and (eq (car-safe n) '^) + (integerp (nth 2 n)) + (setq pow1 (nth 2 n) n (nth 1 n))) + (and (eq (car-safe d) '^) + (integerp (nth 2 d)) + (setq pow2 (nth 2 d) d (nth 1 d))) + (let ((un (math-check-unit-name n)) + (ud (math-check-unit-name d))) + (and un ud + (if (and (equal (nth 4 un) (nth 4 ud)) + (eq pow1 pow2)) + (math-to-standard-units (list '/ n d) nil) + (let (ud1) + (setq un (nth 4 un) + ud (nth 4 ud)) + (while un + (setq ud1 ud) + (while ud1 + (and (eq (car (car un)) (car (car ud1))) + (setq try-cancel-units + (+ try-cancel-units + (- (* (cdr (car un)) pow1) + (* (cdr (car ud)) pow2))))) + (setq ud1 (cdr ud1))) + (setq un (cdr un))) + nil))))) +) + +(math-defsimplify ^ + (and math-simplifying-units + (math-realp (nth 2 expr)) + (if (memq (car-safe (nth 1 expr)) '(* /)) + (list (car (nth 1 expr)) + (list '^ (nth 1 (nth 1 expr)) (nth 2 expr)) + (list '^ (nth 2 (nth 1 expr)) (nth 2 expr))) + (math-simplify-units-pow (nth 1 expr) (nth 2 expr)))) +) + +(math-defsimplify calcFunc-sqrt + (and math-simplifying-units + (if (memq (car-safe (nth 1 expr)) '(* /)) + (list (car (nth 1 expr)) + (list 'calcFunc-sqrt (nth 1 (nth 1 expr))) + (list 'calcFunc-sqrt (nth 2 (nth 1 expr)))) + (math-simplify-units-pow (nth 1 expr) '(frac 1 2)))) +) + +(math-defsimplify (calcFunc-floor + calcFunc-ceil + calcFunc-round + calcFunc-rounde + calcFunc-roundu + calcFunc-trunc + calcFunc-float + calcFunc-frac + calcFunc-abs + calcFunc-clean) + (and math-simplifying-units + (= (length expr) 2) + (if (math-only-units-in-expr-p (nth 1 expr)) + (nth 1 expr) + (if (and (memq (car-safe (nth 1 expr)) '(* /)) + (or (math-only-units-in-expr-p + (nth 1 (nth 1 expr))) + (math-only-units-in-expr-p + (nth 2 (nth 1 expr))))) + (list (car (nth 1 expr)) + (cons (car expr) + (cons (nth 1 (nth 1 expr)) + (cdr (cdr expr)))) + (cons (car expr) + (cons (nth 2 (nth 1 expr)) + (cdr (cdr expr))))))))) + +(defun math-simplify-units-pow (a pow) + (if (and (eq (car-safe a) '^) + (math-check-unit-name (nth 1 a)) + (math-realp (nth 2 a))) + (list '^ (nth 1 a) (math-mul pow (nth 2 a))) + (let* ((u (math-check-unit-name a)) + (pf (math-to-simple-fraction pow)) + (d (and (eq (car-safe pf) 'frac) (nth 2 pf)))) + (and u d + (math-units-are-multiple u d) + (list '^ (math-to-standard-units a nil) pow)))) +) + + +(defun math-units-are-multiple (u n) + (setq u (nth 4 u)) + (while (and u (= (% (cdr (car u)) n) 0)) + (setq u (cdr u))) + (null u) +) + +(math-defsimplify calcFunc-sin + (and math-simplifying-units + (math-units-in-expr-p (nth 1 expr) nil) + (let ((rad (math-simplify-units + (math-evaluate-expr + (math-to-standard-units (nth 1 expr) nil)))) + (calc-angle-mode 'rad)) + (and (eq (car-safe rad) '*) + (math-realp (nth 1 rad)) + (eq (car-safe (nth 2 rad)) 'var) + (eq (nth 1 (nth 2 rad)) 'rad) + (list 'calcFunc-sin (nth 1 rad))))) +) + +(math-defsimplify calcFunc-cos + (and math-simplifying-units + (math-units-in-expr-p (nth 1 expr) nil) + (let ((rad (math-simplify-units + (math-evaluate-expr + (math-to-standard-units (nth 1 expr) nil)))) + (calc-angle-mode 'rad)) + (and (eq (car-safe rad) '*) + (math-realp (nth 1 rad)) + (eq (car-safe (nth 2 rad)) 'var) + (eq (nth 1 (nth 2 rad)) 'rad) + (list 'calcFunc-cos (nth 1 rad))))) +) + +(math-defsimplify calcFunc-tan + (and math-simplifying-units + (math-units-in-expr-p (nth 1 expr) nil) + (let ((rad (math-simplify-units + (math-evaluate-expr + (math-to-standard-units (nth 1 expr) nil)))) + (calc-angle-mode 'rad)) + (and (eq (car-safe rad) '*) + (math-realp (nth 1 rad)) + (eq (car-safe (nth 2 rad)) 'var) + (eq (nth 1 (nth 2 rad)) 'rad) + (list 'calcFunc-tan (nth 1 rad))))) +) + + +(defun math-remove-units (expr) + (if (math-check-unit-name expr) + 1 + (if (Math-primp expr) + expr + (cons (car expr) + (mapcar 'math-remove-units (cdr expr))))) +) + +(defun math-extract-units (expr) + (if (memq (car-safe expr) '(* /)) + (cons (car expr) + (mapcar 'math-extract-units (cdr expr))) + (if (math-check-unit-name expr) expr 1)) +) + +(defun math-build-units-table-buffer (enter-buffer) + (if (not (and math-units-table math-units-table-buffer-valid + (get-buffer "*Units Table*"))) + (let ((buf (get-buffer-create "*Units Table*")) + (uptr (math-build-units-table)) + (calc-language (if (eq calc-language 'big) nil calc-language)) + (calc-float-format '(float 0)) + (calc-group-digits nil) + (calc-number-radix 10) + (calc-point-char ".") + (std nil) + u name shadowed) + (save-excursion + (message "Formatting units table...") + (set-buffer buf) + (setq buffer-read-only nil) + (erase-buffer) + (insert "Calculator Units Table:\n\n") + (insert "Unit Type Definition Description\n\n") + (while uptr + (setq u (car uptr) + name (nth 2 u)) + (if (eq (car u) 'm) + (setq std t)) + (setq shadowed (and std (assq (car u) math-additional-units))) + (if (and name + (> (length name) 1) + (eq (aref name 0) ?\*)) + (progn + (or (eq uptr math-units-table) + (insert "\n")) + (setq name (substring name 1)))) + (insert " ") + (and shadowed (insert "(")) + (insert (symbol-name (car u))) + (and shadowed (insert ")")) + (if (nth 3 u) + (progn + (indent-to 10) + (insert (symbol-name (nth 3 u)))) + (or std + (progn + (indent-to 10) + (insert "U")))) + (indent-to 14) + (and shadowed (insert "(")) + (if (nth 1 u) + (insert (math-format-value (nth 1 u) 80)) + (insert (symbol-name (car u)))) + (and shadowed (insert ")")) + (indent-to 41) + (insert " ") + (if name + (insert name)) + (if shadowed + (insert " (redefined above)") + (or (nth 1 u) + (insert " (base unit)"))) + (insert "\n") + (setq uptr (cdr uptr))) + (insert "\n\nUnit Prefix Table:\n\n") + (setq uptr math-unit-prefixes) + (while uptr + (setq u (car uptr)) + (insert " " (char-to-string (car u))) + (if (equal (nth 1 u) (nth 1 (nth 1 uptr))) + (insert " " (char-to-string (car (car (setq uptr (cdr uptr))))) + " ") + (insert " ")) + (insert "10^" (int-to-string (nth 2 (nth 1 u)))) + (indent-to 15) + (insert " " (nth 2 u) "\n") + (while (eq (car (car (setq uptr (cdr uptr)))) 0))) + (insert "\n") + (setq buffer-read-only t) + (message "Formatting units table...done")) + (setq math-units-table-buffer-valid t) + (let ((oldbuf (current-buffer))) + (set-buffer buf) + (goto-char (point-min)) + (set-buffer oldbuf)) + (if enter-buffer + (pop-to-buffer buf) + (display-buffer buf))) + (if enter-buffer + (pop-to-buffer (get-buffer "*Units Table*")) + (display-buffer (get-buffer "*Units Table*")))) +) + + + + diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el new file mode 100644 index 0000000000..bd6ab2e667 --- /dev/null +++ b/lisp/calc/calc-vec.el @@ -0,0 +1,1698 @@ +;; Calculator for GNU Emacs, part II [calc-vec.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-vec () nil) + + +(defun calc-display-strings (n) + (interactive "P") + (calc-wrapper + (message (if (calc-change-mode 'calc-display-strings n t t) + "Displaying vectors of integers as quoted strings." + "Displaying vectors of integers normally."))) +) + + +(defun calc-pack (n) + (interactive "P") + (calc-wrapper + (let* ((nn (if n 1 2)) + (mode (if n (prefix-numeric-value n) (calc-top-n 1))) + (mode (if (and (Math-vectorp mode) (cdr mode)) (cdr mode) + (if (integerp mode) mode + (error "Packing mode must be an integer or vector of integers")))) + (num (calc-pack-size mode)) + (items (calc-top-list num nn))) + (calc-enter-result (+ nn num -1) "pack" (calc-pack-items mode items)))) +) + +(defun calc-pack-size (mode) + (cond ((consp mode) + (let ((size 1)) + (while mode + (or (integerp (car mode)) (error "Vector of integers expected")) + (setq size (* size (calc-pack-size (car mode))) + mode (cdr mode))) + (if (= size 0) + (error "Zero dimensions not allowed") + size))) + ((>= mode 0) mode) + (t (or (cdr (assq mode '((-3 . 3) (-13 . 1) (-14 . 3) (-15 . 6)))) + 2))) +) + +(defun calc-pack-items (mode items) + (cond ((consp mode) + (if (cdr mode) + (let* ((size (calc-pack-size (cdr mode))) + (len (length items)) + (new nil) + p row) + (while (> len 0) + (setq p (nthcdr (1- size) items) + row items + items (cdr p) + len (- len size)) + (setcdr p nil) + (setq new (cons (calc-pack-items (cdr mode) row) new))) + (calc-pack-items (car mode) (nreverse new))) + (calc-pack-items (car mode) items))) + ((>= mode 0) + (cons 'vec items)) + ((= mode -3) + (if (and (math-objvecp (car items)) + (math-objvecp (nth 1 items)) + (math-objvecp (nth 2 items))) + (if (and (math-num-integerp (car items)) + (math-num-integerp (nth 1 items))) + (if (math-realp (nth 2 items)) + (cons 'hms items) + (error "Seconds must be real")) + (error "Hours and minutes must be integers")) + (math-normalize (list '+ + (list '+ + (if (eq calc-angle-mode 'rad) + (list '* (car items) + '(hms 1 0 0)) + (car items)) + (list '* (nth 1 items) '(hms 0 1 0))) + (list '* (nth 2 items) '(hms 0 0 1)))))) + ((= mode -13) + (if (math-realp (car items)) + (cons 'date items) + (if (eq (car-safe (car items)) 'date) + (car items) + (if (math-objvecp (car items)) + (error "Date value must be real") + (cons 'calcFunc-date items))))) + ((memq mode '(-14 -15)) + (let ((p items)) + (while (and p (math-objvecp (car p))) + (or (math-integerp (car p)) + (error "Components must be integers")) + (setq p (cdr p))) + (if p + (cons 'calcFunc-date items) + (list 'date (math-dt-to-date items))))) + ((or (eq (car-safe (car items)) 'vec) + (eq (car-safe (nth 1 items)) 'vec)) + (let* ((x (car items)) + (vx (eq (car-safe x) 'vec)) + (y (nth 1 items)) + (vy (eq (car-safe y) 'vec)) + (z nil) + (n (1- (length (if vx x y))))) + (and vx vy + (/= n (1- (length y))) + (error "Vectors must be the same length")) + (while (>= (setq n (1- n)) 0) + (setq z (cons (calc-pack-items + mode + (list (if vx (car (setq x (cdr x))) x) + (if vy (car (setq y (cdr y))) y))) + z))) + (cons 'vec (nreverse z)))) + ((= mode -1) + (if (and (math-realp (car items)) (math-realp (nth 1 items))) + (cons 'cplx items) + (if (and (math-objectp (car items)) (math-objectp (nth 1 items))) + (error "Components must be real")) + (math-normalize (list '+ (car items) + (list '* (nth 1 items) '(cplx 0 1)))))) + ((= mode -2) + (if (and (math-realp (car items)) (math-anglep (nth 1 items))) + (cons 'polar items) + (if (and (math-objectp (car items)) (math-objectp (nth 1 items))) + (error "Components must be real")) + (math-normalize (list '* (car items) + (if (math-anglep (nth 1 items)) + (list 'polar 1 (nth 1 items)) + (list 'calcFunc-exp + (list '* + (math-to-radians-2 + (nth 1 items)) + (list 'polar + 1 + (math-quarter-circle + nil))))))))) + ((= mode -4) + (let ((x (car items)) + (sigma (nth 1 items))) + (if (or (math-scalarp x) (not (math-objvecp x))) + (if (or (math-anglep sigma) (not (math-objvecp sigma))) + (math-make-sdev x sigma) + (error "Error component must be real")) + (error "Mean component must be real or complex")))) + ((= mode -5) + (let ((a (car items)) + (m (nth 1 items))) + (if (and (math-anglep a) (math-anglep m)) + (if (math-posp m) + (math-make-mod a m) + (error "Modulus must be positive")) + (if (and (math-objectp a) (math-objectp m)) + (error "Components must be real")) + (list 'calcFunc-makemod a m)))) + ((memq mode '(-6 -7 -8 -9)) + (let ((lo (car items)) + (hi (nth 1 items))) + (if (and (or (math-anglep lo) (eq (car lo) 'date) + (not (math-objvecp lo))) + (or (math-anglep hi) (eq (car hi) 'date) + (not (math-objvecp hi)))) + (math-make-intv (+ mode 9) lo hi) + (error "Components must be real")))) + ((eq mode -10) + (if (math-zerop (nth 1 items)) + (error "Denominator must not be zero") + (if (and (math-integerp (car items)) (math-integerp (nth 1 items))) + (math-normalize (cons 'frac items)) + (if (and (math-objectp (car items)) (math-objectp (nth 1 items))) + (error "Components must be integers")) + (cons 'calcFunc-fdiv items)))) + ((memq mode '(-11 -12)) + (if (and (math-realp (car items)) (math-integerp (nth 1 items))) + (calcFunc-scf (math-float (car items)) (nth 1 items)) + (if (and (math-objectp (car items)) (math-objectp (nth 1 items))) + (error "Components must be integers")) + (math-normalize + (list 'calcFunc-scf + (list 'calcFunc-float (car items)) + (nth 1 items))))) + (t + (error "Invalid packing mode: %d" mode))) +) + +(defun calc-unpack (mode) + (interactive "P") + (calc-wrapper + (let ((calc-unpack-with-type t)) + (calc-pop-push-record-list 1 "unpk" (calc-unpack-item + (and mode + (prefix-numeric-value mode)) + (calc-top))))) +) + +(defun calc-unpack-type (item) + (cond ((eq (car-safe item) 'vec) + (1- (length item))) + ((eq (car-safe item) 'intv) + (- (nth 1 item) 9)) + (t + (or (cdr (assq (car-safe item) '( (cplx . -1) (polar . -2) + (hms . -3) (sdev . -4) (mod . -5) + (frac . -10) (float . -11) + (date . -13) ))) + (error "Argument must be a composite object")))) +) + +(defun calc-unpack-item (mode item) + (cond ((not mode) + (if (or (and (not (memq (car-safe item) '(frac float cplx polar vec + hms date sdev mod + intv))) + (math-objvecp item)) + (eq (car-safe item) 'var)) + (error "Argument must be a composite object or function call")) + (if (eq (car item) 'intv) + (cdr (cdr item)) + (cdr item))) + ((> mode 0) + (let ((dims nil) + type new row) + (setq item (list item)) + (while (> mode 0) + (setq type (calc-unpack-type (car item)) + dims (cons type dims) + new (calc-unpack-item nil (car item))) + (while (setq item (cdr item)) + (or (= (calc-unpack-type (car item)) type) + (error "Inconsistent types or dimensions in vector elements")) + (setq new (append new (calc-unpack-item nil (car item))))) + (setq item new + mode (1- mode))) + (if (cdr dims) (setq dims (list (cons 'vec (nreverse dims))))) + (cond ((eq calc-unpack-with-type 'pair) + (list (car dims) (cons 'vec item))) + (calc-unpack-with-type + (append item dims)) + (t item)))) + ((eq calc-unpack-with-type 'pair) + (let ((calc-unpack-with-type nil)) + (list mode (cons 'vec (calc-unpack-item mode item))))) + ((= mode -3) + (if (eq (car-safe item) 'hms) + (cdr item) + (error "Argument must be an HMS form"))) + ((= mode -13) + (if (eq (car-safe item) 'date) + (cdr item) + (error "Argument must be a date form"))) + ((= mode -14) + (if (eq (car-safe item) 'date) + (math-date-to-dt (math-floor (nth 1 item))) + (error "Argument must be a date form"))) + ((= mode -15) + (if (eq (car-safe item) 'date) + (append (math-date-to-dt (nth 1 item)) + (and (not (math-integerp (nth 1 item))) + (list 0 0 0))) + (error "Argument must be a date form"))) + ((eq (car-safe item) 'vec) + (let ((x nil) + (y nil) + res) + (while (setq item (cdr item)) + (setq res (calc-unpack-item mode (car item)) + x (cons (car res) x) + y (cons (nth 1 res) y))) + (list (cons 'vec (nreverse x)) + (cons 'vec (nreverse y))))) + ((= mode -1) + (if (eq (car-safe item) 'cplx) + (cdr item) + (if (eq (car-safe item) 'polar) + (cdr (math-complex item)) + (if (Math-realp item) + (list item 0) + (error "Argument must be a complex number"))))) + ((= mode -2) + (if (or (memq (car-safe item) '(cplx polar)) + (Math-realp item)) + (cdr (math-polar item)) + (error "Argument must be a complex number"))) + ((= mode -4) + (if (eq (car-safe item) 'sdev) + (cdr item) + (list item 0))) + ((= mode -5) + (if (eq (car-safe item) 'mod) + (cdr item) + (error "Argument must be a modulo form"))) + ((memq mode '(-6 -7 -8 -9)) + (if (eq (car-safe item) 'intv) + (cdr (cdr item)) + (list item item))) + ((= mode -10) + (if (eq (car-safe item) 'frac) + (cdr item) + (if (Math-integerp item) + (list item 1) + (error "Argument must be a rational number")))) + ((= mode -11) + (if (eq (car-safe item) 'float) + (list (nth 1 item) (math-normalize (nth 2 item))) + (error "Expected a floating-point number"))) + ((= mode -12) + (if (eq (car-safe item) 'float) + (list (calcFunc-mant item) (calcFunc-xpon item)) + (error "Expected a floating-point number"))) + (t + (error "Invalid unpacking mode: %d" mode))) +) +(setq calc-unpack-with-type nil) + +(defun calc-diag (n) + (interactive "P") + (calc-wrapper + (calc-enter-result 1 "diag" (if n + (list 'calcFunc-diag (calc-top-n 1) + (prefix-numeric-value n)) + (list 'calcFunc-diag (calc-top-n 1))))) +) + +(defun calc-ident (n) + (interactive "NDimension of identity matrix = ") + (calc-wrapper + (calc-enter-result 0 "idn" (if (eq n 0) + '(calcFunc-idn 1) + (list 'calcFunc-idn 1 + (prefix-numeric-value n))))) +) + +(defun calc-index (n &optional stack) + (interactive "NSize of vector = \nP") + (calc-wrapper + (if (consp stack) + (calc-enter-result 3 "indx" (cons 'calcFunc-index (calc-top-list-n 3))) + (calc-enter-result 0 "indx" (list 'calcFunc-index + (prefix-numeric-value n))))) +) + +(defun calc-build-vector (n) + (interactive "NSize of vector = ") + (calc-wrapper + (calc-enter-result 1 "bldv" (list 'calcFunc-cvec + (calc-top-n 1) + (prefix-numeric-value n)))) +) + +(defun calc-cons (arg) + (interactive "P") + (calc-wrapper + (if (calc-is-hyperbolic) + (calc-binary-op "rcns" 'calcFunc-rcons arg) + (calc-binary-op "cons" 'calcFunc-cons arg))) +) + + +(defun calc-head (arg) + (interactive "P") + (calc-wrapper + (if (calc-is-inverse) + (if (calc-is-hyperbolic) + (calc-unary-op "rtai" 'calcFunc-rtail arg) + (calc-unary-op "tail" 'calcFunc-tail arg)) + (if (calc-is-hyperbolic) + (calc-unary-op "rhed" 'calcFunc-rhead arg) + (calc-unary-op "head" 'calcFunc-head arg)))) +) + +(defun calc-tail (arg) + (interactive "P") + (calc-invert-func) + (calc-head arg) +) + +(defun calc-vlength (arg) + (interactive "P") + (calc-wrapper + (if (calc-is-hyperbolic) + (calc-unary-op "dims" 'calcFunc-mdims arg) + (calc-unary-op "len" 'calcFunc-vlen arg))) +) + +(defun calc-arrange-vector (n) + (interactive "NNumber of columns = ") + (calc-wrapper + (calc-enter-result 1 "arng" (list 'calcFunc-arrange (calc-top-n 1) + (prefix-numeric-value n)))) +) + +(defun calc-vector-find (arg) + (interactive "P") + (calc-wrapper + (let ((func (cons 'calcFunc-find (calc-top-list-n 2)))) + (calc-enter-result + 2 "find" + (if arg (append func (list (prefix-numeric-value arg))) func)))) +) + +(defun calc-subvector () + (interactive) + (calc-wrapper + (if (calc-is-inverse) + (calc-enter-result 3 "rsvc" (cons 'calcFunc-rsubvec + (calc-top-list-n 3))) + (calc-enter-result 3 "svec" (cons 'calcFunc-subvec (calc-top-list-n 3))))) +) + +(defun calc-reverse-vector (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "rev" 'calcFunc-rev arg)) +) + +(defun calc-mask-vector (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "vmsk" 'calcFunc-vmask arg)) +) + +(defun calc-expand-vector (arg) + (interactive "P") + (calc-wrapper + (if (calc-is-hyperbolic) + (calc-enter-result 3 "vexp" (cons 'calcFunc-vexp (calc-top-list-n 3))) + (calc-binary-op "vexp" 'calcFunc-vexp arg))) +) + +(defun calc-sort () + (interactive) + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-enter-result 1 "rsrt" (list 'calcFunc-rsort (calc-top-n 1))) + (calc-enter-result 1 "sort" (list 'calcFunc-sort (calc-top-n 1))))) +) + +(defun calc-grade () + (interactive) + (calc-slow-wrapper + (if (calc-is-inverse) + (calc-enter-result 1 "rgrd" (list 'calcFunc-rgrade (calc-top-n 1))) + (calc-enter-result 1 "grad" (list 'calcFunc-grade (calc-top-n 1))))) +) + +(defun calc-histogram (n) + (interactive "NNumber of bins: ") + (calc-slow-wrapper + (if calc-hyperbolic-flag + (calc-enter-result 2 "hist" (list 'calcFunc-histogram + (calc-top-n 2) + (calc-top-n 1) + (prefix-numeric-value n))) + (calc-enter-result 1 "hist" (list 'calcFunc-histogram + (calc-top-n 1) + (prefix-numeric-value n))))) +) + +(defun calc-transpose (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "trn" 'calcFunc-trn arg)) +) + +(defun calc-conj-transpose (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "ctrn" 'calcFunc-ctrn arg)) +) + +(defun calc-cross (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "cros" 'calcFunc-cross arg)) +) + +(defun calc-remove-duplicates (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "rdup" 'calcFunc-rdup arg)) +) + +(defun calc-set-union (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "unio" 'calcFunc-vunion arg '(vec) 'calcFunc-rdup)) +) + +(defun calc-set-intersect (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "intr" 'calcFunc-vint arg '(vec) 'calcFunc-rdup)) +) + +(defun calc-set-difference (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "diff" 'calcFunc-vdiff arg '(vec) 'calcFunc-rdup)) +) + +(defun calc-set-xor (arg) + (interactive "P") + (calc-wrapper + (calc-binary-op "xor" 'calcFunc-vxor arg '(vec) 'calcFunc-rdup)) +) + +(defun calc-set-complement (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "cmpl" 'calcFunc-vcompl arg)) +) + +(defun calc-set-floor (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "vflr" 'calcFunc-vfloor arg)) +) + +(defun calc-set-enumerate (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "enum" 'calcFunc-venum arg)) +) + +(defun calc-set-span (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "span" 'calcFunc-vspan arg)) +) + +(defun calc-set-cardinality (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "card" 'calcFunc-vcard arg)) +) + +(defun calc-unpack-bits (arg) + (interactive "P") + (calc-wrapper + (if (calc-is-inverse) + (calc-unary-op "bpck" 'calcFunc-vpack arg) + (calc-unary-op "bupk" 'calcFunc-vunpack arg))) +) + +(defun calc-pack-bits (arg) + (interactive "P") + (calc-invert-func) + (calc-unpack-bits arg) +) + + +(defun calc-rnorm (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "rnrm" 'calcFunc-rnorm arg)) +) + +(defun calc-cnorm (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "cnrm" 'calcFunc-cnorm arg)) +) + +(defun calc-mrow (n &optional nn) + (interactive "NRow number: \nP") + (calc-wrapper + (if (consp nn) + (calc-enter-result 2 "mrow" (cons 'calcFunc-mrow (calc-top-list-n 2))) + (setq n (prefix-numeric-value n)) + (if (= n 0) + (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1))) + (if (< n 0) + (calc-enter-result 1 "rrow" (list 'calcFunc-mrrow + (calc-top-n 1) (- n))) + (calc-enter-result 1 "mrow" (list 'calcFunc-mrow + (calc-top-n 1) n)))))) +) + +(defun calc-mcol (n &optional nn) + (interactive "NColumn number: \nP") + (calc-wrapper + (if (consp nn) + (calc-enter-result 2 "mcol" (cons 'calcFunc-mcol (calc-top-list-n 2))) + (setq n (prefix-numeric-value n)) + (if (= n 0) + (calc-enter-result 1 "getd" (list 'calcFunc-getdiag (calc-top-n 1))) + (if (< n 0) + (calc-enter-result 1 "rcol" (list 'calcFunc-mrcol + (calc-top-n 1) (- n))) + (calc-enter-result 1 "mcol" (list 'calcFunc-mcol + (calc-top-n 1) n)))))) +) + + +;;;; Vectors. + +(defun calcFunc-mdims (m) + (or (math-vectorp m) + (math-reject-arg m 'vectorp)) + (cons 'vec (math-mat-dimens m)) +) + + +;;; Apply a function elementwise to vector A. [V X V; N X N] [Public] +(defun math-map-vec (f a) + (if (math-vectorp a) + (cons 'vec (mapcar f (cdr a))) + (funcall f a)) +) + +(defun math-dimension-error () + (calc-record-why "*Dimension error") + (signal 'wrong-type-argument nil) +) + + +;;; Build a vector out of a list of objects. [Public] +(defun calcFunc-vec (&rest objs) + (cons 'vec objs) +) + + +;;; Build a constant vector or matrix. [Public] +(defun calcFunc-cvec (obj &rest dims) + (math-make-vec-dimen obj dims) +) + +(defun math-make-vec-dimen (obj dims) + (if dims + (if (natnump (car dims)) + (if (or (cdr dims) + (not (math-numberp obj))) + (cons 'vec (copy-sequence + (make-list (car dims) + (math-make-vec-dimen obj (cdr dims))))) + (cons 'vec (make-list (car dims) obj))) + (math-reject-arg (car dims) 'fixnatnump)) + obj) +) + +(defun calcFunc-head (vec) + (if (and (Math-vectorp vec) + (cdr vec)) + (nth 1 vec) + (calc-record-why 'vectorp vec) + (list 'calcFunc-head vec)) +) + +(defun calcFunc-tail (vec) + (if (and (Math-vectorp vec) + (cdr vec)) + (cons 'vec (cdr (cdr vec))) + (calc-record-why 'vectorp vec) + (list 'calcFunc-tail vec)) +) + +(defun calcFunc-cons (head tail) + (if (Math-vectorp tail) + (cons 'vec (cons head (cdr tail))) + (calc-record-why 'vectorp tail) + (list 'calcFunc-cons head tail)) +) + +(defun calcFunc-rhead (vec) + (if (and (Math-vectorp vec) + (cdr vec)) + (let ((vec (copy-sequence vec))) + (setcdr (nthcdr (- (length vec) 2) vec) nil) + vec) + (calc-record-why 'vectorp vec) + (list 'calcFunc-rhead vec)) +) + +(defun calcFunc-rtail (vec) + (if (and (Math-vectorp vec) + (cdr vec)) + (nth (1- (length vec)) vec) + (calc-record-why 'vectorp vec) + (list 'calcFunc-rtail vec)) +) + +(defun calcFunc-rcons (head tail) + (if (Math-vectorp head) + (append head (list tail)) + (calc-record-why 'vectorp head) + (list 'calcFunc-rcons head tail)) +) + + + +;;; Apply a function elementwise to vectors A and B. [O X O O] [Public] +(defun math-map-vec-2 (f a b) + (if (math-vectorp a) + (if (math-vectorp b) + (let ((v nil)) + (while (setq a (cdr a)) + (or (setq b (cdr b)) + (math-dimension-error)) + (setq v (cons (funcall f (car a) (car b)) v))) + (if a (math-dimension-error)) + (cons 'vec (nreverse v))) + (let ((v nil)) + (while (setq a (cdr a)) + (setq v (cons (funcall f (car a) b) v))) + (cons 'vec (nreverse v)))) + (if (math-vectorp b) + (let ((v nil)) + (while (setq b (cdr b)) + (setq v (cons (funcall f a (car b)) v))) + (cons 'vec (nreverse v))) + (funcall f a b))) +) + + + +;;; "Reduce" a function over a vector (left-associatively). [O X V] [Public] +(defun math-reduce-vec (f a) + (if (math-vectorp a) + (if (cdr a) + (let ((accum (car (setq a (cdr a))))) + (while (setq a (cdr a)) + (setq accum (funcall f accum (car a)))) + accum) + 0) + a) +) + +;;; Reduce a function over the columns of matrix A. [V X V] [Public] +(defun math-reduce-cols (f a) + (if (math-matrixp a) + (cons 'vec (math-reduce-cols-col-step f (cdr a) 1 (length (nth 1 a)))) + a) +) + +(defun math-reduce-cols-col-step (f a col cols) + (and (< col cols) + (cons (math-reduce-cols-row-step f (nth col (car a)) col (cdr a)) + (math-reduce-cols-col-step f a (1+ col) cols))) +) + +(defun math-reduce-cols-row-step (f tot col a) + (if a + (math-reduce-cols-row-step f + (funcall f tot (nth col (car a))) + col + (cdr a)) + tot) +) + + + +(defun math-dot-product (a b) + (if (setq a (cdr a) b (cdr b)) + (let ((accum (math-mul (car a) (car b)))) + (while (setq a (cdr a) b (cdr b)) + (setq accum (math-add accum (math-mul (car a) (car b))))) + accum) + 0) +) + + +;;; Return the number of elements in vector V. [Public] +(defun calcFunc-vlen (v) + (if (math-vectorp v) + (1- (length v)) + (if (math-objectp v) + 0 + (list 'calcFunc-vlen v))) +) + +;;; Get the Nth row of a matrix. +(defun calcFunc-mrow (mat n) ; [Public] + (if (Math-vectorp n) + (math-map-vec (function (lambda (x) (calcFunc-mrow mat x))) n) + (if (and (eq (car-safe n) 'intv) (math-constp n)) + (calcFunc-subvec mat + (math-add (nth 2 n) (if (memq (nth 1 n) '(2 3)) 0 1)) + (math-add (nth 3 n) (if (memq (nth 1 n) '(1 3)) 1 0))) + (or (and (integerp (setq n (math-check-integer n))) + (> n 0)) + (math-reject-arg n 'fixposintp)) + (or (Math-vectorp mat) + (math-reject-arg mat 'vectorp)) + (or (nth n mat) + (math-reject-arg n "*Index out of range")))) +) + +(defun calcFunc-subscr (mat n &optional m) + (setq mat (calcFunc-mrow mat n)) + (if m + (if (math-num-integerp n) + (calcFunc-mrow mat m) + (calcFunc-mcol mat m)) + mat) +) + +;;; Get the Nth column of a matrix. +(defun math-mat-col (mat n) + (cons 'vec (mapcar (function (lambda (x) (elt x n))) (cdr mat))) +) + +(defun calcFunc-mcol (mat n) ; [Public] + (if (Math-vectorp n) + (calcFunc-trn + (math-map-vec (function (lambda (x) (calcFunc-mcol mat x))) n)) + (if (and (eq (car-safe n) 'intv) (math-constp n)) + (if (math-matrixp mat) + (math-map-vec (function (lambda (x) (calcFunc-mrow x n))) mat) + (calcFunc-mrow mat n)) + (or (and (integerp (setq n (math-check-integer n))) + (> n 0)) + (math-reject-arg n 'fixposintp)) + (or (Math-vectorp mat) + (math-reject-arg mat 'vectorp)) + (or (if (math-matrixp mat) + (and (< n (length (nth 1 mat))) + (math-mat-col mat n)) + (nth n mat)) + (math-reject-arg n "*Index out of range")))) +) + +;;; Remove the Nth row from a matrix. +(defun math-mat-less-row (mat n) + (if (<= n 0) + (cdr mat) + (cons (car mat) + (math-mat-less-row (cdr mat) (1- n)))) +) + +(defun calcFunc-mrrow (mat n) ; [Public] + (and (integerp (setq n (math-check-integer n))) + (> n 0) + (< n (length mat)) + (math-mat-less-row mat n)) +) + +;;; Remove the Nth column from a matrix. +(defun math-mat-less-col (mat n) + (cons 'vec (mapcar (function (lambda (x) (math-mat-less-row x n))) + (cdr mat))) +) + +(defun calcFunc-mrcol (mat n) ; [Public] + (and (integerp (setq n (math-check-integer n))) + (> n 0) + (if (math-matrixp mat) + (and (< n (length (nth 1 mat))) + (math-mat-less-col mat n)) + (math-mat-less-row mat n))) +) + +(defun calcFunc-getdiag (mat) ; [Public] + (if (math-square-matrixp mat) + (cons 'vec (math-get-diag-step (cdr mat) 1)) + (calc-record-why 'square-matrixp mat) + (list 'calcFunc-getdiag mat)) +) + +(defun math-get-diag-step (row n) + (and row + (cons (nth n (car row)) + (math-get-diag-step (cdr row) (1+ n)))) +) + +(defun math-transpose (mat) ; [Public] + (let ((m nil) + (col (length (nth 1 mat)))) + (while (> (setq col (1- col)) 0) + (setq m (cons (math-mat-col mat col) m))) + (cons 'vec m)) +) + +(defun calcFunc-trn (mat) + (if (math-vectorp mat) + (if (math-matrixp mat) + (math-transpose mat) + (math-col-matrix mat)) + (if (math-numberp mat) + mat + (math-reject-arg mat 'matrixp))) +) + +(defun calcFunc-ctrn (mat) + (calcFunc-conj (calcFunc-trn mat)) +) + +(defun calcFunc-pack (mode els) + (or (Math-vectorp els) (math-reject-arg els 'vectorp)) + (if (and (Math-vectorp mode) (cdr mode)) + (setq mode (cdr mode)) + (or (integerp mode) (math-reject-arg mode 'fixnump))) + (condition-case err + (if (= (calc-pack-size mode) (1- (length els))) + (calc-pack-items mode (cdr els)) + (math-reject-arg els "*Wrong number of elements")) + (error (math-reject-arg els (nth 1 err)))) +) + +(defun calcFunc-unpack (mode thing) + (or (integerp mode) (math-reject-arg mode 'fixnump)) + (condition-case err + (cons 'vec (calc-unpack-item mode thing)) + (error (math-reject-arg thing (nth 1 err)))) +) + +(defun calcFunc-unpackt (mode thing) + (let ((calc-unpack-with-type 'pair)) + (calcFunc-unpack mode thing)) +) + +(defun calcFunc-arrange (vec cols) ; [Public] + (setq cols (math-check-fixnum cols t)) + (if (math-vectorp vec) + (let* ((flat (math-flatten-vector vec)) + (mat (list 'vec)) + next) + (if (<= cols 0) + (nconc mat flat) + (while (>= (length flat) cols) + (setq next (nthcdr cols flat)) + (setcdr (nthcdr (1- cols) flat) nil) + (setq mat (nconc mat (list (cons 'vec flat))) + flat next)) + (if flat + (setq mat (nconc mat (list (cons 'vec flat))))) + mat))) +) + +(defun math-flatten-vector (vec) ; [L V] + (if (math-vectorp vec) + (apply 'append (mapcar 'math-flatten-vector (cdr vec))) + (list vec)) +) + +(defun calcFunc-vconcat (a b) + (math-normalize (list '| a b)) +) + +(defun calcFunc-vconcatrev (a b) + (math-normalize (list '| b a)) +) + +(defun calcFunc-append (v1 v2) + (if (and (math-vectorp v1) (math-vectorp v2)) + (append v1 (cdr v2)) + (list 'calcFunc-append v1 v2)) +) + +(defun calcFunc-appendrev (v1 v2) + (calcFunc-append v2 v1) +) + + +;;; Copy a matrix. [Public] +(defun math-copy-matrix (m) + (if (math-vectorp (nth 1 m)) + (cons 'vec (mapcar 'copy-sequence (cdr m))) + (copy-sequence m)) +) + +;;; Convert a scalar or vector into an NxN diagonal matrix. [Public] +(defun calcFunc-diag (a &optional n) + (and n (not (integerp n)) + (setq n (math-check-fixnum n))) + (if (math-vectorp a) + (if (and n (/= (length a) (1+ n))) + (list 'calcFunc-diag a n) + (if (math-matrixp a) + (if (and n (/= (length (elt a 1)) (1+ n))) + (list 'calcFunc-diag a n) + a) + (cons 'vec (math-diag-step (cdr a) 0 (1- (length a)))))) + (if n + (cons 'vec (math-diag-step (make-list n a) 0 n)) + (list 'calcFunc-diag a))) +) + +(defun calcFunc-idn (a &optional n) + (if n + (if (math-vectorp a) + (math-reject-arg a 'numberp) + (calcFunc-diag a n)) + (if (integerp calc-matrix-mode) + (calcFunc-idn a calc-matrix-mode) + (list 'calcFunc-idn a))) +) + +(defun math-mimic-ident (a m) + (if (math-square-matrixp m) + (calcFunc-idn a (1- (length m))) + (if (math-vectorp m) + (if (math-zerop a) + (cons 'vec (mapcar (function (lambda (x) + (if (math-vectorp x) + (math-mimic-ident a x) + a))) + (cdr m))) + (math-dimension-error)) + (calcFunc-idn a))) +) + +(defun math-diag-step (a n m) + (if (< n m) + (cons (cons 'vec + (nconc (make-list n 0) + (cons (car a) + (make-list (1- (- m n)) 0)))) + (math-diag-step (cdr a) (1+ n) m)) + nil) +) + +;;; Create a vector of consecutive integers. [Public] +(defun calcFunc-index (n &optional start incr) + (if (math-messy-integerp n) + (math-float (calcFunc-index (math-trunc n) start incr)) + (and (not (integerp n)) + (setq n (math-check-fixnum n))) + (let ((vec nil)) + (if start + (progn + (if (>= n 0) + (while (>= (setq n (1- n)) 0) + (setq vec (cons start vec) + start (math-add start (or incr 1)))) + (while (<= (setq n (1+ n)) 0) + (setq vec (cons start vec) + start (math-mul start (or incr 2))))) + (setq vec (nreverse vec))) + (if (>= n 0) + (while (> n 0) + (setq vec (cons n vec) + n (1- n))) + (let ((i -1)) + (while (>= i n) + (setq vec (cons i vec) + i (1- i)))))) + (cons 'vec vec))) +) + +;;; Find an element in a vector. +(defun calcFunc-find (vec x &optional start) + (setq start (if start (math-check-fixnum start t) 1)) + (if (< start 1) (math-reject-arg start 'posp)) + (setq vec (nthcdr start vec)) + (let ((n start)) + (while (and vec (not (Math-equal x (car vec)))) + (setq n (1+ n) + vec (cdr vec))) + (if vec n 0)) +) + +;;; Return a subvector of a vector. +(defun calcFunc-subvec (vec start &optional end) + (setq start (math-check-fixnum start t) + end (math-check-fixnum (or end 0) t)) + (or (math-vectorp vec) (math-reject-arg vec 'vectorp)) + (let ((len (1- (length vec)))) + (if (<= start 0) + (setq start (+ len start 1))) + (if (<= end 0) + (setq end (+ len end 1))) + (if (or (> start len) + (<= end start)) + '(vec) + (setq vec (nthcdr start vec)) + (if (<= end len) + (let ((chop (nthcdr (- end start 1) (setq vec (copy-sequence vec))))) + (setcdr chop nil))) + (cons 'vec vec))) +) + +;;; Remove a subvector from a vector. +(defun calcFunc-rsubvec (vec start &optional end) + (setq start (math-check-fixnum start t) + end (math-check-fixnum (or end 0) t)) + (or (math-vectorp vec) (math-reject-arg vec 'vectorp)) + (let ((len (1- (length vec)))) + (if (<= start 0) + (setq start (+ len start 1))) + (if (<= end 0) + (setq end (+ len end 1))) + (if (or (> start len) + (<= end start)) + vec + (let ((tail (nthcdr end vec)) + (chop (nthcdr (1- start) (setq vec (copy-sequence vec))))) + (setcdr chop nil) + (append vec tail)))) +) + +;;; Reverse the order of the elements of a vector. +(defun calcFunc-rev (vec) + (if (math-vectorp vec) + (cons 'vec (reverse (cdr vec))) + (math-reject-arg vec 'vectorp)) +) + +;;; Compress a vector according to a mask vector. +(defun calcFunc-vmask (mask vec) + (if (math-numberp mask) + (if (math-zerop mask) + '(vec) + vec) + (or (math-vectorp mask) (math-reject-arg mask 'vectorp)) + (or (math-constp mask) (math-reject-arg mask 'constp)) + (or (math-vectorp vec) (math-reject-arg vec 'vectorp)) + (or (= (length mask) (length vec)) (math-dimension-error)) + (let ((new nil)) + (while (setq mask (cdr mask) vec (cdr vec)) + (or (math-zerop (car mask)) + (setq new (cons (car vec) new)))) + (cons 'vec (nreverse new)))) +) + +;;; Expand a vector according to a mask vector. +(defun calcFunc-vexp (mask vec &optional filler) + (or (math-vectorp mask) (math-reject-arg mask 'vectorp)) + (or (math-constp mask) (math-reject-arg mask 'constp)) + (or (math-vectorp vec) (math-reject-arg vec 'vectorp)) + (let ((new nil) + (fvec (and filler (math-vectorp filler)))) + (while (setq mask (cdr mask)) + (if (math-zerop (car mask)) + (setq new (cons (or (if fvec + (car (setq filler (cdr filler))) + filler) + (car mask)) new)) + (setq vec (cdr vec) + new (cons (or (car vec) (car mask)) new)))) + (cons 'vec (nreverse new))) +) + + +;;; Compute the row and column norms of a vector or matrix. [Public] +(defun calcFunc-rnorm (a) + (if (and (Math-vectorp a) + (math-constp a)) + (if (math-matrixp a) + (math-reduce-vec 'math-max (math-map-vec 'calcFunc-cnorm a)) + (math-reduce-vec 'math-max (math-map-vec 'math-abs a))) + (calc-record-why 'vectorp a) + (list 'calcFunc-rnorm a)) +) + +(defun calcFunc-cnorm (a) + (if (and (Math-vectorp a) + (math-constp a)) + (if (math-matrixp a) + (math-reduce-vec 'math-max + (math-reduce-cols 'math-add-abs a)) + (math-reduce-vec 'math-add-abs a)) + (calc-record-why 'vectorp a) + (list 'calcFunc-cnorm a)) +) + +(defun math-add-abs (a b) + (math-add (math-abs a) (math-abs b)) +) + + +;;; Sort the elements of a vector into increasing order. +(defun calcFunc-sort (vec) ; [Public] + (if (math-vectorp vec) + (cons 'vec (sort (copy-sequence (cdr vec)) 'math-beforep)) + (math-reject-arg vec 'vectorp)) +) + +(defun calcFunc-rsort (vec) ; [Public] + (if (math-vectorp vec) + (cons 'vec (nreverse (sort (copy-sequence (cdr vec)) 'math-beforep))) + (math-reject-arg vec 'vectorp)) +) + +(defun calcFunc-grade (grade-vec) + (if (math-vectorp grade-vec) + (let* ((len (1- (length grade-vec)))) + (cons 'vec (sort (cdr (calcFunc-index len)) 'math-grade-beforep))) + (math-reject-arg grade-vec 'vectorp)) +) + +(defun calcFunc-rgrade (grade-vec) + (if (math-vectorp grade-vec) + (let* ((len (1- (length grade-vec)))) + (cons 'vec (nreverse (sort (cdr (calcFunc-index len)) + 'math-grade-beforep)))) + (math-reject-arg grade-vec 'vectorp)) +) + +(defun math-grade-beforep (i j) + (math-beforep (nth i grade-vec) (nth j grade-vec)) +) + + +;;; Compile a histogram of data from a vector. +(defun calcFunc-histogram (vec wts &optional n) + (or n (setq n wts wts 1)) + (or (Math-vectorp vec) + (math-reject-arg vec 'vectorp)) + (if (Math-vectorp wts) + (or (= (length vec) (length wts)) + (math-dimension-error))) + (or (natnump n) + (math-reject-arg n 'fixnatnump)) + (let ((res (make-vector n 0)) + (vp vec) + (wvec (Math-vectorp wts)) + (wp wts) + bin) + (while (setq vp (cdr vp)) + (setq bin (car vp)) + (or (natnump bin) + (setq bin (math-floor bin))) + (and (natnump bin) + (< bin n) + (aset res bin (math-add (aref res bin) + (if wvec (car (setq wp (cdr wp))) wts))))) + (cons 'vec (append res nil))) +) + + +;;; Set operations. + +(defun calcFunc-vunion (a b) + (if (Math-objectp a) + (setq a (list 'vec a)) + (or (math-vectorp a) (math-reject-arg a 'vectorp))) + (if (Math-objectp b) + (setq b (list b)) + (or (math-vectorp b) (math-reject-arg b 'vectorp)) + (setq b (cdr b))) + (calcFunc-rdup (append a b)) +) + +(defun calcFunc-vint (a b) + (if (and (math-simple-set a) (math-simple-set b)) + (progn + (setq a (cdr (calcFunc-rdup a))) + (setq b (cdr (calcFunc-rdup b))) + (let ((vec (list 'vec))) + (while (and a b) + (if (math-beforep (car a) (car b)) + (setq a (cdr a)) + (if (Math-equal (car a) (car b)) + (setq vec (cons (car a) vec) + a (cdr a))) + (setq b (cdr b)))) + (nreverse vec))) + (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) + (calcFunc-vcompl b)))) +) + +(defun calcFunc-vdiff (a b) + (if (and (math-simple-set a) (math-simple-set b)) + (progn + (setq a (cdr (calcFunc-rdup a))) + (setq b (cdr (calcFunc-rdup b))) + (let ((vec (list 'vec))) + (while a + (while (and b (math-beforep (car b) (car a))) + (setq b (cdr b))) + (if (and b (Math-equal (car a) (car b))) + (setq a (cdr a) + b (cdr b)) + (setq vec (cons (car a) vec) + a (cdr a)))) + (nreverse vec))) + (calcFunc-vcompl (calcFunc-vunion (calcFunc-vcompl a) b))) +) + +(defun calcFunc-vxor (a b) + (if (and (math-simple-set a) (math-simple-set b)) + (progn + (setq a (cdr (calcFunc-rdup a))) + (setq b (cdr (calcFunc-rdup b))) + (let ((vec (list 'vec))) + (while (or a b) + (if (and a + (or (not b) + (math-beforep (car a) (car b)))) + (setq vec (cons (car a) vec) + a (cdr a)) + (if (and a (Math-equal (car a) (car b))) + (setq a (cdr a)) + (setq vec (cons (car b) vec))) + (setq b (cdr b)))) + (nreverse vec))) + (let ((ca (calcFunc-vcompl a)) + (cb (calcFunc-vcompl b))) + (calcFunc-vunion (calcFunc-vcompl (calcFunc-vunion ca b)) + (calcFunc-vcompl (calcFunc-vunion a cb))))) +) + +(defun calcFunc-vcompl (a) + (setq a (math-prepare-set a)) + (let ((vec (list 'vec)) + (prev '(neg (var inf var-inf))) + (closed 2)) + (while (setq a (cdr a)) + (or (and (equal (nth 2 (car a)) '(neg (var inf var-inf))) + (memq (nth 1 (car a)) '(2 3))) + (setq vec (cons (list 'intv + (+ closed + (if (memq (nth 1 (car a)) '(0 1)) 1 0)) + prev + (nth 2 (car a))) + vec))) + (setq prev (nth 3 (car a)) + closed (if (memq (nth 1 (car a)) '(0 2)) 2 0))) + (or (and (equal prev '(var inf var-inf)) + (= closed 0)) + (setq vec (cons (list 'intv (+ closed 1) + prev '(var inf var-inf)) + vec))) + (math-clean-set (nreverse vec))) +) + +(defun calcFunc-vspan (a) + (setq a (math-prepare-set a)) + (if (cdr a) + (let ((last (nth (1- (length a)) a))) + (math-make-intv (+ (logand (nth 1 (nth 1 a)) 2) + (logand (nth 1 last) 1)) + (nth 2 (nth 1 a)) + (nth 3 last))) + '(intv 2 0 0)) +) + +(defun calcFunc-vfloor (a &optional always-vec) + (setq a (math-prepare-set a)) + (let ((vec (list 'vec)) (p a) (prev nil) b mask) + (while (setq p (cdr p)) + (setq mask (nth 1 (car p)) + a (nth 2 (car p)) + b (nth 3 (car p))) + (and (memq mask '(0 1)) + (not (math-infinitep a)) + (setq mask (logior mask 2)) + (math-num-integerp a) + (setq a (math-add a 1))) + (setq a (math-ceiling a)) + (and (memq mask '(0 2)) + (not (math-infinitep b)) + (setq mask (logior mask 1)) + (math-num-integerp b) + (setq b (math-sub b 1))) + (setq b (math-floor b)) + (if (and prev (Math-equal (math-sub a 1) (nth 3 prev))) + (setcar (nthcdr 3 prev) b) + (or (Math-lessp b a) + (setq vec (cons (setq prev (list 'intv mask a b)) vec))))) + (setq vec (nreverse vec)) + (math-clean-set vec always-vec)) +) + +(defun calcFunc-vcard (a) + (setq a (calcFunc-vfloor a t)) + (or (math-constp a) (math-reject-arg a "*Set must be finite")) + (let ((count 0)) + (while (setq a (cdr a)) + (if (eq (car-safe (car a)) 'intv) + (setq count (math-add count (math-sub (nth 3 (car a)) + (nth 2 (car a)))))) + (setq count (math-add count 1))) + count) +) + +(defun calcFunc-venum (a) + (setq a (calcFunc-vfloor a t)) + (or (math-constp a) (math-reject-arg a "*Set must be finite")) + (let ((p a) next) + (while (cdr p) + (setq next (cdr p)) + (if (eq (car-safe (nth 1 p)) 'intv) + (setcdr p (nconc (cdr (calcFunc-index (math-add + (math-sub (nth 3 (nth 1 p)) + (nth 2 (nth 1 p))) + 1) + (nth 2 (nth 1 p)))) + (cdr (cdr p))))) + (setq p next)) + a) +) + +(defun calcFunc-vpack (a) + (setq a (calcFunc-vfloor a t)) + (if (and (cdr a) + (math-negp (if (eq (car-safe (nth 1 a)) 'intv) + (nth 2 (nth 1 a)) + (nth 1 a)))) + (math-reject-arg (nth 1 a) 'posp)) + (let ((accum 0)) + (while (setq a (cdr a)) + (if (eq (car-safe (car a)) 'intv) + (if (equal (nth 3 (car a)) '(var inf var-inf)) + (setq accum (math-sub accum + (math-power-of-2 (nth 2 (car a))))) + (setq accum (math-add accum + (math-sub + (math-power-of-2 (1+ (nth 3 (car a)))) + (math-power-of-2 (nth 2 (car a))))))) + (setq accum (math-add accum (math-power-of-2 (car a)))))) + accum) +) + +(defun calcFunc-vunpack (a &optional w) + (or (math-num-integerp a) (math-reject-arg a 'integerp)) + (if w (setq a (math-clip a w))) + (if (math-messy-integerp a) (setq a (math-trunc a))) + (let* ((calc-number-radix 2) + (neg (math-negp a)) + (aa (if neg (math-sub -1 a) a)) + (str (if (eq aa 0) + "" + (if (consp aa) + (math-format-bignum-binary (cdr aa)) + (math-format-binary aa)))) + (zero (if neg ?1 ?0)) + (one (if neg ?0 ?1)) + (len (length str)) + (vec (list 'vec)) + (pos (1- len)) pos2) + (while (>= pos 0) + (if (eq (aref str pos) zero) + (setq pos (1- pos)) + (setq pos2 pos) + (while (and (>= pos 0) (eq (aref str pos) one)) + (setq pos (1- pos))) + (setq vec (cons (if (= pos (1- pos2)) + (- len pos2 1) + (list 'intv 3 (- len pos2 1) (- len pos 2))) + vec)))) + (if neg + (setq vec (cons (list 'intv 2 len '(var inf var-inf)) vec))) + (math-clean-set (nreverse vec))) +) + +(defun calcFunc-rdup (a) + (if (math-simple-set a) + (progn + (and (Math-objectp a) (setq a (list 'vec a))) + (or (math-vectorp a) (math-reject-arg a 'vectorp)) + (setq a (sort (copy-sequence (cdr a)) 'math-beforep)) + (let ((p a)) + (while (cdr p) + (if (Math-equal (car p) (nth 1 p)) + (setcdr p (cdr (cdr p))) + (setq p (cdr p))))) + (cons 'vec a)) + (math-clean-set (math-prepare-set a))) +) + +(defun math-prepare-set (a) + (if (Math-objectp a) + (setq a (list 'vec a)) + (or (math-vectorp a) (math-reject-arg a 'vectorp)) + (setq a (cons 'vec (sort (copy-sequence (cdr a)) 'math-beforep)))) + (let ((p a) res) + + ;; Convert all elements to non-empty intervals. + (while (cdr p) + (if (eq (car-safe (nth 1 p)) 'intv) + (if (math-intv-constp (nth 1 p)) + (if (and (memq (nth 1 (nth 1 p)) '(0 1 2)) + (Math-equal (nth 2 (nth 1 p)) (nth 3 (nth 1 p)))) + (setcdr p (cdr (cdr p))) + (setq p (cdr p))) + (math-reject-arg (nth 1 p) 'constp)) + (or (Math-anglep (nth 1 p)) + (eq (car (nth 1 p)) 'date) + (equal (nth 1 p) '(var inf var-inf)) + (equal (nth 1 p) '(neg (var inf var-inf))) + (math-reject-arg (nth 1 p) 'realp)) + (setcar (cdr p) (list 'intv 3 (nth 1 p) (nth 1 p))) + (setq p (cdr p)))) + + ;; Combine redundant intervals. + (setq p a) + (while (cdr (cdr p)) + (if (or (memq (setq res (math-compare (nth 3 (nth 1 p)) + (nth 2 (nth 2 p)))) + '(-1 2)) + (and (eq res 0) + (memq (nth 1 (nth 1 p)) '(0 2)) + (memq (nth 1 (nth 2 p)) '(0 1)))) + (setq p (cdr p)) + (setq res (math-compare (nth 3 (nth 1 p)) (nth 3 (nth 2 p)))) + (setcdr p (cons (list 'intv + (+ (logand (logior (nth 1 (nth 1 p)) + (if (Math-equal + (nth 2 (nth 1 p)) + (nth 2 (nth 2 p))) + (nth 1 (nth 2 p)) + 0)) + 2) + (logand (logior (if (memq res '(1 0 2)) + (nth 1 (nth 1 p)) 0) + (if (memq res '(-1 0 2)) + (nth 1 (nth 2 p)) 0)) + 1)) + (nth 2 (nth 1 p)) + (if (eq res 1) + (nth 3 (nth 1 p)) + (nth 3 (nth 2 p)))) + (cdr (cdr (cdr p)))))))) + a +) + +(defun math-clean-set (a &optional always-vec) + (let ((p a) res) + (while (cdr p) + (if (and (eq (car-safe (nth 1 p)) 'intv) + (Math-equal (nth 2 (nth 1 p)) (nth 3 (nth 1 p)))) + (setcar (cdr p) (nth 2 (nth 1 p)))) + (setq p (cdr p))) + (if (and (not (cdr (cdr a))) + (eq (car-safe (nth 1 a)) 'intv) + (not always-vec)) + (nth 1 a) + a)) +) + +(defun math-simple-set (a) + (or (and (Math-objectp a) + (not (eq (car-safe a) 'intv))) + (and (Math-vectorp a) + (progn + (while (and (setq a (cdr a)) + (not (eq (car-safe (car a)) 'intv)))) + (null a)))) +) + + + + +;;; Compute a right-handed vector cross product. [O O O] [Public] +(defun calcFunc-cross (a b) + (if (and (eq (car-safe a) 'vec) + (= (length a) 4)) + (if (and (eq (car-safe b) 'vec) + (= (length b) 4)) + (list 'vec + (math-sub (math-mul (nth 2 a) (nth 3 b)) + (math-mul (nth 3 a) (nth 2 b))) + (math-sub (math-mul (nth 3 a) (nth 1 b)) + (math-mul (nth 1 a) (nth 3 b))) + (math-sub (math-mul (nth 1 a) (nth 2 b)) + (math-mul (nth 2 a) (nth 1 b)))) + (math-reject-arg b "*Three-vector expected")) + (math-reject-arg a "*Three-vector expected")) +) + + + + + +(defun math-read-brackets (space-sep close) + (and space-sep (setq space-sep (not (math-check-for-commas)))) + (math-read-token) + (while (eq exp-token 'space) + (math-read-token)) + (if (or (equal exp-data close) + (eq exp-token 'end)) + (progn + (math-read-token) + '(vec)) + (let ((save-exp-pos exp-pos) + (save-exp-old-pos exp-old-pos) + (save-exp-token exp-token) + (save-exp-data exp-data) + (vals (let ((exp-keep-spaces space-sep)) + (if (or (equal exp-data "\\dots") + (equal exp-data "\\ldots")) + '(vec (neg (var inf var-inf))) + (catch 'syntax (math-read-vector)))))) + (if (stringp vals) + (if space-sep + (let ((error-exp-pos exp-pos) + (error-exp-old-pos exp-old-pos) + vals2) + (setq exp-pos save-exp-pos + exp-old-pos save-exp-old-pos + exp-token save-exp-token + exp-data save-exp-data) + (let ((exp-keep-spaces nil)) + (setq vals2 (catch 'syntax (math-read-vector)))) + (if (and (not (stringp vals2)) + (or (assoc exp-data '(("\\ldots") ("\\dots") (";"))) + (equal exp-data close) + (eq exp-token 'end))) + (setq space-sep nil + vals vals2) + (setq exp-pos error-exp-pos + exp-old-pos error-exp-old-pos) + (throw 'syntax vals))) + (throw 'syntax vals))) + (if (or (equal exp-data "\\dots") + (equal exp-data "\\ldots")) + (progn + (math-read-token) + (setq vals (if (> (length vals) 2) + (cons 'calcFunc-mul (cdr vals)) (nth 1 vals))) + (let ((exp2 (if (or (equal exp-data close) + (equal exp-data ")") + (eq exp-token 'end)) + '(var inf var-inf) + (math-read-expr-level 0)))) + (setq vals + (list 'intv + (if (equal exp-data ")") 2 3) + vals + exp2))) + (if (not (or (equal exp-data close) + (equal exp-data ")") + (eq exp-token 'end))) + (throw 'syntax "Expected `]'"))) + (if (equal exp-data ";") + (let ((exp-keep-spaces space-sep)) + (setq vals (cons 'vec (math-read-matrix (list vals)))))) + (if (not (or (equal exp-data close) + (eq exp-token 'end))) + (throw 'syntax "Expected `]'"))) + (or (eq exp-token 'end) + (math-read-token)) + vals)) +) + +(defun math-check-for-commas (&optional balancing) + (let ((count 0) + (pos (1- exp-pos))) + (while (and (>= count 0) + (setq pos (string-match + (if balancing "[],[{}()<>]" "[],[{}()]") + exp-str (1+ pos))) + (or (/= (aref exp-str pos) ?,) (> count 0) balancing)) + (cond ((memq (aref exp-str pos) '(?\[ ?\{ ?\( ?\<)) + (setq count (1+ count))) + ((memq (aref exp-str pos) '(?\] ?\} ?\) ?\>)) + (setq count (1- count))))) + (if balancing + pos + (and pos (= (aref exp-str pos) ?,)))) +) + +(defun math-read-vector () + (let* ((val (list (math-read-expr-level 0))) + (last val)) + (while (progn + (while (eq exp-token 'space) + (math-read-token)) + (and (not (eq exp-token 'end)) + (not (equal exp-data ";")) + (not (equal exp-data close)) + (not (equal exp-data "\\dots")) + (not (equal exp-data "\\ldots")))) + (if (equal exp-data ",") + (math-read-token)) + (while (eq exp-token 'space) + (math-read-token)) + (let ((rest (list (math-read-expr-level 0)))) + (setcdr last rest) + (setq last rest))) + (cons 'vec val)) +) + +(defun math-read-matrix (mat) + (while (equal exp-data ";") + (math-read-token) + (while (eq exp-token 'space) + (math-read-token)) + (setq mat (nconc mat (list (math-read-vector))))) + mat +) + diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el new file mode 100644 index 0000000000..6551233416 --- /dev/null +++ b/lisp/calc/calc-yank.el @@ -0,0 +1,593 @@ +;; Calculator for GNU Emacs, part II [calc-yank.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-yank () nil) + + +;;; Kill ring commands. + +(defun calc-kill (nn &optional no-delete) + (interactive "P") + (if (eq major-mode 'calc-mode) + (calc-wrapper + (calc-force-refresh) + (calc-set-command-flag 'no-align) + (let ((num (max (calc-locate-cursor-element (point)) 1)) + (n (prefix-numeric-value nn))) + (if (< n 0) + (progn + (if (eobp) + (setq num (1- num))) + (setq num (- num n) + n (- n)))) + (let ((stuff (calc-top-list n (- num n -1)))) + (calc-cursor-stack-index num) + (let ((first (point))) + (calc-cursor-stack-index (- num n)) + (if (null nn) + (backward-char 1)) ; don't include newline for raw C-k + (copy-region-as-kill first (point)) + (if (not no-delete) + (calc-pop-stack n (- num n -1)))) + (setq calc-last-kill (cons (car kill-ring) stuff))))) + (kill-line nn)) +) + +(defun calc-force-refresh () + (if (or calc-executing-macro calc-display-dirty) + (let ((calc-executing-macro nil)) + (calc-refresh))) +) + +(defun calc-locate-cursor-element (pt) + (save-excursion + (goto-char (point-max)) + (calc-locate-cursor-scan (- calc-stack-top) calc-stack pt)) +) + +(defun calc-locate-cursor-scan (n stack pt) + (if (or (<= (point) pt) + (null stack)) + n + (forward-line (- (nth 1 (car stack)))) + (calc-locate-cursor-scan (1+ n) (cdr stack) pt)) +) + +(defun calc-kill-region (top bot &optional no-delete) + (interactive "r") + (if (eq major-mode 'calc-mode) + (calc-wrapper + (calc-force-refresh) + (calc-set-command-flag 'no-align) + (let* ((top-num (calc-locate-cursor-element top)) + (bot-num (calc-locate-cursor-element (1- bot))) + (num (- top-num bot-num -1))) + (copy-region-as-kill top bot) + (setq calc-last-kill (cons (car kill-ring) + (calc-top-list num bot-num))) + (if (not no-delete) + (calc-pop-stack num bot-num)))) + (if no-delete + (copy-region-as-kill top bot) + (kill-region top bot))) +) + +(defun calc-copy-as-kill (n) + (interactive "P") + (calc-kill n t) +) + +(defun calc-copy-region-as-kill (top bot) + (interactive "r") + (calc-kill-region top bot t) +) + +;;; This function uses calc-last-kill if possible to get an exact result, +;;; otherwise it just parses the yanked string. +;;; Modified to use Emacs 19 extended concept of kill-ring. -- daveg 12/15/96 +(defun calc-yank () + (interactive) + (calc-wrapper + (calc-pop-push-record-list + 0 "yank" + (let ((thing (if (fboundp 'current-kill) + (current-kill 0 t) + (car kill-ring-yank-pointer)))) + (if (eq (car-safe calc-last-kill) thing) + (cdr calc-last-kill) + (if (stringp thing) + (let ((val (math-read-exprs (calc-clean-newlines thing)))) + (if (eq (car-safe val) 'error) + (progn + (setq val (math-read-exprs thing)) + (if (eq (car-safe val) 'error) + (error "Bad format in yanked data") + val)) + val))))))) +) + +(defun calc-clean-newlines (s) + (cond + + ;; Omit leading/trailing whitespace + ((or (string-match "\\`[ \n\r]+\\([^\001]*\\)\\'" s) + (string-match "\\`\\([^\001]*\\)[ \n\r]+\\'" s)) + (calc-clean-newlines (math-match-substring s 1))) + + ;; Convert newlines to commas + ((string-match "\\`\\(.*\\)[\n\r]+\\([^\001]*\\)\\'" s) + (calc-clean-newlines (concat (math-match-substring s 1) "," + (math-match-substring s 2)))) + + (t s)) +) + + +(defun calc-do-grab-region (top bot arg) + (and (memq major-mode '(calc-mode calc-trail-mode)) + (error "This command works only in a regular text buffer.")) + (let* ((from-buffer (current-buffer)) + (calc-was-started (get-buffer-window "*Calculator*")) + (single nil) + data vals pos) + (if arg + (if (consp arg) + (setq single t) + (setq arg (prefix-numeric-value arg)) + (if (= arg 0) + (save-excursion + (beginning-of-line) + (setq top (point)) + (end-of-line) + (setq bot (point))) + (save-excursion + (setq top (point)) + (forward-line arg) + (if (> arg 0) + (setq bot (point)) + (setq bot top + top (point))))))) + (setq data (buffer-substring top bot)) + (calc) + (if single + (setq vals (math-read-expr data)) + (setq vals (math-read-expr (concat "[" data "]"))) + (and (eq (car-safe vals) 'vec) + (= (length vals) 2) + (eq (car-safe (nth 1 vals)) 'vec) + (setq vals (nth 1 vals)))) + (if (eq (car-safe vals) 'error) + (progn + (if calc-was-started + (pop-to-buffer from-buffer) + (calc-quit t) + (switch-to-buffer from-buffer)) + (goto-char top) + (forward-char (+ (nth 1 vals) (if single 0 1))) + (error (nth 2 vals)))) + (calc-slow-wrapper + (calc-enter-result 0 "grab" vals))) +) + + +(defun calc-do-grab-rectangle (top bot arg &optional reduce) + (and (memq major-mode '(calc-mode calc-trail-mode)) + (error "This command works only in a regular text buffer.")) + (let* ((col1 (save-excursion (goto-char top) (current-column))) + (col2 (save-excursion (goto-char bot) (current-column))) + (from-buffer (current-buffer)) + (calc-was-started (get-buffer-window "*Calculator*")) + data mat vals lnum pt pos) + (if (= col1 col2) + (save-excursion + (or (= col1 0) + (error "Point and mark must be at beginning of line, or define a rectangle")) + (goto-char top) + (while (< (point) bot) + (setq pt (point)) + (forward-line 1) + (setq data (cons (buffer-substring pt (1- (point))) data))) + (setq data (nreverse data))) + (setq data (extract-rectangle top bot))) + (calc) + (setq mat (list 'vec) + lnum 0) + (and arg + (setq arg (if (consp arg) 0 (prefix-numeric-value arg)))) + (while data + (if (natnump arg) + (progn + (if (= arg 0) + (setq arg 1000000)) + (setq pos 0 + vals (list 'vec)) + (let ((w (length (car data))) + j v) + (while (< pos w) + (setq j (+ pos arg) + v (if (>= j w) + (math-read-expr (substring (car data) pos)) + (math-read-expr (substring (car data) pos j)))) + (if (eq (car-safe v) 'error) + (setq vals v w 0) + (setq vals (nconc vals (list v)) + pos j))))) + (if (string-match "\\` *-?[0-9][0-9]?[0-9]?[0-9]?[0-9]?[0-9]? *\\'" + (car data)) + (setq vals (list 'vec (string-to-int (car data)))) + (if (and (null arg) + (string-match "[[{][^][{}]*[]}]" (car data))) + (setq pos (match-beginning 0) + vals (math-read-expr (math-match-substring (car data) 0))) + (let ((s (if (string-match + "\\`\\([0-9]+:[ \t]\\)?\\(.*[^, \t]\\)[, \t]*\\'" + (car data)) + (math-match-substring (car data) 2) + (car data)))) + (setq pos -1 + vals (math-read-expr (concat "[" s "]"))) + (if (eq (car-safe vals) 'error) + (let ((v2 (math-read-expr s))) + (or (eq (car-safe v2) 'error) + (setq vals (list 'vec v2))))))))) + (if (eq (car-safe vals) 'error) + (progn + (if calc-was-started + (pop-to-buffer from-buffer) + (calc-quit t) + (switch-to-buffer from-buffer)) + (goto-char top) + (forward-line lnum) + (forward-char (+ (nth 1 vals) (min col1 col2) pos)) + (error (nth 2 vals)))) + (or (equal vals '(vec)) + (setq mat (cons vals mat))) + (setq data (cdr data) + lnum (1+ lnum))) + (calc-slow-wrapper + (if reduce + (calc-enter-result 0 "grb+" (list reduce '(var add var-add) + (nreverse mat))) + (calc-enter-result 0 "grab" (nreverse mat))))) +) + + +(defun calc-copy-to-buffer (nn) + "Copy the top of stack into an editing buffer." + (interactive "P") + (let ((thebuf (and (not (memq major-mode '(calc-mode calc-trail-mode))) + (current-buffer))) + (movept nil) + oldbuf newbuf) + (calc-wrapper + (save-excursion + (calc-force-refresh) + (let ((n (prefix-numeric-value nn)) + (eat-lnums calc-line-numbering) + (big-offset (if (eq calc-language 'big) 1 0)) + top bot) + (setq oldbuf (current-buffer) + newbuf (or thebuf + (calc-find-writable-buffer (buffer-list) 0) + (calc-find-writable-buffer (buffer-list) 1) + (error "No other buffer"))) + (cond ((and (or (null nn) + (consp nn)) + (= (calc-substack-height 0) + (- (1- (calc-substack-height 1)) big-offset))) + (calc-cursor-stack-index 1) + (if (looking-at + (if calc-line-numbering "[0-9]+: *[^ \n]" " *[^ \n]")) + (goto-char (1- (match-end 0)))) + (setq eat-lnums nil + top (point)) + (calc-cursor-stack-index 0) + (setq bot (- (1- (point)) big-offset))) + ((> n 0) + (calc-cursor-stack-index n) + (setq top (point)) + (calc-cursor-stack-index 0) + (setq bot (- (point) big-offset))) + ((< n 0) + (calc-cursor-stack-index (- n)) + (setq top (point)) + (calc-cursor-stack-index (1- (- n))) + (setq bot (point))) + (t + (goto-char (point-min)) + (forward-line 1) + (setq top (point)) + (calc-cursor-stack-index 0) + (setq bot (point)))) + (save-excursion + (set-buffer newbuf) + (if (consp nn) + (kill-region (region-beginning) (region-end))) + (push-mark (point) t) + (if (and overwrite-mode (not (consp nn))) + (calc-overwrite-string (save-excursion + (set-buffer oldbuf) + (buffer-substring top bot)) + eat-lnums) + (or (bolp) (setq eat-lnums nil)) + (insert-buffer-substring oldbuf top bot) + (and eat-lnums + (let ((n 1)) + (while (and (> (point) (mark)) + (progn + (forward-line -1) + (>= (point) (mark)))) + (delete-char 4) + (setq n (1+ n))) + (forward-line n)))) + (if thebuf (setq movept (point))) + (if (get-buffer-window (current-buffer)) + (set-window-point (get-buffer-window (current-buffer)) + (point))))))) + (if movept (goto-char movept)) + (and (consp nn) + (not thebuf) + (progn + (calc-quit t) + (switch-to-buffer newbuf)))) +) + +(defun calc-overwrite-string (str eat-lnums) + (if (string-match "\n\\'" str) + (setq str (substring str 0 -1))) + (if eat-lnums + (setq str (substring str 4))) + (if (and (string-match "\\`[-+]?[0-9.]+\\(e-?[0-9]+\\)?\\'" str) + (looking-at "[-+]?[0-9.]+\\(e-?[0-9]+\\)?")) + (progn + (delete-region (point) (match-end 0)) + (insert str)) + (let ((i 0)) + (while (< i (length str)) + (if (= (setq last-command-char (aref str i)) ?\n) + (or (= i (1- (length str))) + (let ((pt (point))) + (end-of-line) + (delete-region pt (point)) + (if (eobp) + (insert "\n") + (forward-char 1)) + (if eat-lnums (setq i (+ i 4))))) + (self-insert-command 1)) + (setq i (1+ i))))) +) + +;;; First, require that buffer is visible and does not begin with "*" +;;; Second, require only that it not begin with "*Calc" +(defun calc-find-writable-buffer (buf mode) + (and buf + (if (or (string-match "\\`\\( .*\\|\\*Calc.*\\)" + (buffer-name (car buf))) + (and (= mode 0) + (or (string-match "\\`\\*.*" (buffer-name (car buf))) + (not (get-buffer-window (car buf)))))) + (calc-find-writable-buffer (cdr buf) mode) + (car buf))) +) + + +(defun calc-edit (n) + (interactive "p") + (calc-slow-wrapper + (if (eq n 0) + (setq n (calc-stack-size))) + (let* ((flag nil) + (allow-ret (> n 1)) + (list (math-showing-full-precision + (mapcar (if (> n 1) + (function (lambda (x) + (math-format-flat-expr x 0))) + (function + (lambda (x) + (if (math-vectorp x) (setq allow-ret t)) + (math-format-nice-expr x (screen-width))))) + (if (> n 0) + (calc-top-list n) + (calc-top-list 1 (- n))))))) + (calc-edit-mode (list 'calc-finish-stack-edit (or flag n)) allow-ret) + (while list + (insert (car list) "\n") + (setq list (cdr list))))) + (calc-show-edit-buffer) +) + +(defun calc-alg-edit (str) + (calc-edit-mode '(calc-finish-stack-edit 0)) + (calc-show-edit-buffer) + (insert str "\n") + (backward-char 1) + (calc-set-command-flag 'do-edit) +) + +(defvar calc-edit-mode-map nil "Keymap for use by the calc-edit command.") +(if calc-edit-mode-map + () + (setq calc-edit-mode-map (make-sparse-keymap)) + (define-key calc-edit-mode-map "\n" 'calc-edit-finish) + (define-key calc-edit-mode-map "\r" 'calc-edit-return) + (define-key calc-edit-mode-map "\C-c\C-c" 'calc-edit-finish) +) + +(defun calc-edit-mode (&optional handler allow-ret title) + "Calculator editing mode. Press RET, LFD, or C-c C-c to finish. +To cancel the edit, simply kill the *Calc Edit* buffer." + (interactive) + (or handler + (error "This command can be used only indirectly through calc-edit.")) + (let ((oldbuf (current-buffer)) + (buf (get-buffer-create "*Calc Edit*"))) + (set-buffer buf) + (kill-all-local-variables) + (use-local-map calc-edit-mode-map) + (setq buffer-read-only nil) + (setq truncate-lines nil) + (setq major-mode 'calc-edit-mode) + (setq mode-name "Calc Edit") + (run-hooks 'calc-edit-mode-hook) + (make-local-variable 'calc-original-buffer) + (setq calc-original-buffer oldbuf) + (make-local-variable 'calc-return-buffer) + (setq calc-return-buffer oldbuf) + (make-local-variable 'calc-one-window) + (setq calc-one-window (and (one-window-p t) pop-up-windows)) + (make-local-variable 'calc-edit-handler) + (setq calc-edit-handler handler) + (make-local-variable 'calc-restore-trail) + (setq calc-restore-trail (get-buffer-window (calc-trail-buffer))) + (make-local-variable 'calc-allow-ret) + (setq calc-allow-ret allow-ret) + (erase-buffer) + (insert (or title title "Calc Edit Mode") + ". Press " + (if (eq (lookup-key (current-global-map) "\e#") 'calc-dispatch) + "M-# M-# or C-c C-c" + (if allow-ret "C-c C-c" "RET")) + " to finish, " + (if (eq (lookup-key (current-global-map) "\e#") 'calc-dispatch) + "M-# x" + "C-x k RET") + " to cancel.\n")) +) +(put 'calc-edit-mode 'mode-class 'special) + +(defun calc-show-edit-buffer () + (let ((buf (current-buffer))) + (if (and (one-window-p t) pop-up-windows) + (pop-to-buffer (get-buffer-create "*Calc Edit*")) + (and calc-embedded-info (get-buffer-window (aref calc-embedded-info 1)) + (select-window (get-buffer-window (aref calc-embedded-info 1)))) + (switch-to-buffer (get-buffer-create "*Calc Edit*"))) + (setq calc-return-buffer buf) + (if (and (< (window-width) (screen-width)) + calc-display-trail) + (let ((win (get-buffer-window (calc-trail-buffer)))) + (if win + (delete-window win)))) + (set-buffer-modified-p nil) + (goto-char (point-min)) + (forward-line 1)) +) + +(defun calc-edit-return () + (interactive) + (if (and (boundp 'calc-allow-ret) calc-allow-ret) + (newline) + (calc-edit-finish)) +) + +(defun calc-edit-finish (&optional keep) + "Finish calc-edit mode. Parse buffer contents and push them on the stack." + (interactive "P") + (message "Working...") + (or (and (boundp 'calc-original-buffer) + (boundp 'calc-return-buffer) + (boundp 'calc-one-window) + (boundp 'calc-edit-handler) + (boundp 'calc-restore-trail) + (eq major-mode 'calc-edit-mode)) + (error "This command is valid only in buffers created by calc-edit.")) + (let ((buf (current-buffer)) + (original calc-original-buffer) + (return calc-return-buffer) + (one-window calc-one-window) + (disp-trail calc-restore-trail)) + (save-excursion + (if (or (null (buffer-name original)) + (progn + (set-buffer original) + (not (eq major-mode 'calc-mode)))) + (error "Original calculator buffer has been corrupted."))) + (goto-char (point-min)) + (if (looking-at "Calc Edit\\|Editing ") + (forward-line 1)) + (if (buffer-modified-p) + (eval calc-edit-handler)) + (if one-window + (delete-window)) + (if (get-buffer-window return) + (select-window (get-buffer-window return)) + (switch-to-buffer return)) + (if keep + (bury-buffer buf) + (kill-buffer buf)) + (if disp-trail + (calc-wrapper + (calc-trail-display 1 t))) + (message "")) +) + +(defun calc-edit-cancel () + "Cancel calc-edit mode. Ignore the Calc Edit buffer and don't change stack." + (interactive) + (let ((calc-edit-handler nil)) + (calc-edit-finish)) + (message "(Cancelled)") +) + +(defun calc-finish-stack-edit (num) + (let ((buf (current-buffer)) + (str (buffer-substring (point) (point-max))) + (start (point)) + pos) + (if (and (integerp num) (> num 1)) + (while (setq pos (string-match "\n." str)) + (aset str pos ?\,))) + (switch-to-buffer calc-original-buffer) + (let ((vals (let ((calc-language nil) + (math-expr-opers math-standard-opers)) + (and (string-match "[^\n\t ]" str) + (math-read-exprs str))))) + (if (eq (car-safe vals) 'error) + (progn + (switch-to-buffer buf) + (goto-char (+ start (nth 1 vals))) + (error (nth 2 vals)))) + (calc-wrapper + (if (symbolp num) + (progn + (set num (car vals)) + (calc-refresh-evaltos num)) + (if disp-trail + (calc-trail-display 1 t)) + (and vals + (let ((calc-simplify-mode (if (eq last-command-char ?\C-j) + 'none + calc-simplify-mode))) + (if (>= num 0) + (calc-enter-result num "edit" vals) + (calc-enter-result 1 "edit" vals (- num))))))))) +) + + + + diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el new file mode 100644 index 0000000000..9e09ff8e97 --- /dev/null +++ b/lisp/calc/calc.el @@ -0,0 +1,3557 @@ +;; Calculator for GNU Emacs, part I +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;;; Calc is split into many files. This file is the main entry point. +;;; This file includes autoload commands for various other basic Calc +;;; facilities. The more advanced features are based in calc-ext, which +;;; in turn contains autoloads for the rest of the Calc files. This +;;; odd set of interactions is designed to make Calc's loading time +;;; be as short as possible when only simple calculations are needed. + +;;; Suggested usage: +;;; +;;; (autoload 'calc-dispatch "calc" "Emacs Calculator" t nil) +;;; (global-set-key "\e#" 'calc-dispatch) +;;; Type `M-# M-#' to start. +;;; +;;; The Calc home directory must be added to the Emacs load-path: +;;; +;;; (setq load-path (cons "/x/y/z/calc" load-path)) +;;; +;;; where "/x/y/z/calc" represents the full name of the Calc home directory. +;;; +;;; See the file INSTALL for a complete list of recommeded autoload +;;; commands (though only calc-dispatch is absolutely necessary). + + +;;; Author's address: +;;; Dave Gillespie, [email protected], uunet!synaptx!daveg. +;;; Synaptics, Inc., 2698 Orchard Parkway, San Jose, CA 95134. +;;; +;;; The old address [email protected] will continue to +;;; work for the foreseeable future. +;;; +;;; The latest version of Calc is always available from anonymous FTP +;;; on csvax.cs.caltech.edu [131.215.131.131]; look in ~ftp/pub/calc*. +;;; It should also be available on prep.ai.mit.edu. +;;; +;;; Bug reports and suggestions are always welcome! + + +;;; All functions, macros, and Lisp variables defined here begin with one +;;; of the prefixes "math", "Math", or "calc", with the exceptions of +;;; "full-calc", "full-calc-keypad", "another-calc", "quick-calc", +;;; "report-calc-bug", and "defmath". User-accessible variables begin +;;; with "var-". + + + +(provide 'calc) + + +(defun calc-record-compilation-date () + (calc-record-compilation-date-macro) +) +(calc-record-compilation-date) + + +;;; The "###autoload" comment will be used by Emacs version 19 for +;;; maintaining the loaddefs.el file automatically. + +;;;###autoload +(defvar calc-info-filename "calc.info" + "*File name in which to look for the Calculator's Info documentation.") + +;;;###autoload +(defvar calc-settings-file "~/.emacs" + "*File in which to record permanent settings; default is \"~/.emacs\".") + +;;;###autoload +(defvar calc-autoload-directory nil + "Name of directory from which additional \".elc\" files for Calc should be +loaded. Should include a trailing \"/\". +If nil, use original installation directory. +This can safely be nil as long as the Calc files are on the load-path.") + +;;;###autoload +(defvar calc-gnuplot-name "gnuplot" + "*Name of GNUPLOT program, for calc-graph features.") + +;;;###autoload +(defvar calc-gnuplot-plot-command nil + "*Name of command for displaying GNUPLOT output; %s = file name to print.") + +;;;###autoload +(defvar calc-gnuplot-print-command "lp %s" + "*Name of command for printing GNUPLOT output; %s = file name to print.") + + +;; Address of the author of Calc, for use by report-calc-bug. +(defvar calc-bug-address "[email protected]") + + +;; If T, scan keymaps to find all DEL-like keys. +;; If NIL, only DEL itself is mapped to calc-pop. +(defvar calc-scan-for-dels t) + + + +(defvar calc-extensions-loaded nil) + + + +;;; IDEAS: +;;; +;;; Fix rewrite mechanism to do less gratuitous rearrangement of terms. +;;; Implement a pattern-based "refers" predicate. +;;; +;;; Make it possible to Undo a selection command. +;;; Figure out how to allow selecting rows of matrices. +;;; If cursor was in selection before, move it after j n, j p, j L, etc. +;;; Consider reimplementing calc-delete-selection using rewrites. +;;; +;;; Implement line-breaking in non-flat compositions (is this desirable?). +;;; Implement matrix formatting with multi-line components. +;;; +;;; Have "Z R" define a user command based on a set of rewrite rules. +;;; Support "incf" and "decf" in defmath definitions. +;;; Have defmath generate calls to calc-binary-op or calc-unary-op. +;;; Make some way to define algebraic functions using keyboard macros. +;;; +;;; Allow calc-word-size=0 => Common Lisp-style signed bitwise arithmetic. +;;; Consider digamma function (and thus arb. prec. Euler's gamma constant). +;;; May as well make continued-fractions stuff available to the user. +;;; +;;; How about matrix eigenvalues, SVD, pseudo-inverse, etc.? +;;; Should cache matrix inverses as well as decompositions. +;;; If dividing by a non-square matrix, use least-squares automatically. +;;; Consider supporting matrix exponentials. +;;; +;;; Have ninteg detect and work around singularities at the endpoints. +;;; Use an adaptive subdivision algorithm for ninteg. +;;; Provide nsum and nprod to go along with ninteg. +;;; +;;; Handle TeX-mode parsing of \matrix{ ... } where ... contains braces. +;;; Support AmS-TeX's \{d,t,}frac, \{d,t,}binom notations. +;;; Format and parse sums and products in Eqn and Math modes. +;;; +;;; Get math-read-big-expr to read sums, products, etc. +;;; Change calc-grab-region to use math-read-big-expr. +;;; Have a way to define functions using := in Embedded Mode. +;;; +;;; Support polar plotting with GNUPLOT. +;;; Make a calc-graph-histogram function. +;;; +;;; Replace hokey formulas for complex functions with formulas designed +;;; to minimize roundoff while maintaining the proper branch cuts. +;;; Test accuracy of advanced math functions over whole complex plane. +;;; Extend Bessel functions to provide arbitrary precision. +;;; Extend advanced math functions to handle error forms and intervals. +;;; Provide a better implementation for math-sin-cos-raw. +;;; Provide a better implementation for math-hypot. +;;; Provide a better implementation for math-make-frac. +;;; Provide a better implementation for calcFunc-prfac. +;;; Provide a better implementation for calcFunc-factor. +;;; +;;; Provide more examples in the tutorial section of the manual. +;;; Cover in the tutorial: simplification modes, declarations, +;;; bitwise stuff, selections, matrix mapping, financial functions. +;;; Provide more Lisp programming examples in the manual. +;;; Finish the Internals section of the manual (and bring it up to date). +;;; +;;; Tim suggests adding spreadsheet-like features. +;;; Implement language modes for Gnuplot, Lisp, Ada, APL, ...? +;;; + + +;;; For atan series, if x > tan(pi/12) (about 0.268) reduce using the identity +;;; atan(x) = atan((x * sqrt(3) - 1) / (sqrt(3) + x)) + pi/6. + + +;;; A better integration algorithm: +;;; Use breadth-first instead of depth-first search, as follows: +;;; The integral cache allows unfinished integrals in symbolic notation +;;; on the righthand side. An entry with no unfinished integrals on the +;;; RHS is "complete"; references to it elsewhere are replaced by the +;;; integrated value. More than one cache entry for the same integral +;;; may exist, though if one becomes complete, the others may be deleted. +;;; The integrator works by using every applicable rule (such as +;;; substitution, parts, linearity, etc.) to generate possible righthand +;;; sides, all of which are entered into the cache. Now, as long as the +;;; target integral is not complete (and the time limit has not run out) +;;; choose an incomplete integral from the cache and, for every integral +;;; appearing in its RHS's, add those integrals to the cache using the +;;; same substitition, parts, etc. rules. The cache should be organized +;;; as a priority queue, choosing the "simplest" incomplete integral at +;;; each step, or choosing randomly among equally simple integrals. +;;; Simplicity equals small size, and few steps removed from the original +;;; target integral. Note that when the integrator finishes, incomplete +;;; integrals can be left in the cache, so the algorithm can start where +;;; it left off if another similar integral is later requested. +;;; Breadth-first search would avoid the nagging problem of, e.g., whether +;;; to use parts or substitution first, and which decomposition is best. +;;; All are tried, and any path that diverges will quickly be put on the +;;; back burner by the priority queue. +;;; Note: Probably a good idea to call math-simplify-extended before +;;; measuring a formula's simplicity. + + + + + + +;; Calculator stack. +;; Entries are 3-lists: Formula, Height (in lines), Selection (or nil). +(defvar calc-stack '((top-of-stack 1 nil))) + +;; Index into calc-stack of "top" of stack. +;; This is 1 unless calc-truncate-stack has been used. +;;(defvar calc-stack-top 1) + +;; If non-NIL, load the calc-ext module automatically when calc is loaded. +;;(defvar calc-always-load-extensions nil) + +;; If non-NIL, display line numbers in Calculator stack. +;;(defvar calc-line-numbering t) + +;; If non-NIL, break long values across multiple lines in Calculator stack. +;;(defvar calc-line-breaking t) + +;; If NIL, stack display is left-justified. +;; If 'right, stack display is right-justified. +;; If 'center, stack display is centered." +;;(defvar calc-display-just nil) + +;; Horizontal origin of displayed stack entries. +;; In left-justified mode, this is effectively indentation. (Default 0). +;; In right-justified mode, this is effectively window width. +;; In centered mode, center of stack entry is placed here. +;;(defvar calc-display-origin nil) + +;; Radix for entry and display of numbers in calc-mode, 2-36. +;;(defvar calc-number-radix 10) + +;; If non-NIL, leading zeros are provided to pad integers to calc-word-size. +;;(defvar calc-leading-zeros nil) + +;; If non-NIL, group digits in large displayed integers by inserting spaces. +;; If an integer, group that many digits at a time. +;; If 't', use 4 for binary and hex, 3 otherwise. +;;(defvar calc-group-digits nil) + +;; The character (in the form of a string) to be used for grouping digits. +;; This is used only when calc-group-digits mode is on. +;;(defvar calc-group-char ",") + +;; The character (in the form of a string) to be used as a decimal point. +;;(defvar calc-point-char ".") + +;; Format of displayed fractions; a string of one or two of ":" or "/". +;;(defvar calc-frac-format '(":" nil)) + +;; If non-NIL, prefer fractional over floating-point results. +;;(defvar calc-prefer-frac nil) + +;; Format of displayed hours-minutes-seconds angles, a format string. +;; String must contain three %s marks for hours, minutes, seconds respectively. +;;(defvar calc-hms-format "%s@ %s' %s\"") + +;; Format of displayed date forms. +;;(defvar calc-date-format '((H ":" mm ":" SS pp " ") Www " " Mmm " " D ", " YYYY)) + +;; Format to use for display of floating-point numbers in calc-mode. +;; Must be a list of one of the following forms: +;; (float 0) Floating point format, display full precision. +;; (float N) N > 0: Floating point format, at most N significant figures. +;; (float -N) -N < 0: Floating point format, calc-internal-prec - N figs. +;; (fix N) N >= 0: Fixed point format, N places after decimal point. +;; (sci 0) Scientific notation, full precision. +;; (sci N) N > 0: Scientific notation, N significant figures. +;; (sci -N) -N < 0: Scientific notation, calc-internal-prec - N figs. +;; (eng 0) Engineering notation, full precision. +;; (eng N) N > 0: Engineering notation, N significant figures. +;; (eng -N) -N < 0: Engineering notation, calc-internal-prec - N figs. +;;(defvar calc-float-format '(float 0)) + +;; Format to use when full precision must be displayed. +;;(defvar calc-full-float-format '(float 0)) + +;; Format to use for display of complex numbers in calc-mode. Must be one of: +;; nil Use (x, y) form. +;; i Use x + yi form. +;; j Use x + yj form. +;;(defvar calc-complex-format nil) + +;; Preferred form, either 'cplx or 'polar, for complex numbers. +;;(defvar calc-complex-mode 'cplx) + +;; If NIL, 1 / 0 is left unsimplified. +;; If 0, 1 / 0 is changed to inf (zeros are considered positive). +;; Otherwise, 1 / 0 is changed to uinf (undirected infinity). +;;(defvar calc-infinite-mode nil) + +;; If non-NIL, display vectors of byte-sized integers as strings. +;;(defvar calc-display-strings nil) + +;; If NIL, vector elements are left-justified. +;; If 'right, vector elements are right-justified. +;; If 'center, vector elements are centered." +;;(defvar calc-matrix-just 'center) + +;; If non-NIL, display vectors one element per line. +;;(defvar calc-break-vectors nil) + +;; If non-NIL, display long vectors in full. If NIL, use abbreviated form. +;;(defvar calc-full-vectors t) + +;; If non-NIL, display long vectors in full in the trail. +;;(defvar calc-full-trail-vectors t) + +;; If non-NIL, separate elements of displayed vectors with this string. +;;(defvar calc-vector-commas ",") + +;; If non-NIL, surround displayed vectors with these characters. +;;(defvar calc-vector-brackets "[]") + +;; A list of code-letter symbols that control "big" matrix display. +;; If 'R is present, display inner brackets for matrices. +;; If 'O is present, display outer brackets for matrices (above/below). +;; If 'C is present, display outer brackets for matrices (centered). +;;(defvar calc-matrix-brackets '(R O)) + +;; Language or format for entry and display of stack values. Must be one of: +;; nil Use standard Calc notation. +;; flat Use standard Calc notation, one-line format. +;; big Display formulas in 2-d notation (enter w/std notation). +;; unform Use unformatted display: add(a, mul(b,c)). +;; c Use C language notation. +;; pascal Use Pascal language notation. +;; fortran Use Fortran language notation. +;; tex Use TeX notation. +;; eqn Use eqn notation. +;; math Use Mathematica(tm) notation. +;; maple Use Maple notation. +;;(defvar calc-language nil) + +;; Numeric prefix argument for the command that set calc-language. +;;(defvar calc-language-option nil) + +;; Open-parenthesis string for function call notation. +;;(defvar calc-function-open "(") + +;; Close-parenthesis string for function call notation. +;;(defvar calc-function-close ")") + +;; Function through which to pass strings after formatting. +;;(defvar calc-language-output-filter nil) + +;; Function through which to pass strings before parsing. +;;(defvar calc-language-input-filter nil) + +;; Formatting function used for non-decimal numbers. +;;(defvar calc-radix-formatter nil) + +;; Label to display at left of formula. +;;(defvar calc-left-label "") + +;; Label to display at right of formula. +;;(defvar calc-right-label "") + +;; Minimum number of bits per word, if any, for binary operations in calc-mode. +;;(defvar calc-word-size 32) + +;; Most recently used value of M in a modulo form. +;;(defvar calc-previous-modulo nil) + +;; Type of simplification applied to results. +;; If 'none, results are not simplified when pushed on the stack. +;; If 'num, functions are simplified only when args are constant. +;; If NIL, only fast simplifications are applied. +;; If 'binary, math-clip is applied if appropriate. +;; If 'alg, math-simplify is applied. +;; If 'ext, math-simplify-extended is applied. +;; If 'units, math-simplify-units is applied. +;;(defvar calc-simplify-mode nil) + +;; If non-NIL, recompute evalto's automatically when necessary. +;;(defvar calc-auto-recompute t) + +;; If non-NIL, display shows unformatted Lisp exprs. (For debugging) +;;(defvar calc-display-raw nil) + +;; Number of digits of internal precision for calc-mode calculations. +;;(defvar calc-internal-prec 12) + +;; If non-NIL, next operation is Inverse. +;;(defvar calc-inverse-flag nil) + +;; If non-NIL, next operation is Hyperbolic. +;;(defvar calc-hyperbolic-flag nil) + +;; If non-NIL, next operation should not remove its arguments from stack. +;;(defvar calc-keep-args-flag nil) + +;; If deg, angles are in degrees; if rad, angles are in radians. +;; If hms, angles are in degrees-minutes-seconds. +;;(defvar calc-angle-mode 'deg) + +;; If non-NIL, numeric entry accepts whole algebraic expressions. +;; If NIL, algebraic expressions must be preceded by "'". +;;(defvar calc-algebraic-mode nil) + +;; Like calc-algebraic-mode except only affects ( and [ keys. +;;(defvar calc-incomplete-algebraic-mode nil) + +;; If non-NIL, inexact numeric computations like sqrt(2) are postponed. +;; If NIL, computations on numbers always yield numbers where possible. +;;(defvar calc-symbolic-mode nil) + +;; If 'matrix, variables are assumed to be matrix-valued. +;; If a number, variables are assumed to be NxN matrices. +;; If 'scalar, variables are assumed to be scalar-valued. +;; If NIL, symbolic math routines make no assumptions about variables. +;;(defvar calc-matrix-mode nil) + +;; If non-NIL, shifted letter keys are prefix keys rather than normal meanings. +;;(defvar calc-shift-prefix nil) + +;; Initial height of Calculator window. +;;(defvar calc-window-height 7) + +;; If non-NIL, M-x calc creates a window to display Calculator trail. +;;(defvar calc-display-trail t) + +;; If non-NIL, selected sub-formulas are shown by obscuring rest of formula. +;; If NIL, selected sub-formulas are highlighted by obscuring the sub-formulas. +;;(defvar calc-show-selections t) + +;; If non-NIL, commands operate only on selected portions of formulas. +;; If NIL, selections displayed but ignored. +;;(defvar calc-use-selections t) + +;; If non-NIL, selection hides deep structure of associative formulas. +;;(defvar calc-assoc-selections t) + +;; If non-NIL, display "Working..." for potentially slow Calculator commands. +;;(defvar calc-display-working-message 'lots) + +;; If non-NIL, automatically execute a "why" command to explain odd results. +;;(defvar calc-auto-why nil) + +;; If non-NIL, display timing information on each slow command. +;;(defvar calc-timing nil) + +;; Floating-point numbers with this positive exponent or higher above the +;; current precision are displayed in scientific notation in calc-mode. +(defvar calc-display-sci-high 0) + +;; Floating-point numbers with this negative exponent or lower are displayed +;; scientific notation in calc-mode. +(defvar calc-display-sci-low -3) + + +;; List of used-defined strings to append to Calculator mode line. +(defvar calc-other-modes nil) + +;; List of strings for Y prefix help. +(defvar calc-Y-help-msgs nil) + +;; T if calc-settings-file has been loaded yet. +(defvar calc-loaded-settings-file nil) + + + +(defconst calc-mode-var-list '((calc-always-load-extensions nil) + (calc-mode-save-mode local) + (calc-line-numbering t) + (calc-line-breaking t) + (calc-display-just nil) + (calc-display-origin nil) + (calc-left-label "") + (calc-right-label "") + (calc-number-radix 10) + (calc-leading-zeros nil) + (calc-group-digits nil) + (calc-group-char ",") + (calc-point-char ".") + (calc-frac-format (":" nil)) + (calc-prefer-frac nil) + (calc-hms-format "%s@ %s' %s\"") + (calc-date-format ((H ":" mm C SS pp " ") + Www " " Mmm " " D ", " YYYY)) + (calc-standard-date-formats + ("N" + "<H:mm:SSpp >Www Mmm D, YYYY" + "D Mmm YYYY<, h:mm:SS>" + "Www Mmm BD< hh:mm:ss> YYYY" + "M/D/Y< H:mm:SSpp>" + "D.M.Y< h:mm:SS>" + "M-D-Y< H:mm:SSpp>" + "D-M-Y< h:mm:SS>" + "j<, h:mm:SS>" + "YYddd< hh:mm:ss>")) + (calc-float-format (float 0)) + (calc-full-float-format (float 0)) + (calc-complex-format nil) + (calc-matrix-just center) + (calc-full-vectors t) + (calc-full-trail-vectors t) + (calc-break-vectors nil) + (calc-vector-commas ",") + (calc-vector-brackets "[]") + (calc-matrix-brackets (R O)) + (calc-complex-mode cplx) + (calc-infinite-mode nil) + (calc-display-strings nil) + (calc-simplify-mode nil) + (calc-auto-recompute t) + (calc-word-size 32) + (calc-previous-modulo nil) + (calc-display-raw nil) + (calc-internal-prec 12) + (calc-angle-mode deg) + (calc-algebraic-mode nil) + (calc-incomplete-algebraic-mode nil) + (calc-symbolic-mode nil) + (calc-matrix-mode nil) + (calc-autorange-units nil) + (calc-shift-prefix nil) + (calc-window-height 7) + (calc-was-keypad-mode nil) + (calc-full-mode nil) + (calc-language nil) + (calc-language-option nil) + (calc-user-parse-tables nil) + (calc-show-selections t) + (calc-use-selections t) + (calc-assoc-selections t) + (calc-display-trail t) + (calc-display-working-message lots) + (calc-auto-why 'maybe) + (calc-timing nil) + (calc-gnuplot-default-device "default") + (calc-gnuplot-default-output "STDOUT") + (calc-gnuplot-print-device "postscript") + (calc-gnuplot-print-output "auto") + (calc-gnuplot-geometry nil) + (calc-graph-default-resolution 15) + (calc-graph-default-resolution-3d 5) + (calc-invocation-macro nil))) + +(defconst calc-local-var-list '(calc-stack + calc-stack-top + calc-undo-list + calc-redo-list + calc-always-load-extensions + calc-mode-save-mode + calc-display-raw + calc-line-numbering + calc-line-breaking + calc-display-just + calc-display-origin + calc-left-label + calc-right-label + calc-auto-why + calc-algebraic-mode + calc-incomplete-algebraic-mode + calc-symbolic-mode + calc-matrix-mode + calc-inverse-flag + calc-hyperbolic-flag + calc-keep-args-flag + calc-angle-mode + calc-number-radix + calc-leading-zeros + calc-group-digits + calc-group-char + calc-point-char + calc-frac-format + calc-prefer-frac + calc-hms-format + calc-date-format + calc-standard-date-formats + calc-float-format + calc-full-float-format + calc-complex-format + calc-matrix-just + calc-full-vectors + calc-full-trail-vectors + calc-break-vectors + calc-vector-commas + calc-vector-brackets + calc-matrix-brackets + calc-complex-mode + calc-infinite-mode + calc-display-strings + calc-simplify-mode + calc-auto-recompute + calc-autorange-units + calc-show-plain + calc-show-selections + calc-use-selections + calc-assoc-selections + calc-word-size + calc-internal-prec)) + + +(defun calc-init-base () + + ;; Verify that Calc is running on the right kind of system. + (setq calc-emacs-type-epoch (and (fboundp 'epoch::version) epoch::version) + calc-emacs-type-19 (not (or calc-emacs-type-epoch + (string-lessp emacs-version "19"))) + calc-emacs-type-lucid (not (not (string-match "Lucid" emacs-version))) + calc-emacs-type-gnu19 (and calc-emacs-type-19 + (not calc-emacs-type-lucid))) + + ;; Set up the standard keystroke (M-#) to run the Calculator, if that key + ;; has not yet been bound to anything. For best results, the user should + ;; do this before Calc is even loaded, so that M-# can auto-load Calc. + (or (global-key-binding "\e#") + (global-set-key "\e#" 'calc-dispatch)) + + ;; Set up the autoloading linkage. + (let ((name (and (fboundp 'calc-dispatch) + (eq (car-safe (symbol-function 'calc-dispatch)) 'autoload) + (nth 1 (symbol-function 'calc-dispatch)))) + (p load-path)) + + ;; If Calc files exist on the load-path, we're all set. + (while (and p (not (file-exists-p + (expand-file-name "calc-misc.elc" (car p))))) + (setq p (cdr p))) + (or p + + ;; If Calc is autoloaded using a path name, look there for Calc files. + ;; This works for both relative ("calc/calc.elc") and absolute paths. + (and name (file-name-directory name) + (let ((p2 load-path) + (name2 (concat (file-name-directory name) + "calc-misc.elc"))) + (while (and p2 (not (file-exists-p + (expand-file-name name2 (car p2))))) + (setq p2 (cdr p2))) + (if p2 + (setq load-path (nconc load-path + (list + (directory-file-name + (file-name-directory + (expand-file-name + name (car p2)))))))))) + + ;; If calc-autoload-directory is given, use that (and hope it works!). + (and calc-autoload-directory + (not (equal calc-autoload-directory "")) + (setq load-path (nconc load-path + (list (directory-file-name + calc-autoload-directory))))))) + + ;; The following modes use specially-formatted data. + (put 'calc-mode 'mode-class 'special) + (put 'calc-trail-mode 'mode-class 'special) + + ;; Define "inexact-result" as an e-lisp error symbol. + (put 'inexact-result 'error-conditions '(error inexact-result calc-error)) + (put 'inexact-result 'error-message "Calc internal error (inexact-result)") + + ;; Define "math-overflow" and "math-underflow" as e-lisp error symbols. + (put 'math-overflow 'error-conditions '(error math-overflow calc-error)) + (put 'math-overflow 'error-message "Floating-point overflow occurred") + (put 'math-underflow 'error-conditions '(error math-underflow calc-error)) + (put 'math-underflow 'error-message "Floating-point underflow occurred") + + (setq calc-version "2.02f" + calc-version-date "Sun Dec 15 1996" + calc-trail-pointer nil ; "Current" entry in trail buffer. + calc-trail-overlay nil ; Value of overlay-arrow-string. + calc-was-split nil ; Had multiple windows before Calc. + calc-undo-list nil ; List of previous operations for undo. + calc-redo-list nil ; List of recent undo operations. + calc-main-buffer nil ; Pointer to Calculator buffer. + calc-trail-buffer nil ; Pointer to Calc Trail buffer. + calc-why nil ; Explanations of most recent errors. + calc-next-why nil + calc-inverse-flag nil + calc-hyperbolic-flag nil + calc-keep-args-flag nil + calc-function-open "(" + calc-function-close ")" + calc-language-output-filter nil + calc-language-input-filter nil + calc-radix-formatter nil + calc-last-kill nil ; Last number killed in calc-mode. + calc-previous-alg-entry nil ; Previous algebraic entry. + calc-dollar-values nil ; Values to be used for '$'. + calc-dollar-used nil ; Highest order of '$' that occurred. + calc-hashes-used nil ; Highest order of '#' that occurred. + calc-quick-prev-results nil ; Previous results from Quick Calc. + calc-said-hello nil ; Has welcome message been said yet? + calc-executing-macro nil ; Kbd macro executing from "K" key. + calc-any-selections nil ; Nil means no selections present. + calc-help-phase 0 ; Count of consecutive "?" keystrokes. + calc-full-help-flag nil ; Executing calc-full-help? + calc-refresh-count 0 ; Count of calc-refresh calls. + calc-display-dirty nil + calc-prepared-composition nil + calc-selection-cache-default-entry nil + calc-embedded-info nil + calc-embedded-active nil + calc-standalone-flag nil + var-EvalRules nil + math-eval-rules-cache-tag t + math-radix-explicit-format t + math-expr-function-mapping nil + math-expr-variable-mapping nil + math-read-expr-quotes nil + math-working-step nil + math-working-step-2 nil + var-i '(special-const (math-imaginary 1)) + var-pi '(special-const (math-pi)) + var-e '(special-const (math-e)) + var-phi '(special-const (math-phi)) + var-gamma '(special-const (math-gamma-const)) + var-Modes '(special-const (math-get-modes-vec))) + + (mapcar (function (lambda (v) (or (boundp (car v)) (set (car v) (nth 1 v))))) + calc-mode-var-list) + (mapcar (function (lambda (v) (or (boundp v) (set v nil)))) + calc-local-var-list) + + (if (boundp 'calc-mode-map) + nil + (setq calc-mode-map (make-keymap)) + (suppress-keymap calc-mode-map t) + (define-key calc-mode-map "+" 'calc-plus) + (define-key calc-mode-map "-" 'calc-minus) + (define-key calc-mode-map "*" 'calc-times) + (define-key calc-mode-map "/" 'calc-divide) + (define-key calc-mode-map "%" 'calc-mod) + (define-key calc-mode-map "&" 'calc-inv) + (define-key calc-mode-map "^" 'calc-power) + (define-key calc-mode-map "\M-%" 'calc-percent) + (define-key calc-mode-map "e" 'calcDigit-start) + (define-key calc-mode-map "i" 'calc-info) + (define-key calc-mode-map "n" 'calc-change-sign) + (define-key calc-mode-map "q" 'calc-quit) + (define-key calc-mode-map "Y" 'nil) + (define-key calc-mode-map "Y?" 'calc-shift-Y-prefix-help) + (define-key calc-mode-map "?" 'calc-help) + (define-key calc-mode-map " " 'calc-enter) + (define-key calc-mode-map "'" 'calc-algebraic-entry) + (define-key calc-mode-map "$" 'calc-auto-algebraic-entry) + (define-key calc-mode-map "\"" 'calc-auto-algebraic-entry) + (define-key calc-mode-map "\t" 'calc-roll-down) + (define-key calc-mode-map "\M-\t" 'calc-roll-up) + (define-key calc-mode-map "\C-m" 'calc-enter) + (define-key calc-mode-map "\M-\C-m" 'calc-last-args-stub) + (define-key calc-mode-map "\C-j" 'calc-over) + + (mapcar (function + (lambda (x) + (define-key calc-mode-map (char-to-string x) 'undefined))) + "lOW") + (mapcar (function + (lambda (x) + (define-key calc-mode-map (char-to-string x) + 'calc-missing-key))) + (concat "ABCDEFGHIJKLMNPQRSTUVXZabcdfghjkmoprstuvwxyz" + ":\\|!()[]<>{},;=~`\C-k\M-k\C-w\M-w\C-y\C-_")) + (mapcar (function + (lambda (x) + (define-key calc-mode-map (char-to-string x) 'calcDigit-start))) + "_0123456789.#@") + + (setq calc-digit-map (make-keymap)) + (if calc-emacs-type-lucid + (map-keymap (function + (lambda (keys bind) + (define-key calc-digit-map keys + (if (eq bind 'undefined) + 'undefined 'calcDigit-nondigit)))) + calc-mode-map) + (let ((cmap (if calc-emacs-type-19 (nth 1 calc-mode-map) calc-mode-map)) + (dmap (if calc-emacs-type-19 (nth 1 calc-digit-map) + calc-digit-map)) + (i 0)) + (while (< i 128) + (aset dmap i + (if (eq (aref cmap i) 'undefined) + 'undefined 'calcDigit-nondigit)) + (setq i (1+ i))))) + (mapcar (function + (lambda (x) + (define-key calc-digit-map (char-to-string x) + 'calcDigit-key))) + "_0123456789.e+-:n#@oh'\"mspM") + (mapcar (function + (lambda (x) + (define-key calc-digit-map (char-to-string x) + 'calcDigit-letter))) + "abcdfgijklqrtuvwxyzABCDEFGHIJKLNOPQRSTUVWXYZ") + (define-key calc-digit-map "'" 'calcDigit-algebraic) + (define-key calc-digit-map "`" 'calcDigit-edit) + (define-key calc-digit-map "\C-g" 'abort-recursive-edit) + + (mapcar (function + (lambda (x) + (condition-case err + (progn + (define-key calc-digit-map x 'calcDigit-backspace) + (define-key calc-mode-map x 'calc-pop) + (define-key calc-mode-map + (if (vectorp x) + (if calc-emacs-type-lucid + (if (= (length x) 1) + (vector (if (consp (aref x 0)) + (cons 'meta (aref x 0)) + (list 'meta (aref x 0)))) + "\e\C-d") + (vconcat "\e" x)) + (concat "\e" x)) + 'calc-pop-above)) + (error nil)))) + (if calc-scan-for-dels + (append (where-is-internal 'delete-backward-char global-map) + (where-is-internal 'backward-delete-char global-map) + '("\C-d")) + '("\177" "\C-d"))) + + (setq calc-dispatch-map (make-keymap)) + (mapcar (function + (lambda (x) + (define-key calc-dispatch-map (char-to-string (car x)) (cdr x)) + (if (string-match "abcdefhijklnopqrstuwxyz" + (char-to-string (car x))) + (define-key calc-dispatch-map + (char-to-string (- (car x) ?a -1)) (cdr x))) + (define-key calc-dispatch-map (format "\e%c" (car x)) (cdr x)))) + '( ( ?a . calc-embedded-activate ) + ( ?b . calc-big-or-small ) + ( ?c . calc ) + ( ?d . calc-embedded-duplicate ) + ( ?e . calc-embedded ) + ( ?f . calc-embedded-new-formula ) + ( ?g . calc-grab-region ) + ( ?h . calc-dispatch-help ) + ( ?i . calc-info ) + ( ?j . calc-embedded-select ) + ( ?k . calc-keypad ) + ( ?l . calc-load-everything ) + ( ?m . read-kbd-macro ) + ( ?n . calc-embedded-next ) + ( ?o . calc-other-window ) + ( ?p . calc-embedded-previous ) + ( ?q . quick-calc ) + ( ?r . calc-grab-rectangle ) + ( ?s . calc-info-summary ) + ( ?t . calc-tutorial ) + ( ?u . calc-embedded-update-formula ) + ( ?w . calc-embedded-word ) + ( ?x . calc-quit ) + ( ?y . calc-copy-to-buffer ) + ( ?z . calc-user-invocation ) + ( ?= . calc-embedded-update-formula ) + ( ?\' . calc-embedded-new-formula ) + ( ?\` . calc-embedded-edit ) + ( ?: . calc-grab-sum-down ) + ( ?_ . calc-grab-sum-across ) + ( ?0 . calc-reset ) + ( ?# . calc-same-interface ) + ( ?? . calc-dispatch-help ) )) + ) + + (autoload 'calc-extensions "calc-ext") + (autoload 'calc-need-macros "calc-macs") + +;;;; (Autoloads here) + (mapcar (function (lambda (x) + (mapcar (function (lambda (func) + (autoload func (car x)))) (cdr x)))) + '( + + ("calc-aent" calc-Need-calc-aent calc-alg-digit-entry calc-alg-entry +calc-check-user-syntax calc-do-alg-entry calc-do-calc-eval +calc-do-quick-calc calc-match-user-syntax math-build-parse-table +math-find-user-tokens math-read-expr-list math-read-exprs math-read-if +math-read-token math-remove-dashes) + + ("calc-misc" calc-Need-calc-misc calc-delete-windows-keep +calc-do-handle-whys calc-do-refresh calc-num-prefix-name +calc-record-list calc-record-why calc-report-bug calc-roll-down-stack +calc-roll-up-stack calc-temp-minibuffer-message calcFunc-floor +calcFunc-inv calcFunc-trunc math-concat math-constp math-div2 +math-div2-bignum math-do-working math-evenp math-fixnatnump +math-fixnump math-floor math-imod math-ipow math-looks-negp math-mod +math-negp math-posp math-pow math-read-radix-digit math-reject-arg +math-trunc math-zerop) + +)) + + (mapcar (function (lambda (x) + (mapcar (function (lambda (cmd) + (autoload cmd (car x) nil t))) (cdr x)))) + '( + + ("calc-aent" calc-algebraic-entry calc-auto-algebraic-entry +calcDigit-algebraic calcDigit-edit) + + ("calc-misc" another-calc calc-big-or-small calc-dispatch-help +calc-help calc-info calc-info-summary calc-inv calc-last-args-stub +calc-missing-key calc-mod calc-other-window calc-over calc-percent +calc-pop-above calc-power calc-roll-down calc-roll-up +calc-shift-Y-prefix-help calc-tutorial calcDigit-letter +report-calc-bug) + +)) + +) + +(calc-init-base) + + +;;;###autoload (global-set-key "\e#" 'calc-dispatch) + +;;;###autoload +(defun calc-dispatch (&optional arg) + "Invoke the GNU Emacs Calculator. See calc-dispatch-help for details." + (interactive "P") + (sit-for echo-keystrokes) + (condition-case err ; look for other keys bound to calc-dispatch + (let ((keys (this-command-keys))) + (or (not (stringp keys)) + (string-match "\\`\C-u\\|\\`\e[-0-9#]\\|`[\M--\M-0-\M-9]" keys) + (eq (lookup-key calc-dispatch-map keys) 'calc-same-interface) + (progn + (and (string-match "\\`[\C-@-\C-_]" keys) + (symbolp + (lookup-key calc-dispatch-map (substring keys 0 1))) + (define-key calc-dispatch-map (substring keys 0 1) nil)) + (define-key calc-dispatch-map keys 'calc-same-interface)))) + (error nil)) + (calc-do-dispatch arg) +) + +(defun calc-do-dispatch (arg) + (let ((key (calc-read-key-sequence + (if calc-dispatch-help + "Calc options: Calc, Keypad, Quick, Embed; eXit; Info, Tutorial; Grab; ?=more" + (format "%s (Type ? for a list of Calc options)" + (key-description (this-command-keys)))) + calc-dispatch-map))) + (setq key (lookup-key calc-dispatch-map key)) + (message "") + (if key + (progn + (or (commandp key) (calc-extensions)) + (call-interactively key)) + (beep))) +) +(setq calc-dispatch-help nil) + +(defun calc-read-key-sequence (prompt map) + (let ((prompt2 (format "%s " (key-description (this-command-keys)))) + (glob (current-global-map)) + (loc (current-local-map))) + (or (input-pending-p) (message prompt)) + (let ((key (calc-read-key t))) + (calc-unread-command (cdr key)) + (unwind-protect + (progn + (use-global-map map) + (use-local-map nil) + (read-key-sequence + (if (commandp (key-binding (if calc-emacs-type-19 + (vector (cdr key)) + (char-to-string (cdr key))))) + "" prompt2))) + (use-global-map glob) + (use-local-map loc)))) +) + + + +(defun calc-mode () + "Calculator major mode. + +This is an RPN calculator featuring arbitrary-precision integer, rational, +floating-point, complex, matrix, and symbolic arithmetic. + +RPN calculation: 2 RET 3 + produces 5. +Algebraic style: ' 2+3 RET produces 5. + +Basic operators are +, -, *, /, ^, & (reciprocal), % (modulo), n (change-sign). + +Press ? repeatedly for more complete help. Press `h i' to read the +Calc manual on-line, `h s' to read the summary, or `h t' for the tutorial. + +Notations: 3.14e6 3.14 * 10^6 + _23 negative number -23 (or type `23 n') + 17:3 the fraction 17/3 + 5:2:3 the fraction 5 and 2/3 + 16#12C the integer 12C base 16 = 300 base 10 + 8#177:100 the fraction 177:100 base 8 = 127:64 base 10 + (2, 4) complex number 2 + 4i + (2; 4) polar complex number (r; theta) + [1, 2, 3] vector ([[1, 2], [3, 4]] is a matrix) + [1 .. 4) semi-open interval, 1 <= x < 4 + 2 +/- 3 (p key) number with mean 2, standard deviation 3 + 2 mod 3 (M key) number 2 computed modulo 3 + <1 jan 91> Date form (enter using ' key) + + +\\{calc-mode-map} +" + (interactive) + (mapcar (function + (lambda (v) (set-default v (symbol-value v)))) calc-local-var-list) + (kill-all-local-variables) + (use-local-map (if (eq calc-algebraic-mode 'total) + (progn (calc-extensions) calc-alg-map) calc-mode-map)) + (mapcar (function (lambda (v) (make-local-variable v))) calc-local-var-list) + (make-local-variable 'overlay-arrow-position) + (make-local-variable 'overlay-arrow-string) + (setq truncate-lines t) + (setq buffer-read-only t) + (setq major-mode 'calc-mode) + (setq mode-name "Calculator") + (setq calc-stack-top (length (or (memq (assq 'top-of-stack calc-stack) + calc-stack) + (setq calc-stack (list (list 'top-of-stack + 1 nil)))))) + (setq calc-stack-top (- (length calc-stack) calc-stack-top -1)) + (or calc-loaded-settings-file + (string-match "\\.emacs" calc-settings-file) + (progn + (setq calc-loaded-settings-file t) + (load calc-settings-file t))) ; t = missing-ok + (if (and (eq window-system 'x) (boundp 'mouse-map)) + (substitute-key-definition 'x-paste-text 'calc-x-paste-text + mouse-map)) + (let ((p command-line-args)) + (while p + (and (equal (car p) "-f") + (string-match "calc" (nth 1 p)) + (string-match "full" (nth 1 p)) + (setq calc-standalone-flag t)) + (setq p (cdr p)))) + (run-hooks 'calc-mode-hook) + (calc-refresh t) + (calc-set-mode-line) + ;; The calc-defs variable is a relic. Use calc-define properties instead. + (if (and (boundp 'calc-defs) + calc-defs) + (progn + (message "Evaluating calc-defs...") + (calc-need-macros) + (eval (cons 'progn calc-defs)) + (setq calc-defs nil) + (calc-set-mode-line))) + (calc-check-defines) +) + +(defun calc-check-defines () + (if (symbol-plist 'calc-define) + (let ((plist (copy-sequence (symbol-plist 'calc-define)))) + (while (and plist (null (nth 1 plist))) + (setq plist (cdr (cdr plist)))) + (if plist + (save-excursion + (calc-extensions) + (calc-need-macros) + (set-buffer "*Calculator*") + (while plist + (put 'calc-define (car plist) nil) + (eval (nth 1 plist)) + (setq plist (cdr (cdr plist)))) + ;; See if this has added any more calc-define properties. + (calc-check-defines)) + (setplist 'calc-define nil)))) +) +(setq calc-check-defines 'calc-check-defines) ; suitable for run-hooks + +(defun calc-trail-mode (&optional buf) + "Calc Trail mode. +This mode is used by the *Calc Trail* buffer, which records all results +obtained by the GNU Emacs Calculator. + +Calculator commands beginning with the `t' key are used to manipulate +the Trail. + +This buffer uses the same key map as the *Calculator* buffer; calculator +commands given here will actually operate on the *Calculator* stack." + (interactive) + (fundamental-mode) + (use-local-map calc-mode-map) + (setq major-mode 'calc-trail-mode) + (setq mode-name "Calc Trail") + (setq truncate-lines t) + (setq buffer-read-only t) + (make-local-variable 'overlay-arrow-position) + (make-local-variable 'overlay-arrow-string) + (if buf + (progn + (make-local-variable 'calc-main-buffer) + (setq calc-main-buffer buf))) + (if (= (buffer-size) 0) + (let ((buffer-read-only nil)) + (insert "Emacs Calculator v" calc-version " by Dave Gillespie, " + "installed " calc-installed-date "\n"))) + (run-hooks 'calc-trail-mode-hook) +) + +(defun calc-create-buffer () + (set-buffer (get-buffer-create "*Calculator*")) + (or (eq major-mode 'calc-mode) + (calc-mode)) + (setq max-lisp-eval-depth (max max-lisp-eval-depth 1000)) + (if calc-always-load-extensions + (calc-extensions)) + (if calc-language + (progn + (calc-extensions) + (calc-set-language calc-language calc-language-option t))) +) + +;;;###autoload +(defun calc (&optional arg full-display interactive) + "The Emacs Calculator. Full documentation is listed under \"calc-mode\"." + (interactive "P") + (if arg + (or (eq arg 0) + (progn + (calc-extensions) + (if (= (prefix-numeric-value arg) -1) + (calc-grab-region (region-beginning) (region-end) nil) + (if (= (prefix-numeric-value arg) -2) + (calc-keypad))))) + (if (get-buffer-window "*Calc Keypad*") + (progn + (calc-keypad) + (set-buffer (window-buffer (selected-window))))) + (if (eq major-mode 'calc-mode) + (calc-quit) + (let ((oldbuf (current-buffer))) + (calc-create-buffer) + (setq calc-was-keypad-mode nil) + (if (or (eq full-display t) + (and (null full-display) calc-full-mode)) + (switch-to-buffer (current-buffer) t) + (if (get-buffer-window (current-buffer)) + (select-window (get-buffer-window (current-buffer))) + (setq calc-was-split nil) + (if (and (boundp 'calc-window-hook) calc-window-hook) + (run-hooks 'calc-window-hook) + (let ((w (get-largest-window))) + (if (and pop-up-windows + (> (window-height w) + (+ window-min-height calc-window-height 2))) + (progn + (or (one-window-p) + (setq calc-was-split (list w (window-height w) + (selected-window)))) + (setq w (split-window w + (- (window-height w) + calc-window-height 2) + nil)) + (set-window-buffer w (current-buffer)) + (select-window w)) + (pop-to-buffer (current-buffer))))))) + (save-excursion + (set-buffer (calc-trail-buffer)) + (and calc-display-trail + (= (window-width) (screen-width)) + (calc-trail-display 1 t))) + (message "Welcome to the GNU Emacs Calculator! Press `?' or `h' for help, `q' to quit.") + (run-hooks 'calc-start-hook) + (and (windowp full-display) + (window-point full-display) + (select-window full-display)) + (calc-check-defines) + (and calc-said-hello + (or (interactive-p) interactive) + (progn + (sit-for 2) + (message ""))) + (setq calc-said-hello t)))) +) + +;;;###autoload +(defun full-calc () + "Invoke the Calculator and give it a full-sized window." + (interactive) + (calc nil t (interactive-p)) +) + +(defun calc-same-interface (arg) + "Invoke the Calculator using the most recent interface (calc or calc-keypad)." + (interactive "P") + (if (and (equal (buffer-name) "*Gnuplot Trail*") + (> (recursion-depth) 0)) + (exit-recursive-edit) + (if (eq major-mode 'calc-edit-mode) + (calc-edit-finish arg) + (if (eq major-mode 'MacEdit-mode) + (MacEdit-finish-edit) + (if calc-was-keypad-mode + (calc-keypad) + (calc arg calc-full-mode t))))) +) + + +(defun calc-quit (&optional non-fatal) + (interactive) + (and calc-standalone-flag (not non-fatal) + (save-buffers-kill-emacs nil)) + (if (and (equal (buffer-name) "*Gnuplot Trail*") + (> (recursion-depth) 0)) + (exit-recursive-edit)) + (if (eq major-mode 'calc-edit-mode) + (calc-edit-cancel) + (if (eq major-mode 'MacEdit-mode) + (MacEdit-cancel-edit) + (if (and (interactive-p) + calc-embedded-info + (eq (current-buffer) (aref calc-embedded-info 0))) + (calc-embedded nil) + (or (eq major-mode 'calc-mode) + (calc-create-buffer)) + (run-hooks 'calc-end-hook) + (setq calc-undo-list nil calc-redo-list nil) + (mapcar (function (lambda (v) (set-default v (symbol-value v)))) + calc-local-var-list) + (let ((buf (current-buffer)) + (win (get-buffer-window (current-buffer))) + (kbuf (get-buffer "*Calc Keypad*"))) + (delete-windows-on (calc-trail-buffer)) + (if (and win + (< (window-height win) (1- (screen-height))) + (= (window-width win) (screen-width)) ; avoid calc-keypad + (not (get-buffer-window "*Calc Keypad*"))) + (setq calc-window-height (- (window-height win) 2))) + (if calc-was-split + (calc-delete-windows-keep buf kbuf) + (delete-windows-on buf) + (delete-windows-on kbuf)) + (bury-buffer buf) + (bury-buffer calc-trail-buffer) + (and kbuf (bury-buffer kbuf)))))) +) + +;;;###autoload +(defun quick-calc () + "Do a quick calculation in the minibuffer without invoking full Calculator." + (interactive) + (calc-do-quick-calc) +) + +;;;###autoload +(defun calc-eval (str &optional separator &rest args) + "Do a quick calculation and return the result as a string. +Return value will either be the formatted result in string form, +or a list containing a character position and an error message in string form." + (calc-do-calc-eval str separator args) +) + +;;;###autoload +(defun calc-keypad () + "Invoke the Calculator in \"visual keypad\" mode. +This is most useful in the X window system. +In this mode, click on the Calc \"buttons\" using the left mouse button. +Or, position the cursor manually and do M-x calc-keypad-press." + (interactive) + (calc-extensions) + (calc-do-keypad calc-full-mode (interactive-p)) +) + +;;;###autoload +(defun full-calc-keypad () + "Invoke the Calculator in full-screen \"visual keypad\" mode. +See calc-keypad for details." + (interactive) + (calc-extensions) + (calc-do-keypad t (interactive-p)) +) + + +;;; Note that modifications to this function may break calc-pass-errors. +(defun calc-do (do-body &optional do-slow) + (calc-check-defines) + (let* ((calc-command-flags nil) + (calc-start-time (and calc-timing (not calc-start-time) + (calc-extensions) + (current-time-string))) + (gc-cons-threshold (max gc-cons-threshold + (if calc-timing 2000000 100000)))) + (setq calc-aborted-prefix "") + (unwind-protect + (condition-case err + (save-excursion + (if calc-embedded-info + (calc-embedded-select-buffer) + (calc-select-buffer)) + (and (eq calc-algebraic-mode 'total) + (calc-extensions) + (use-local-map calc-alg-map)) + (and do-slow calc-display-working-message + (progn + (message "Working...") + (calc-set-command-flag 'clear-message))) + (funcall do-body) + (setq calc-aborted-prefix nil) + (and (memq 'renum-stack calc-command-flags) + (calc-renumber-stack)) + (and (memq 'clear-message calc-command-flags) + (message ""))) + (error + (if (and (eq (car err) 'error) + (stringp (nth 1 err)) + (string-match "max-specpdl-size\\|max-lisp-eval-depth" + (nth 1 err))) + (error "Computation got stuck or ran too long. Type `M' to increase the limit.") + (setq calc-aborted-prefix nil) + (signal (car err) (cdr err))))) + (setq calc-old-aborted-prefix calc-aborted-prefix) + (and calc-aborted-prefix + (calc-record "<Aborted>" calc-aborted-prefix)) + (and calc-start-time + (let* ((calc-internal-prec 12) + (calc-date-format nil) + (end-time (current-time-string)) + (time (if (equal calc-start-time end-time) + 0 + (math-sub + (calcFunc-unixtime (math-parse-date end-time) 0) + (calcFunc-unixtime (math-parse-date calc-start-time) + 0))))) + (if (math-lessp 1 time) + (calc-record time "(t)")))) + (or (memq 'no-align calc-command-flags) + (eq major-mode 'calc-trail-mode) + (calc-align-stack-window)) + (and (memq 'position-point calc-command-flags) + (if (eq major-mode 'calc-mode) + (progn + (goto-line calc-final-point-line) + (move-to-column calc-final-point-column)) + (save-excursion + (calc-select-buffer) + (goto-line calc-final-point-line) + (move-to-column calc-final-point-column)))) + (or (memq 'keep-flags calc-command-flags) + (save-excursion + (calc-select-buffer) + (setq calc-inverse-flag nil + calc-hyperbolic-flag nil + calc-keep-args-flag nil))) + (and (memq 'do-edit calc-command-flags) + (switch-to-buffer (get-buffer-create "*Calc Edit*"))) + (calc-set-mode-line) + (and calc-embedded-info + (calc-embedded-finish-command)))) + (identity nil) ; allow a GC after timing is done +) +(setq calc-aborted-prefix nil) +(setq calc-start-time nil) + +(defun calc-set-command-flag (f) + (if (not (memq f calc-command-flags)) + (setq calc-command-flags (cons f calc-command-flags))) +) + +(defun calc-select-buffer () + (or (eq major-mode 'calc-mode) + (if calc-main-buffer + (set-buffer calc-main-buffer) + (let ((buf (get-buffer "*Calculator*"))) + (if buf + (set-buffer buf) + (error "Calculator buffer not available"))))) +) + +(defun calc-cursor-stack-index (&optional index) + (goto-char (point-max)) + (forward-line (- (calc-substack-height (or index 1)))) +) + +(defun calc-stack-size () + (- (length calc-stack) calc-stack-top) +) + +(defun calc-substack-height (n) + (let ((sum 0) + (stack calc-stack)) + (setq n (+ n calc-stack-top)) + (while (and (> n 0) stack) + (setq sum (+ sum (nth 1 (car stack))) + n (1- n) + stack (cdr stack))) + sum) +) + +(defun calc-set-mode-line () + (save-excursion + (calc-select-buffer) + (let* ((fmt (car calc-float-format)) + (figs (nth 1 calc-float-format)) + (new-mode-string + (format "Calc%s%s: %d %s %-14s" + (if calc-embedded-info "Embed" "") + (if (and (> (length (buffer-name)) 12) + (equal (substring (buffer-name) 0 12) + "*Calculator*")) + (substring (buffer-name) 12) + "") + calc-internal-prec + (capitalize (symbol-name calc-angle-mode)) + (concat + + ;; Input-related modes + (if (eq calc-algebraic-mode 'total) "Alg* " + (if calc-algebraic-mode "Alg " + (if calc-incomplete-algebraic-mode "Alg[( " ""))) + + ;; Computational modes + (if calc-symbolic-mode "Symb " "") + (cond ((eq calc-matrix-mode 'matrix) "Matrix ") + ((integerp calc-matrix-mode) + (format "Matrix%d " calc-matrix-mode)) + ((eq calc-matrix-mode 'scalar) "Scalar ") + (t "")) + (if (eq calc-complex-mode 'polar) "Polar " "") + (if calc-prefer-frac "Frac " "") + (cond ((null calc-infinite-mode) "") + ((eq calc-infinite-mode 1) "+Inf ") + (t "Inf ")) + (cond ((eq calc-simplify-mode 'none) "NoSimp ") + ((eq calc-simplify-mode 'num) "NumSimp ") + ((eq calc-simplify-mode 'binary) + (format "BinSimp%d " calc-word-size)) + ((eq calc-simplify-mode 'alg) "AlgSimp ") + ((eq calc-simplify-mode 'ext) "ExtSimp ") + ((eq calc-simplify-mode 'units) "UnitSimp ") + (t "")) + + ;; Display modes + (cond ((= calc-number-radix 10) "") + ((= calc-number-radix 2) "Bin ") + ((= calc-number-radix 8) "Oct ") + ((= calc-number-radix 16) "Hex ") + (t (format "Radix%d " calc-number-radix))) + (if calc-leading-zeros "Zero " "") + (cond ((null calc-language) "") + ((eq calc-language 'tex) "TeX ") + (t (concat + (capitalize (symbol-name calc-language)) + " "))) + (cond ((eq fmt 'float) + (if (zerop figs) "" (format "Norm%d " figs))) + ((eq fmt 'fix) (format "Fix%d " figs)) + ((eq fmt 'sci) + (if (zerop figs) "Sci " (format "Sci%d " figs))) + ((eq fmt 'eng) + (if (zerop figs) "Eng " (format "Eng%d " figs)))) + (cond ((not calc-display-just) + (if calc-display-origin + (format "Left%d " calc-display-origin) "")) + ((eq calc-display-just 'right) + (if calc-display-origin + (format "Right%d " calc-display-origin) + "Right ")) + (t + (if calc-display-origin + (format "Center%d " calc-display-origin) + "Center "))) + (cond ((integerp calc-line-breaking) + (format "Wid%d " calc-line-breaking)) + (calc-line-breaking "") + (t "Wide ")) + + ;; Miscellaneous other modes/indicators + (if calc-assoc-selections "" "Break ") + (cond ((eq calc-mode-save-mode 'save) "Save ") + ((not calc-embedded-info) "") + ((eq calc-mode-save-mode 'local) "Local ") + ((eq calc-mode-save-mode 'edit) "LocEdit ") + ((eq calc-mode-save-mode 'perm) "LocPerm ") + ((eq calc-mode-save-mode 'global) "Global ") + (t "")) + (if calc-auto-recompute "" "Manual ") + (if (and (fboundp 'calc-gnuplot-alive) + (calc-gnuplot-alive)) "Graph " "") + (if (and calc-embedded-info + (> (calc-stack-size) 0) + (calc-top 1 'sel)) "Sel " "") + (if calc-display-dirty "Dirty " "") + (if calc-inverse-flag "Inv " "") + (if calc-hyperbolic-flag "Hyp " "") + (if calc-keep-args-flag "Keep " "") + (if (/= calc-stack-top 1) "Narrow " "") + (apply 'concat calc-other-modes))))) + (if (equal new-mode-string mode-line-buffer-identification) + nil + (setq mode-line-buffer-identification new-mode-string) + (set-buffer-modified-p (buffer-modified-p)) + (and calc-embedded-info (calc-embedded-mode-line-change))))) +) + +(defun calc-align-stack-window () + (if (eq major-mode 'calc-mode) + (progn + (let ((win (get-buffer-window (current-buffer)))) + (if win + (progn + (calc-cursor-stack-index 0) + (vertical-motion (- 2 (window-height win))) + (set-window-start win (point))))) + (calc-cursor-stack-index 0) + (if (looking-at " *\\.$") + (goto-char (1- (match-end 0))))) + (save-excursion + (calc-select-buffer) + (calc-align-stack-window))) +) + +(defun calc-check-stack (n) + (if (> n (calc-stack-size)) + (error "Too few elements on stack")) + (if (< n 0) + (error "Invalid argument")) +) + +(defun calc-push-list (vals &optional m sels) + (while vals + (if calc-executing-macro + (calc-push-list-in-macro vals m sels) + (save-excursion + (calc-select-buffer) + (let* ((val (car vals)) + (entry (list val 1 (car sels))) + (mm (+ (or m 1) calc-stack-top))) + (calc-cursor-stack-index (1- (or m 1))) + (if (> mm 1) + (setcdr (nthcdr (- mm 2) calc-stack) + (cons entry (nthcdr (1- mm) calc-stack))) + (setq calc-stack (cons entry calc-stack))) + (let ((buffer-read-only nil)) + (insert (math-format-stack-value entry) "\n")) + (calc-record-undo (list 'push mm)) + (calc-set-command-flag 'renum-stack)))) + (setq vals (cdr vals) + sels (cdr sels))) +) + +(defun calc-pop-push-list (n vals &optional m sels) + (if (and calc-any-selections (null sels)) + (calc-replace-selections n vals m) + (calc-pop-stack n m sels) + (calc-push-list vals m sels)) +) + +(defun calc-pop-push-record-list (n prefix vals &optional m sels) + (or (and (consp vals) + (or (integerp (car vals)) + (consp (car vals)))) + (and vals (setq vals (list vals) + sels (and sels (list sels))))) + (calc-check-stack (+ n (or m 1) -1)) + (if prefix + (if (cdr vals) + (calc-record-list vals prefix) + (calc-record (car vals) prefix))) + (calc-pop-push-list n vals m sels) +) + +(defun calc-enter-result (n prefix vals &optional m) + (setq calc-aborted-prefix prefix) + (if (and (consp vals) + (or (integerp (car vals)) + (consp (car vals)))) + (setq vals (mapcar 'calc-normalize vals)) + (setq vals (calc-normalize vals))) + (or (and (consp vals) + (or (integerp (car vals)) + (consp (car vals)))) + (setq vals (list vals))) + (if (equal vals '((nil))) + (setq vals nil)) + (calc-pop-push-record-list n prefix vals m) + (calc-handle-whys) +) + +(defun calc-normalize (val) + (if (memq calc-simplify-mode '(nil none num)) + (math-normalize val) + (calc-extensions) + (calc-normalize-fancy val)) +) + +(defun calc-handle-whys () + (if calc-next-why + (calc-do-handle-whys)) +) + + +(defun calc-pop-stack (&optional n m sel-ok) ; pop N objs at level M of stack. + (or n (setq n 1)) + (or m (setq m 1)) + (or calc-keep-args-flag + (let ((mm (+ m calc-stack-top))) + (if (and calc-any-selections (not sel-ok) + (calc-top-selected n m)) + (calc-sel-error)) + (if calc-executing-macro + (calc-pop-stack-in-macro n mm) + (calc-record-undo (list 'pop mm (calc-top-list n m 'full))) + (save-excursion + (calc-select-buffer) + (let ((buffer-read-only nil)) + (if (> mm 1) + (progn + (calc-cursor-stack-index (1- m)) + (let ((bot (point))) + (calc-cursor-stack-index (+ n m -1)) + (delete-region (point) bot)) + (setcdr (nthcdr (- mm 2) calc-stack) + (nthcdr (+ n mm -1) calc-stack))) + (calc-cursor-stack-index n) + (setq calc-stack (nthcdr n calc-stack)) + (delete-region (point) (point-max)))) + (calc-set-command-flag 'renum-stack))))) +) + +(defun calc-get-stack-element (x) + (cond ((eq sel-mode 'entry) + x) + ((eq sel-mode 'sel) + (nth 2 x)) + ((or (null (nth 2 x)) + (eq sel-mode 'full) + (not calc-use-selections)) + (car x)) + (sel-mode + (calc-sel-error)) + (t (nth 2 x))) +) + +;; Get the Nth element of the stack (N=1 is the top element). +(defun calc-top (&optional n sel-mode) + (or n (setq n 1)) + (calc-check-stack n) + (calc-get-stack-element (nth (+ n calc-stack-top -1) calc-stack)) +) + +(defun calc-top-n (&optional n sel-mode) ; in case precision has changed + (math-check-complete (calc-normalize (calc-top n sel-mode))) +) + +(defun calc-top-list (&optional n m sel-mode) + (or n (setq n 1)) + (or m (setq m 1)) + (calc-check-stack (+ n m -1)) + (and (> n 0) + (let ((top (copy-sequence (nthcdr (+ m calc-stack-top -1) + calc-stack)))) + (setcdr (nthcdr (1- n) top) nil) + (nreverse (mapcar 'calc-get-stack-element top)))) +) + +(defun calc-top-list-n (&optional n m sel-mode) + (mapcar 'math-check-complete + (mapcar 'calc-normalize (calc-top-list n m sel-mode))) +) + + +(defun calc-renumber-stack () + (if calc-line-numbering + (save-excursion + (calc-cursor-stack-index 0) + (let ((lnum 1) + (buffer-read-only nil) + (stack (nthcdr calc-stack-top calc-stack))) + (if (re-search-forward "^[0-9]+[:*]" nil t) + (progn + (beginning-of-line) + (while (re-search-forward "^[0-9]+[:*]" nil t) + (let ((buffer-read-only nil)) + (beginning-of-line) + (delete-char 4) + (insert " "))) + (calc-cursor-stack-index 0))) + (while (re-search-backward "^[0-9]+[:*]" nil t) + (delete-char 4) + (if (> lnum 999) + (insert (format "%03d%s" (% lnum 1000) + (if (and (nth 2 (car stack)) + calc-use-selections) "*" ":"))) + (let ((prefix (int-to-string lnum))) + (insert prefix (if (and (nth 2 (car stack)) + calc-use-selections) "*" ":") + (make-string (- 3 (length prefix)) 32)))) + (beginning-of-line) + (setq lnum (1+ lnum) + stack (cdr stack)))))) + (and calc-embedded-info (calc-embedded-stack-change)) +) + +(defun calc-refresh (&optional align) + (interactive) + (and (eq major-mode 'calc-mode) + (not calc-executing-macro) + (let* ((buffer-read-only nil) + (save-point (point)) + (save-mark (condition-case err (mark) (error nil))) + (save-aligned (looking-at "\\.$")) + (thing calc-stack)) + (setq calc-any-selections nil + calc-any-evaltos nil) + (erase-buffer) + (insert "--- Emacs Calculator Mode ---\n") + (while thing + (goto-char (point-min)) + (forward-line 1) + (insert (math-format-stack-value (car thing)) "\n") + (setq thing (cdr thing))) + (calc-renumber-stack) + (if calc-display-dirty + (calc-wrapper (setq calc-display-dirty nil))) + (and calc-any-evaltos calc-auto-recompute + (calc-wrapper (calc-refresh-evaltos))) + (if (or align save-aligned) + (calc-align-stack-window) + (goto-char save-point)) + (if save-mark (set-mark save-mark)))) + (and calc-embedded-info (not (eq major-mode 'calc-mode)) + (save-excursion + (set-buffer (aref calc-embedded-info 1)) + (calc-refresh align))) + (setq calc-refresh-count (1+ calc-refresh-count)) +) + + +(defun calc-x-paste-text (arg) + "Move point to mouse position and insert window system cut buffer contents. +If mouse is pressed in Calc window, push cut buffer contents onto the stack." + (x-mouse-select arg) + (if (memq major-mode '(calc-mode calc-trail-mode)) + (progn + (calc-wrapper + (calc-extensions) + (let* ((buf (x-get-cut-buffer)) + (val (math-read-exprs (calc-clean-newlines buf)))) + (if (eq (car-safe val) 'error) + (progn + (setq val (math-read-exprs buf)) + (if (eq (car-safe val) 'error) + (error "%s in yanked data" (nth 2 val))))) + (calc-enter-result 0 "Xynk" val)))) + (x-paste-text arg)) +) + + + +;;;; The Calc Trail buffer. + +(defun calc-check-trail-aligned () + (save-excursion + (let ((win (get-buffer-window (current-buffer)))) + (and win + (pos-visible-in-window-p (1- (point-max)) win)))) +) + +(defun calc-trail-buffer () + (and (or (null calc-trail-buffer) + (null (buffer-name calc-trail-buffer))) + (save-excursion + (setq calc-trail-buffer (get-buffer-create "*Calc Trail*")) + (let ((buf (or (and (not (eq major-mode 'calc-mode)) + (get-buffer "*Calculator*")) + (current-buffer)))) + (set-buffer calc-trail-buffer) + (or (eq major-mode 'calc-trail-mode) + (calc-trail-mode buf))))) + (or (and calc-trail-pointer + (eq (marker-buffer calc-trail-pointer) calc-trail-buffer)) + (save-excursion + (set-buffer calc-trail-buffer) + (goto-line 2) + (setq calc-trail-pointer (point-marker)))) + calc-trail-buffer +) + +(defun calc-record (val &optional prefix) + (setq calc-aborted-prefix nil) + (or calc-executing-macro + (let* ((mainbuf (current-buffer)) + (buf (calc-trail-buffer)) + (calc-display-raw nil) + (calc-can-abbrev-vectors t) + (fval (if val + (if (stringp val) + val + (math-showing-full-precision + (math-format-flat-expr val 0))) + ""))) + (save-excursion + (set-buffer buf) + (let ((aligned (calc-check-trail-aligned)) + (buffer-read-only nil)) + (goto-char (point-max)) + (cond ((null prefix) (insert " ")) + ((and (> (length prefix) 4) + (string-match " " prefix 4)) + (insert (substring prefix 0 4) " ")) + (t (insert (format "%4s " prefix)))) + (insert fval "\n") + (let ((win (get-buffer-window buf))) + (if (and aligned win (not (memq 'hold-trail calc-command-flags))) + (calc-trail-here)) + (goto-char (1- (point-max)))))))) + val +) + + +(defun calc-trail-display (flag &optional no-refresh) + (interactive "P") + (let ((win (get-buffer-window (calc-trail-buffer)))) + (if (setq calc-display-trail + (not (if flag (memq flag '(nil 0)) win))) + (if (null win) + (progn + (if (and (boundp 'calc-trail-window-hook) calc-trail-window-hook) + (run-hooks 'calc-trail-window-hook) + (let ((w (split-window nil (/ (* (window-width) 2) 3) t))) + (set-window-buffer w calc-trail-buffer))) + (calc-wrapper + (setq overlay-arrow-string calc-trail-overlay + overlay-arrow-position calc-trail-pointer) + (or no-refresh + (if (interactive-p) + (calc-do-refresh) + (calc-refresh)))))) + (if win + (progn + (delete-window win) + (calc-wrapper + (or no-refresh + (if (interactive-p) + (calc-do-refresh) + (calc-refresh)))))))) + calc-trail-buffer +) + +(defun calc-trail-here () + (interactive) + (if (eq major-mode 'calc-trail-mode) + (progn + (beginning-of-line) + (if (bobp) + (forward-line 1) + (if (eobp) + (forward-line -1))) + (if (or (bobp) (eobp)) + (setq overlay-arrow-position nil) ; trail is empty + (set-marker calc-trail-pointer (point) (current-buffer)) + (setq calc-trail-overlay (concat (buffer-substring (point) + (+ (point) 4)) + ">") + overlay-arrow-string calc-trail-overlay + overlay-arrow-position calc-trail-pointer) + (forward-char 4) + (let ((win (get-buffer-window (current-buffer)))) + (if win + (save-excursion + (forward-line (/ (window-height win) 2)) + (forward-line (- 1 (window-height win))) + (set-window-start win (point)) + (set-window-point win (+ calc-trail-pointer 4)) + (set-buffer calc-main-buffer) + (setq overlay-arrow-string calc-trail-overlay + overlay-arrow-position calc-trail-pointer)))))) + (error "Not in Calc Trail buffer")) +) + + + + +;;;; The Undo list. + +(defun calc-record-undo (rec) + (or calc-executing-macro + (if (memq 'undo calc-command-flags) + (setq calc-undo-list (cons (cons rec (car calc-undo-list)) + (cdr calc-undo-list))) + (setq calc-undo-list (cons (list rec) calc-undo-list) + calc-redo-list nil) + (calc-set-command-flag 'undo))) +) + + + + +;;; Arithmetic commands. + +(defun calc-binary-op (name func arg &optional ident unary func2) + (setq calc-aborted-prefix name) + (if (null arg) + (calc-enter-result 2 name (cons (or func2 func) + (mapcar 'math-check-complete + (calc-top-list 2)))) + (calc-extensions) + (calc-binary-op-fancy name func arg ident unary)) +) + +(defun calc-unary-op (name func arg &optional func2) + (setq calc-aborted-prefix name) + (if (null arg) + (calc-enter-result 1 name (list (or func2 func) + (math-check-complete (calc-top 1)))) + (calc-extensions) + (calc-unary-op-fancy name func arg)) +) + + +(defun calc-plus (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "+" 'calcFunc-add arg 0 nil '+)) +) + +(defun calc-minus (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "-" 'calcFunc-sub arg 0 'neg '-)) +) + +(defun calc-times (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "*" 'calcFunc-mul arg 1 nil '*)) +) + +(defun calc-divide (arg) + (interactive "P") + (calc-slow-wrapper + (calc-binary-op "/" 'calcFunc-div arg 0 'calcFunc-inv '/)) +) + + +(defun calc-change-sign (arg) + (interactive "P") + (calc-wrapper + (calc-unary-op "chs" 'neg arg)) +) + + + +;;; Stack management commands. + +(defun calc-enter (n) + (interactive "p") + (calc-wrapper + (cond ((< n 0) + (calc-push-list (calc-top-list 1 (- n)))) + ((= n 0) + (calc-push-list (calc-top-list (calc-stack-size)))) + (t + (calc-push-list (calc-top-list n))))) +) + + +(defun calc-pop (n) + (interactive "P") + (calc-wrapper + (let* ((nn (prefix-numeric-value n)) + (top (and (null n) (calc-top 1)))) + (cond ((and (null n) + (eq (car-safe top) 'incomplete) + (> (length top) (if (eq (nth 1 top) 'intv) 3 2))) + (calc-pop-push-list 1 (let ((tt (copy-sequence top))) + (setcdr (nthcdr (- (length tt) 2) tt) nil) + (list tt)))) + ((< nn 0) + (if (and calc-any-selections + (calc-top-selected 1 (- nn))) + (calc-delete-selection (- nn)) + (calc-pop-stack 1 (- nn) t))) + ((= nn 0) + (calc-pop-stack (calc-stack-size) 1 t)) + (t + (if (and calc-any-selections + (= nn 1) + (calc-top-selected 1 1)) + (calc-delete-selection 1) + (calc-pop-stack nn)))))) +) + + + + +;;;; Reading a number using the minibuffer. + +(defun calcDigit-start () + (interactive) + (calc-wrapper + (if (or calc-algebraic-mode + (and (> calc-number-radix 14) (eq last-command-char ?e))) + (calc-alg-digit-entry) + (calc-unread-command) + (setq calc-aborted-prefix nil) + (let* ((calc-digit-value nil) + (calc-prev-char nil) + (calc-prev-prev-char nil) + (calc-buffer (current-buffer)) + (buf (if calc-emacs-type-lucid + (catch 'calc-foo + (catch 'execute-kbd-macro + (throw 'calc-foo + (read-from-minibuffer + "Calc: " "" calc-digit-map))) + (error "Lucid Emacs requires RET after %s" + "digit entry in kbd macro")) + (let ((old-esc (lookup-key global-map "\e"))) + (unwind-protect + (progn + (define-key global-map "\e" nil) + (read-from-minibuffer "Calc: " "" calc-digit-map)) + (define-key global-map "\e" old-esc)))))) + (or calc-digit-value (setq calc-digit-value (math-read-number buf))) + (if (stringp calc-digit-value) + (calc-alg-entry calc-digit-value) + (if calc-digit-value + (calc-push-list (list (calc-record (calc-normalize + calc-digit-value)))))) + (if (eq calc-prev-char 'dots) + (progn + (calc-extensions) + (calc-dots)))))) +) + +(defun calcDigit-nondigit () + (interactive) + ;; Exercise for the reader: Figure out why this is a good precaution! + (or (boundp 'calc-buffer) + (use-local-map minibuffer-local-map)) + (let ((str (buffer-string))) + (setq calc-digit-value (save-excursion + (set-buffer calc-buffer) + (math-read-number str)))) + (if (and (null calc-digit-value) (> (buffer-size) 0)) + (progn + (beep) + (calc-temp-minibuffer-message " [Bad format]")) + (or (memq last-command-char '(32 13)) + (progn (setq prefix-arg current-prefix-arg) + (calc-unread-command (if (and (eq last-command-char 27) + (>= last-input-char 128)) + last-input-char + nil)))) + (exit-minibuffer)) +) + + +(defun calc-minibuffer-contains (rex) + (save-excursion + (goto-char (point-min)) + (looking-at rex)) +) + +(defun calcDigit-key () + (interactive) + (goto-char (point-max)) + (if (or (and (memq last-command-char '(?+ ?-)) + (> (buffer-size) 0) + (/= (preceding-char) ?e)) + (and (memq last-command-char '(?m ?s)) + (not (calc-minibuffer-contains "[-+]?[0-9]+\\.?0*[@oh].*")) + (not (calc-minibuffer-contains "[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#.*")))) + (calcDigit-nondigit) + (if (calc-minibuffer-contains "\\([-+]?\\|.* \\)\\'") + (cond ((memq last-command-char '(?. ?@)) (insert "0")) + ((and (memq last-command-char '(?o ?h ?m)) + (not (calc-minibuffer-contains ".*#.*"))) (insert "0")) + ((memq last-command-char '(?: ?e)) (insert "1")) + ((eq last-command-char ?#) + (insert (int-to-string calc-number-radix))))) + (if (and (calc-minibuffer-contains "\\([-+]?[0-9]+#\\|[^:]*:\\)\\'") + (eq last-command-char ?:)) + (insert "1")) + (if (and (calc-minibuffer-contains "[-+]?[0-9]+#\\'") + (eq last-command-char ?.)) + (insert "0")) + (if (and (calc-minibuffer-contains "[-+]?0*\\([2-9]\\|1[0-4]\\)#\\'") + (eq last-command-char ?e)) + (insert "1")) + (if (or (and (memq last-command-char '(?h ?o ?m ?s ?p)) + (calc-minibuffer-contains ".*#.*")) + (and (eq last-command-char ?e) + (calc-minibuffer-contains "[-+]?\\(1[5-9]\\|[2-9][0-9]\\)#.*")) + (and (eq last-command-char ?n) + (calc-minibuffer-contains "[-+]?\\(2[4-9]\\|[3-9][0-9]\\)#.*"))) + (setq last-command-char (upcase last-command-char))) + (cond + ((memq last-command-char '(?_ ?n)) + (goto-char (point-min)) + (if (and (search-forward " +/- " nil t) + (not (search-forward "e" nil t))) + (beep) + (and (not (calc-minibuffer-contains "[-+]?\\(1[5-9]\\|[2-9][0-9]\\)#.*")) + (search-forward "e" nil t)) + (if (looking-at "+") + (delete-char 1)) + (if (looking-at "-") + (delete-char 1) + (insert "-"))) + (goto-char (point-max))) + ((eq last-command-char ?p) + (if (or (calc-minibuffer-contains ".*\\+/-.*") + (calc-minibuffer-contains ".*mod.*") + (calc-minibuffer-contains ".*#.*") + (calc-minibuffer-contains ".*[-+e:]\\'")) + (beep) + (if (not (calc-minibuffer-contains ".* \\'")) + (insert " ")) + (insert "+/- "))) + ((and (eq last-command-char ?M) + (not (calc-minibuffer-contains + "[-+]?\\(2[3-9]\\|[3-9][0-9]\\)#.*"))) + (if (or (calc-minibuffer-contains ".*\\+/-.*") + (calc-minibuffer-contains ".*mod *[^ ]+") + (calc-minibuffer-contains ".*[-+e:]\\'")) + (beep) + (if (calc-minibuffer-contains ".*mod \\'") + (if calc-previous-modulo + (insert (math-format-flat-expr calc-previous-modulo 0)) + (beep)) + (if (not (calc-minibuffer-contains ".* \\'")) + (insert " ")) + (insert "mod ")))) + (t + (insert (char-to-string last-command-char)) + (if (or (and (calc-minibuffer-contains "[-+]?\\(.*\\+/- *\\|.*mod *\\)?\\([0-9][0-9]?\\)#[0-9a-zA-Z]*\\(:[0-9a-zA-Z]*\\(:[0-9a-zA-Z]*\\)?\\|.[0-9a-zA-Z]*\\(e[-+]?[0-9]*\\)?\\)?\\'") + (let ((radix (string-to-int + (buffer-substring + (match-beginning 2) (match-end 2))))) + (and (>= radix 2) + (<= radix 36) + (or (memq last-command-char '(?# ?: ?. ?e ?+ ?-)) + (let ((dig (math-read-radix-digit + (upcase last-command-char)))) + (and dig + (< dig radix))))))) + (save-excursion + (goto-char (point-min)) + (looking-at + "[-+]?\\(.*\\+/- *\\|.*mod *\\)?\\([0-9]+\\.?0*[@oh] *\\)?\\([0-9]+\\.?0*['m] *\\)?[0-9]*\\(\\.?[0-9]*\\(e[-+]?[0-3]?[0-9]?[0-9]?[0-9]?[0-9]?[0-9]?[0-9]?\\)?\\|[0-9]:\\([0-9]+:\\)?[0-9]*\\)?[\"s]?\\'"))) + (if (and (memq last-command-char '(?@ ?o ?h ?\' ?m)) + (string-match " " calc-hms-format)) + (insert " ")) + (if (and (eq this-command last-command) + (eq last-command-char ?.)) + (progn + (calc-extensions) + (calc-digit-dots)) + (delete-backward-char 1) + (beep) + (calc-temp-minibuffer-message " [Bad format]")))))) + (setq calc-prev-prev-char calc-prev-char + calc-prev-char last-command-char) +) + + +(defun calcDigit-backspace () + (interactive) + (goto-char (point-max)) + (cond ((calc-minibuffer-contains ".* \\+/- \\'") + (backward-delete-char 5)) + ((calc-minibuffer-contains ".* mod \\'") + (backward-delete-char 5)) + ((calc-minibuffer-contains ".* \\'") + (backward-delete-char 2)) + ((eq last-command 'calcDigit-start) + (erase-buffer)) + (t (backward-delete-char 1))) + (if (= (buffer-size) 0) + (progn + (setq last-command-char 13) + (calcDigit-nondigit))) +) + + + + + + + +;;;; Arithmetic routines. +;;; +;;; An object as manipulated by one of these routines may take any of the +;;; following forms: +;;; +;;; integer An integer. For normalized numbers, this format +;;; is used only for -999999 ... 999999. +;;; +;;; (bigpos N0 N1 N2 ...) A big positive integer, N0 + N1*1000 + N2*10^6 ... +;;; (bigneg N0 N1 N2 ...) A big negative integer, - N0 - N1*1000 ... +;;; Each digit N is in the range 0 ... 999. +;;; Normalized, always at least three N present, +;;; and the most significant N is nonzero. +;;; +;;; (frac NUM DEN) A fraction. NUM and DEN are small or big integers. +;;; Normalized, DEN > 1. +;;; +;;; (float NUM EXP) A floating-point number, NUM * 10^EXP; +;;; NUM is a small or big integer, EXP is a small int. +;;; Normalized, NUM is not a multiple of 10, and +;;; abs(NUM) < 10^calc-internal-prec. +;;; Normalized zero is stored as (float 0 0). +;;; +;;; (cplx REAL IMAG) A complex number; REAL and IMAG are any of above. +;;; Normalized, IMAG is nonzero. +;;; +;;; (polar R THETA) Polar complex number. Normalized, R > 0 and THETA +;;; is neither zero nor 180 degrees (pi radians). +;;; +;;; (vec A B C ...) Vector of objects A, B, C, ... A matrix is a +;;; vector of vectors. +;;; +;;; (hms H M S) Angle in hours-minutes-seconds form. All three +;;; components have the same sign; H and M must be +;;; numerically integers; M and S are expected to +;;; lie in the range [0,60). +;;; +;;; (date N) A date or date/time object. N is an integer to +;;; store a date only, or a fraction or float to +;;; store a date and time. +;;; +;;; (sdev X SIGMA) Error form, X +/- SIGMA. When normalized, +;;; SIGMA > 0. X is any complex number and SIGMA +;;; is real numbers; or these may be symbolic +;;; expressions where SIGMA is assumed real. +;;; +;;; (intv MASK LO HI) Interval form. MASK is 0=(), 1=(], 2=[), or 3=[]. +;;; LO and HI are any real numbers, or symbolic +;;; expressions which are assumed real, and LO < HI. +;;; For [LO..HI], if LO = HI normalization produces LO, +;;; and if LO > HI normalization produces [LO..LO). +;;; For other intervals, if LO > HI normalization +;;; sets HI equal to LO. +;;; +;;; (mod N M) Number modulo M. When normalized, 0 <= N < M. +;;; N and M are real numbers. +;;; +;;; (var V S) Symbolic variable. V is a Lisp symbol which +;;; represents the variable's visible name. S is +;;; the symbol which actually stores the variable's +;;; value: (var pi var-pi). +;;; +;;; In general, combining rational numbers in a calculation always produces +;;; a rational result, but if either argument is a float, result is a float. + +;;; In the following comments, [x y z] means result is x, args must be y, z, +;;; respectively, where the code letters are: +;;; +;;; O Normalized object (vector or number) +;;; V Normalized vector +;;; N Normalized number of any type +;;; N Normalized complex number +;;; R Normalized real number (float or rational) +;;; F Normalized floating-point number +;;; T Normalized rational number +;;; I Normalized integer +;;; B Normalized big integer +;;; S Normalized small integer +;;; D Digit (small integer, 0..999) +;;; L Normalized bignum digit list (without "bigpos" or "bigneg" symbol) +;;; or normalized vector element list (without "vec") +;;; P Predicate (truth value) +;;; X Any Lisp object +;;; Z "nil" +;;; +;;; Lower-case letters signify possibly un-normalized values. +;;; "L.D" means a cons of an L and a D. +;;; [N N; n n] means result will be normalized if argument is. +;;; Also, [Public] marks routines intended to be called from outside. +;;; [This notation has been neglected in many recent routines.] + +;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public] +(defun math-normalize (a) + (cond + ((not (consp a)) + (if (integerp a) + (if (or (>= a 1000000) (<= a -1000000)) + (math-bignum a) + a) + a)) + ((eq (car a) 'bigpos) + (if (eq (nth (1- (length a)) a) 0) + (let* ((last (setq a (copy-sequence a))) (digs a)) + (while (setq digs (cdr digs)) + (or (eq (car digs) 0) (setq last digs))) + (setcdr last nil))) + (if (cdr (cdr (cdr a))) + a + (cond + ((cdr (cdr a)) (+ (nth 1 a) (* (nth 2 a) 1000))) + ((cdr a) (nth 1 a)) + (t 0)))) + ((eq (car a) 'bigneg) + (if (eq (nth (1- (length a)) a) 0) + (let* ((last (setq a (copy-sequence a))) (digs a)) + (while (setq digs (cdr digs)) + (or (eq (car digs) 0) (setq last digs))) + (setcdr last nil))) + (if (cdr (cdr (cdr a))) + a + (cond + ((cdr (cdr a)) (- (+ (nth 1 a) (* (nth 2 a) 1000)))) + ((cdr a) (- (nth 1 a))) + (t 0)))) + ((eq (car a) 'float) + (math-make-float (math-normalize (nth 1 a)) (nth 2 a))) + ((or (memq (car a) '(frac cplx polar hms date mod sdev intv vec var quote + special-const calcFunc-if calcFunc-lambda + calcFunc-quote calcFunc-condition + calcFunc-evalto)) + (integerp (car a)) + (and (consp (car a)) (not (eq (car (car a)) 'lambda)))) + (calc-extensions) + (math-normalize-fancy a)) + (t + (or (and calc-simplify-mode + (calc-extensions) + (math-normalize-nonstandard)) + (let ((args (mapcar 'math-normalize (cdr a)))) + (or (condition-case err + (let ((func (assq (car a) '( ( + . math-add ) + ( - . math-sub ) + ( * . math-mul ) + ( / . math-div ) + ( % . math-mod ) + ( ^ . math-pow ) + ( neg . math-neg ) + ( | . math-concat ) )))) + (or (and var-EvalRules + (progn + (or (eq var-EvalRules math-eval-rules-cache-tag) + (progn + (calc-extensions) + (math-recompile-eval-rules))) + (and (or math-eval-rules-cache-other + (assq (car a) math-eval-rules-cache)) + (math-apply-rewrites + (cons (car a) args) + (cdr math-eval-rules-cache) + nil math-eval-rules-cache)))) + (if func + (apply (cdr func) args) + (and (or (consp (car a)) + (fboundp (car a)) + (and (not calc-extensions-loaded) + (calc-extensions) + (fboundp (car a)))) + (apply (car a) args))))) + (wrong-number-of-arguments + (calc-record-why "*Wrong number of arguments" + (cons (car a) args)) + nil) + (wrong-type-argument + (or calc-next-why (calc-record-why "Wrong type of argument" + (cons (car a) args))) + nil) + (args-out-of-range + (calc-record-why "*Argument out of range" (cons (car a) args)) + nil) + (inexact-result + (calc-record-why "No exact representation for result" + (cons (car a) args)) + nil) + (math-overflow + (calc-record-why "*Floating-point overflow occurred" + (cons (car a) args)) + nil) + (math-underflow + (calc-record-why "*Floating-point underflow occurred" + (cons (car a) args)) + nil) + (void-variable + (if (eq (nth 1 err) 'var-EvalRules) + (progn + (setq var-EvalRules nil) + (math-normalize (cons (car a) args))) + (calc-record-why "*Variable is void" (nth 1 err))))) + (if (consp (car a)) + (math-dimension-error) + (cons (car a) args))))))) +) + + + +;;; True if A is a floating-point real or complex number. [P x] [Public] +(defun math-floatp (a) + (cond ((eq (car-safe a) 'float) t) + ((memq (car-safe a) '(cplx polar mod sdev intv)) + (or (math-floatp (nth 1 a)) + (math-floatp (nth 2 a)) + (and (eq (car a) 'intv) (math-floatp (nth 3 a))))) + ((eq (car-safe a) 'date) + (math-floatp (nth 1 a)))) +) + + + +;;; Verify that A is a complete object and return A. [x x] [Public] +(defun math-check-complete (a) + (cond ((integerp a) a) + ((eq (car-safe a) 'incomplete) + (calc-incomplete-error a)) + ((consp a) a) + (t (error "Invalid data object encountered"))) +) + + + +;;; Coerce integer A to be a bignum. [B S] +(defun math-bignum (a) + (if (>= a 0) + (cons 'bigpos (math-bignum-big a)) + (cons 'bigneg (math-bignum-big (- a)))) +) + +(defun math-bignum-big (a) ; [L s] + (if (= a 0) + nil + (cons (% a 1000) (math-bignum-big (/ a 1000)))) +) + + +;;; Build a normalized floating-point number. [F I S] +(defun math-make-float (mant exp) + (if (eq mant 0) + '(float 0 0) + (let* ((ldiff (- calc-internal-prec (math-numdigs mant)))) + (if (< ldiff 0) + (setq mant (math-scale-rounding mant ldiff) + exp (- exp ldiff)))) + (if (consp mant) + (let ((digs (cdr mant))) + (if (= (% (car digs) 10) 0) + (progn + (while (= (car digs) 0) + (setq digs (cdr digs) + exp (+ exp 3))) + (while (= (% (car digs) 10) 0) + (setq digs (math-div10-bignum digs) + exp (1+ exp))) + (setq mant (math-normalize (cons (car mant) digs)))))) + (while (= (% mant 10) 0) + (setq mant (/ mant 10) + exp (1+ exp)))) + (if (and (<= exp -4000000) + (<= (+ exp (math-numdigs mant) -1) -4000000)) + (signal 'math-underflow nil) + (if (and (>= exp 3000000) + (>= (+ exp (math-numdigs mant) -1) 4000000)) + (signal 'math-overflow nil) + (list 'float mant exp)))) +) + +(defun math-div10-bignum (a) ; [l l] + (if (cdr a) + (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) 100)) + (math-div10-bignum (cdr a))) + (list (/ (car a) 10))) +) + +;;; Coerce A to be a float. [F N; V V] [Public] +(defun math-float (a) + (cond ((Math-integerp a) (math-make-float a 0)) + ((eq (car a) 'frac) (math-div (math-float (nth 1 a)) (nth 2 a))) + ((eq (car a) 'float) a) + ((memq (car a) '(cplx polar vec hms date sdev mod)) + (cons (car a) (mapcar 'math-float (cdr a)))) + (t (math-float-fancy a))) +) + + +(defun math-neg (a) + (cond ((not (consp a)) (- a)) + ((eq (car a) 'bigpos) (cons 'bigneg (cdr a))) + ((eq (car a) 'bigneg) (cons 'bigpos (cdr a))) + ((memq (car a) '(frac float)) + (list (car a) (Math-integer-neg (nth 1 a)) (nth 2 a))) + ((memq (car a) '(cplx vec hms date calcFunc-idn)) + (cons (car a) (mapcar 'math-neg (cdr a)))) + (t (math-neg-fancy a))) +) + + +;;; Compute the number of decimal digits in integer A. [S I] +(defun math-numdigs (a) + (if (consp a) + (if (cdr a) + (let* ((len (1- (length a))) + (top (nth len a))) + (+ (* len 3) (cond ((>= top 100) 0) ((>= top 10) -1) (t -2)))) + 0) + (cond ((>= a 100) (+ (math-numdigs (/ a 1000)) 3)) + ((>= a 10) 2) + ((>= a 1) 1) + ((= a 0) 0) + ((> a -10) 1) + ((> a -100) 2) + (t (math-numdigs (- a))))) +) + +;;; Multiply (with truncation toward 0) the integer A by 10^N. [I i S] +(defun math-scale-int (a n) + (cond ((= n 0) a) + ((> n 0) (math-scale-left a n)) + (t (math-normalize (math-scale-right a (- n))))) +) + +(defun math-scale-left (a n) ; [I I S] + (if (= n 0) + a + (if (consp a) + (cons (car a) (math-scale-left-bignum (cdr a) n)) + (if (>= n 3) + (if (or (>= a 1000) (<= a -1000)) + (math-scale-left (math-bignum a) n) + (math-scale-left (* a 1000) (- n 3))) + (if (= n 2) + (if (or (>= a 10000) (<= a -10000)) + (math-scale-left (math-bignum a) 2) + (* a 100)) + (if (or (>= a 100000) (<= a -100000)) + (math-scale-left (math-bignum a) 1) + (* a 10)))))) +) + +(defun math-scale-left-bignum (a n) + (if (>= n 3) + (while (>= (setq a (cons 0 a) + n (- n 3)) 3))) + (if (> n 0) + (math-mul-bignum-digit a (if (= n 2) 100 10) 0) + a) +) + +(defun math-scale-right (a n) ; [i i S] + (if (= n 0) + a + (if (consp a) + (cons (car a) (math-scale-right-bignum (cdr a) n)) + (if (<= a 0) + (if (= a 0) + 0 + (- (math-scale-right (- a) n))) + (if (>= n 3) + (while (and (> (setq a (/ a 1000)) 0) + (>= (setq n (- n 3)) 3)))) + (if (= n 2) + (/ a 100) + (if (= n 1) + (/ a 10) + a))))) +) + +(defun math-scale-right-bignum (a n) ; [L L S; l l S] + (if (>= n 3) + (setq a (nthcdr (/ n 3) a) + n (% n 3))) + (if (> n 0) + (cdr (math-mul-bignum-digit a (if (= n 2) 10 100) 0)) + a) +) + +;;; Multiply (with rounding) the integer A by 10^N. [I i S] +(defun math-scale-rounding (a n) + (cond ((>= n 0) + (math-scale-left a n)) + ((consp a) + (math-normalize + (cons (car a) + (let ((val (if (< n -3) + (math-scale-right-bignum (cdr a) (- -3 n)) + (if (= n -2) + (math-mul-bignum-digit (cdr a) 10 0) + (if (= n -1) + (math-mul-bignum-digit (cdr a) 100 0) + (cdr a)))))) ; n = -3 + (if (and val (>= (car val) 500)) + (if (cdr val) + (if (eq (car (cdr val)) 999) + (math-add-bignum (cdr val) '(1)) + (cons (1+ (car (cdr val))) (cdr (cdr val)))) + '(1)) + (cdr val)))))) + (t + (if (< a 0) + (- (math-scale-rounding (- a) n)) + (if (= n -1) + (/ (+ a 5) 10) + (/ (+ (math-scale-right a (- -1 n)) 5) 10))))) +) + + +;;; Compute the sum of A and B. [O O O] [Public] +(defun math-add (a b) + (or + (and (not (or (consp a) (consp b))) + (progn + (setq a (+ a b)) + (if (or (<= a -1000000) (>= a 1000000)) + (math-bignum a) + a))) + (and (Math-zerop a) (not (eq (car-safe a) 'mod)) + (if (and (math-floatp a) (Math-ratp b)) (math-float b) b)) + (and (Math-zerop b) (not (eq (car-safe b) 'mod)) + (if (and (math-floatp b) (Math-ratp a)) (math-float a) a)) + (and (Math-objvecp a) (Math-objvecp b) + (or + (and (Math-integerp a) (Math-integerp b) + (progn + (or (consp a) (setq a (math-bignum a))) + (or (consp b) (setq b (math-bignum b))) + (if (eq (car a) 'bigneg) + (if (eq (car b) 'bigneg) + (cons 'bigneg (math-add-bignum (cdr a) (cdr b))) + (math-normalize + (let ((diff (math-sub-bignum (cdr b) (cdr a)))) + (if (eq diff 'neg) + (cons 'bigneg (math-sub-bignum (cdr a) (cdr b))) + (cons 'bigpos diff))))) + (if (eq (car b) 'bigneg) + (math-normalize + (let ((diff (math-sub-bignum (cdr a) (cdr b)))) + (if (eq diff 'neg) + (cons 'bigneg (math-sub-bignum (cdr b) (cdr a))) + (cons 'bigpos diff)))) + (cons 'bigpos (math-add-bignum (cdr a) (cdr b))))))) + (and (Math-ratp a) (Math-ratp b) + (calc-extensions) + (calc-add-fractions a b)) + (and (Math-realp a) (Math-realp b) + (progn + (or (and (consp a) (eq (car a) 'float)) + (setq a (math-float a))) + (or (and (consp b) (eq (car b) 'float)) + (setq b (math-float b))) + (math-add-float a b))) + (and (calc-extensions) + (math-add-objects-fancy a b)))) + (and (calc-extensions) + (math-add-symb-fancy a b))) +) + +(defun math-add-bignum (a b) ; [L L L; l l l] + (if a + (if b + (let* ((a (copy-sequence a)) (aa a) (carry nil) sum) + (while (and aa b) + (if carry + (if (< (setq sum (+ (car aa) (car b))) 999) + (progn + (setcar aa (1+ sum)) + (setq carry nil)) + (setcar aa (+ sum -999))) + (if (< (setq sum (+ (car aa) (car b))) 1000) + (setcar aa sum) + (setcar aa (+ sum -1000)) + (setq carry t))) + (setq aa (cdr aa) + b (cdr b))) + (if carry + (if b + (nconc a (math-add-bignum b '(1))) + (while (eq (car aa) 999) + (setcar aa 0) + (setq aa (cdr aa))) + (if aa + (progn + (setcar aa (1+ (car aa))) + a) + (nconc a '(1)))) + (if b + (nconc a b) + a))) + a) + b) +) + +(defun math-sub-bignum (a b) ; [l l l] + (if b + (if a + (let* ((a (copy-sequence a)) (aa a) (borrow nil) sum) + (while (and aa b) + (if borrow + (if (>= (setq diff (- (car aa) (car b))) 1) + (progn + (setcar aa (1- diff)) + (setq borrow nil)) + (setcar aa (+ diff 999))) + (if (>= (setq diff (- (car aa) (car b))) 0) + (setcar aa diff) + (setcar aa (+ diff 1000)) + (setq borrow t))) + (setq aa (cdr aa) + b (cdr b))) + (if borrow + (progn + (while (eq (car aa) 0) + (setcar aa 999) + (setq aa (cdr aa))) + (if aa + (progn + (setcar aa (1- (car aa))) + a) + 'neg)) + (while (eq (car b) 0) + (setq b (cdr b))) + (if b + 'neg + a))) + (while (eq (car b) 0) + (setq b (cdr b))) + (and b + 'neg)) + a) +) + +(defun math-add-float (a b) ; [F F F] + (let ((ediff (- (nth 2 a) (nth 2 b)))) + (if (>= ediff 0) + (if (>= ediff (+ calc-internal-prec calc-internal-prec)) + a + (math-make-float (math-add (nth 1 b) + (if (eq ediff 0) + (nth 1 a) + (math-scale-left (nth 1 a) ediff))) + (nth 2 b))) + (if (>= (setq ediff (- ediff)) + (+ calc-internal-prec calc-internal-prec)) + b + (math-make-float (math-add (nth 1 a) + (math-scale-left (nth 1 b) ediff)) + (nth 2 a))))) +) + +;;; Compute the difference of A and B. [O O O] [Public] +(defun math-sub (a b) + (if (or (consp a) (consp b)) + (math-add a (math-neg b)) + (setq a (- a b)) + (if (or (<= a -1000000) (>= a 1000000)) + (math-bignum a) + a)) +) + +(defun math-sub-float (a b) ; [F F F] + (let ((ediff (- (nth 2 a) (nth 2 b)))) + (if (>= ediff 0) + (if (>= ediff (+ calc-internal-prec calc-internal-prec)) + a + (math-make-float (math-add (Math-integer-neg (nth 1 b)) + (if (eq ediff 0) + (nth 1 a) + (math-scale-left (nth 1 a) ediff))) + (nth 2 b))) + (if (>= (setq ediff (- ediff)) + (+ calc-internal-prec calc-internal-prec)) + b + (math-make-float (math-add (nth 1 a) + (Math-integer-neg + (math-scale-left (nth 1 b) ediff))) + (nth 2 a))))) +) + + +;;; Compute the product of A and B. [O O O] [Public] +(defun math-mul (a b) + (or + (and (not (consp a)) (not (consp b)) + (< a 1000) (> a -1000) (< b 1000) (> b -1000) + (* a b)) + (and (Math-zerop a) (not (eq (car-safe b) 'mod)) + (if (Math-scalarp b) + (if (and (math-floatp b) (Math-ratp a)) (math-float a) a) + (calc-extensions) + (math-mul-zero a b))) + (and (Math-zerop b) (not (eq (car-safe a) 'mod)) + (if (Math-scalarp a) + (if (and (math-floatp a) (Math-ratp b)) (math-float b) b) + (calc-extensions) + (math-mul-zero b a))) + (and (Math-objvecp a) (Math-objvecp b) + (or + (and (Math-integerp a) (Math-integerp b) + (progn + (or (consp a) (setq a (math-bignum a))) + (or (consp b) (setq b (math-bignum b))) + (math-normalize + (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) + (if (cdr (cdr a)) + (if (cdr (cdr b)) + (math-mul-bignum (cdr a) (cdr b)) + (math-mul-bignum-digit (cdr a) (nth 1 b) 0)) + (math-mul-bignum-digit (cdr b) (nth 1 a) 0)))))) + (and (Math-ratp a) (Math-ratp b) + (calc-extensions) + (calc-mul-fractions a b)) + (and (Math-realp a) (Math-realp b) + (progn + (or (and (consp a) (eq (car a) 'float)) + (setq a (math-float a))) + (or (and (consp b) (eq (car b) 'float)) + (setq b (math-float b))) + (math-make-float (math-mul (nth 1 a) (nth 1 b)) + (+ (nth 2 a) (nth 2 b))))) + (and (calc-extensions) + (math-mul-objects-fancy a b)))) + (and (calc-extensions) + (math-mul-symb-fancy a b))) +) + +(defun math-infinitep (a &optional undir) + (while (and (consp a) (memq (car a) '(* / neg))) + (if (or (not (eq (car a) '*)) (math-infinitep (nth 1 a))) + (setq a (nth 1 a)) + (setq a (nth 2 a)))) + (and (consp a) + (eq (car a) 'var) + (memq (nth 2 a) '(var-inf var-uinf var-nan)) + (if (and undir (eq (nth 2 a) 'var-inf)) + '(var uinf var-uinf) + a)) +) + +;;; Multiply digit lists A and B. [L L L; l l l] +(defun math-mul-bignum (a b) + (and a b + (let* ((sum (if (<= (car b) 1) + (if (= (car b) 0) + (list 0) + (copy-sequence a)) + (math-mul-bignum-digit a (car b) 0))) + (sump sum) c d aa ss prod) + (while (setq b (cdr b)) + (setq ss (setq sump (or (cdr sump) (setcdr sump (list 0)))) + d (car b) + c 0 + aa a) + (while (progn + (setcar ss (% (setq prod (+ (+ (car ss) (* (car aa) d)) + c)) 1000)) + (setq aa (cdr aa))) + (setq c (/ prod 1000) + ss (or (cdr ss) (setcdr ss (list 0))))) + (if (>= prod 1000) + (if (cdr ss) + (setcar (cdr ss) (+ (/ prod 1000) (car (cdr ss)))) + (setcdr ss (list (/ prod 1000)))))) + sum)) +) + +;;; Multiply digit list A by digit D. [L L D D; l l D D] +(defun math-mul-bignum-digit (a d c) + (if a + (if (<= d 1) + (and (= d 1) a) + (let* ((a (copy-sequence a)) (aa a) prod) + (while (progn + (setcar aa (% (setq prod (+ (* (car aa) d) c)) 1000)) + (cdr aa)) + (setq aa (cdr aa) + c (/ prod 1000))) + (if (>= prod 1000) + (setcdr aa (list (/ prod 1000)))) + a)) + (and (> c 0) + (list c))) +) + + +;;; Compute the integer (quotient . remainder) of A and B, which may be +;;; small or big integers. Type and consistency of truncation is undefined +;;; if A or B is negative. B must be nonzero. [I.I I I] [Public] +(defun math-idivmod (a b) + (if (eq b 0) + (math-reject-arg a "*Division by zero")) + (if (or (consp a) (consp b)) + (if (and (natnump b) (< b 1000)) + (let ((res (math-div-bignum-digit (cdr a) b))) + (cons + (math-normalize (cons (car a) (car res))) + (cdr res))) + (or (consp a) (setq a (math-bignum a))) + (or (consp b) (setq b (math-bignum b))) + (let ((res (math-div-bignum (cdr a) (cdr b)))) + (cons + (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) + (car res))) + (math-normalize (cons (car a) (cdr res)))))) + (cons (/ a b) (% a b))) +) + +(defun math-quotient (a b) ; [I I I] [Public] + (if (and (not (consp a)) (not (consp b))) + (if (= b 0) + (math-reject-arg a "*Division by zero") + (/ a b)) + (if (and (natnump b) (< b 1000)) + (if (= b 0) + (math-reject-arg a "*Division by zero") + (math-normalize (cons (car a) + (car (math-div-bignum-digit (cdr a) b))))) + (or (consp a) (setq a (math-bignum a))) + (or (consp b) (setq b (math-bignum b))) + (let* ((alen (1- (length a))) + (blen (1- (length b))) + (d (/ 1000 (1+ (nth (1- blen) (cdr b))))) + (res (math-div-bignum-big (math-mul-bignum-digit (cdr a) d 0) + (math-mul-bignum-digit (cdr b) d 0) + alen blen))) + (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) + (car res)))))) +) + + +;;; Divide a bignum digit list by another. [l.l l L] +;;; The following division algorithm is borrowed from Knuth vol. II, sec. 4.3.1 +(defun math-div-bignum (a b) + (if (cdr b) + (let* ((alen (length a)) + (blen (length b)) + (d (/ 1000 (1+ (nth (1- blen) b)))) + (res (math-div-bignum-big (math-mul-bignum-digit a d 0) + (math-mul-bignum-digit b d 0) + alen blen))) + (if (= d 1) + res + (cons (car res) + (car (math-div-bignum-digit (cdr res) d))))) + (let ((res (math-div-bignum-digit a (car b)))) + (cons (car res) (list (cdr res))))) +) + +;;; Divide a bignum digit list by a digit. [l.D l D] +(defun math-div-bignum-digit (a b) + (if a + (let* ((res (math-div-bignum-digit (cdr a) b)) + (num (+ (* (cdr res) 1000) (car a)))) + (cons + (cons (/ num b) (car res)) + (% num b))) + '(nil . 0)) +) + +(defun math-div-bignum-big (a b alen blen) ; [l.l l L] + (if (< alen blen) + (cons nil a) + (let* ((res (math-div-bignum-big (cdr a) b (1- alen) blen)) + (num (cons (car a) (cdr res))) + (res2 (math-div-bignum-part num b blen))) + (cons + (cons (car res2) (car res)) + (cdr res2)))) +) + +(defun math-div-bignum-part (a b blen) ; a < b*1000 [D.l l L] + (let* ((num (+ (* (or (nth blen a) 0) 1000) (or (nth (1- blen) a) 0))) + (den (nth (1- blen) b)) + (guess (min (/ num den) 999))) + (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess)) +) + +(defun math-div-bignum-try (a b c guess) ; [D.l l l D] + (let ((rem (math-sub-bignum a c))) + (if (eq rem 'neg) + (math-div-bignum-try a b (math-sub-bignum c b) (1- guess)) + (cons guess rem))) +) + + +;;; Compute the quotient of A and B. [O O N] [Public] +(defun math-div (a b) + (or + (and (Math-zerop b) + (calc-extensions) + (math-div-by-zero a b)) + (and (Math-zerop a) (not (eq (car-safe b) 'mod)) + (if (Math-scalarp b) + (if (and (math-floatp b) (Math-ratp a)) (math-float a) a) + (calc-extensions) + (math-div-zero a b))) + (and (Math-objvecp a) (Math-objvecp b) + (or + (and (Math-integerp a) (Math-integerp b) + (let ((q (math-idivmod a b))) + (if (eq (cdr q) 0) + (car q) + (if calc-prefer-frac + (progn + (calc-extensions) + (math-make-frac a b)) + (math-div-float (math-make-float a 0) + (math-make-float b 0)))))) + (and (Math-ratp a) (Math-ratp b) + (calc-extensions) + (calc-div-fractions a b)) + (and (Math-realp a) (Math-realp b) + (progn + (or (and (consp a) (eq (car a) 'float)) + (setq a (math-float a))) + (or (and (consp b) (eq (car b) 'float)) + (setq b (math-float b))) + (math-div-float a b))) + (and (calc-extensions) + (math-div-objects-fancy a b)))) + (and (calc-extensions) + (math-div-symb-fancy a b))) +) + +(defun math-div-float (a b) ; [F F F] + (let ((ldiff (max (- (1+ calc-internal-prec) + (- (math-numdigs (nth 1 a)) (math-numdigs (nth 1 b)))) + 0))) + (math-make-float (math-quotient (math-scale-int (nth 1 a) ldiff) (nth 1 b)) + (- (- (nth 2 a) (nth 2 b)) ldiff))) +) + + + + + +;;; Format the number A as a string. [X N; X Z] [Public] +(defun math-format-stack-value (entry) + (setq calc-selection-cache-entry calc-selection-cache-default-entry) + (let* ((a (car entry)) + (math-comp-selected (nth 2 entry)) + (c (cond ((null a) "<nil>") + ((eq calc-display-raw t) (format "%s" a)) + ((stringp a) a) + ((eq a 'top-of-stack) ".") + (calc-prepared-composition + calc-prepared-composition) + ((and (Math-scalarp a) + (memq calc-language '(nil flat unform)) + (null math-comp-selected)) + (math-format-number a)) + (t (calc-extensions) + (math-compose-expr a 0)))) + (off (math-stack-value-offset c)) + s w) + (and math-comp-selected (setq calc-any-selections t)) + (setq w (cdr off) + off (car off)) + (if (> off 0) + (setq c (math-comp-concat (make-string off ? ) c))) + (or (equal calc-left-label "") + (setq c (math-comp-concat (if (eq a 'top-of-stack) + (make-string (length calc-left-label) ? ) + calc-left-label) + c))) + (if calc-line-numbering + (setq c (math-comp-concat (if (eq calc-language 'big) + (if math-comp-selected + '(tag t "1: ") "1: ") + " ") + c))) + (or (equal calc-right-label "") + (eq a 'top-of-stack) + (progn + (calc-extensions) + (setq c (list 'horiz c + (make-string (max (- w (math-comp-width c) + (length calc-right-label)) 0) ? ) + '(break -1) + calc-right-label)))) + (setq s (if (stringp c) + (if calc-display-raw + (prin1-to-string c) + c) + (math-composition-to-string c w))) + (if calc-language-output-filter + (setq s (funcall calc-language-output-filter s))) + (if (eq calc-language 'big) + (setq s (concat s "\n")) + (if calc-line-numbering + (progn + (aset s 0 ?1) + (aset s 1 ?:)))) + (setcar (cdr entry) (calc-count-lines s)) + s) +) + +(defun math-stack-value-offset (c) + (let* ((num (if calc-line-numbering 4 0)) + (wid (calc-window-width)) + off) + (if calc-display-just + (progn + (calc-extensions) + (math-stack-value-offset-fancy)) + (setq off (or calc-display-origin 0)) + (if (integerp calc-line-breaking) + (setq wid calc-line-breaking))) + (cons (max (- off (length calc-left-label)) 0) + (+ wid num))) +) + +(defun calc-count-lines (s) + (let ((pos 0) + (num 1)) + (while (setq newpos (string-match "\n" s pos)) + (setq pos (1+ newpos) + num (1+ num))) + num) +) + +(defun math-format-value (a &optional w) + (if (and (Math-scalarp a) + (memq calc-language '(nil flat unform))) + (math-format-number a) + (calc-extensions) + (let ((calc-line-breaking nil)) + (math-composition-to-string (math-compose-expr a 0) w))) +) + +(defun calc-window-width () + (if calc-embedded-info + (let ((win (get-buffer-window (aref calc-embedded-info 0)))) + (1- (if win (window-width win) (screen-width)))) + (- (window-width (get-buffer-window (current-buffer))) + (if calc-line-numbering 5 1))) +) + +(defun math-comp-concat (c1 c2) + (if (and (stringp c1) (stringp c2)) + (concat c1 c2) + (list 'horiz c1 c2)) +) + + + +;;; Format an expression as a one-line string suitable for re-reading. + +(defun math-format-flat-expr (a prec) + (cond + ((or (not (or (consp a) (integerp a))) + (eq calc-display-raw t)) + (let ((print-escape-newlines t)) + (concat "'" (prin1-to-string a)))) + ((Math-scalarp a) + (let ((calc-group-digits nil) + (calc-point-char ".") + (calc-frac-format (if (> (length (car calc-frac-format)) 1) + '("::" nil) '(":" nil))) + (calc-complex-format nil) + (calc-hms-format "%s@ %s' %s\"") + (calc-language nil)) + (math-format-number a))) + (t + (calc-extensions) + (math-format-flat-expr-fancy a prec))) +) + + + +;;; Format a number as a string. +(defun math-format-number (a &optional prec) ; [X N] [Public] + (cond + ((eq calc-display-raw t) (format "%s" a)) + ((and (nth 1 calc-frac-format) (Math-integerp a)) + (calc-extensions) + (math-format-number (math-adjust-fraction a))) + ((integerp a) + (if (not (or calc-group-digits calc-leading-zeros)) + (if (= calc-number-radix 10) + (int-to-string a) + (if (< a 0) + (concat "-" (math-format-number (- a))) + (calc-extensions) + (if math-radix-explicit-format + (if calc-radix-formatter + (funcall calc-radix-formatter + calc-number-radix + (if (= calc-number-radix 2) + (math-format-binary a) + (math-format-radix a))) + (format "%d#%s" calc-number-radix + (if (= calc-number-radix 2) + (math-format-binary a) + (math-format-radix a)))) + (math-format-radix a)))) + (math-format-number (math-bignum a)))) + ((stringp a) a) + ((not (consp a)) (prin1-to-string a)) + ((eq (car a) 'bigpos) (math-format-bignum (cdr a))) + ((eq (car a) 'bigneg) (concat "-" (math-format-bignum (cdr a)))) + ((and (eq (car a) 'float) (= calc-number-radix 10)) + (if (Math-integer-negp (nth 1 a)) + (concat "-" (math-format-number (math-neg a))) + (let ((mant (nth 1 a)) + (exp (nth 2 a)) + (fmt (car calc-float-format)) + (figs (nth 1 calc-float-format)) + (point calc-point-char) + str) + (if (and (eq fmt 'fix) + (or (and (< figs 0) (setq figs (- figs))) + (> (+ exp (math-numdigs mant)) (- figs)))) + (progn + (setq mant (math-scale-rounding mant (+ exp figs)) + str (if (integerp mant) + (int-to-string mant) + (math-format-bignum-decimal (cdr mant)))) + (if (<= (length str) figs) + (setq str (concat (make-string (1+ (- figs (length str))) ?0) + str))) + (if (> figs 0) + (setq str (concat (substring str 0 (- figs)) point + (substring str (- figs)))) + (setq str (concat str point))) + (if calc-group-digits + (setq str (math-group-float str)))) + (if (< figs 0) + (setq figs (+ calc-internal-prec figs))) + (if (> figs 0) + (let ((adj (- figs (math-numdigs mant)))) + (if (< adj 0) + (setq mant (math-scale-rounding mant adj) + exp (- exp adj))))) + (setq str (if (integerp mant) + (int-to-string mant) + (math-format-bignum-decimal (cdr mant)))) + (let* ((len (length str)) + (dpos (+ exp len))) + (if (and (eq fmt 'float) + (<= dpos (+ calc-internal-prec calc-display-sci-high)) + (>= dpos (+ calc-display-sci-low 2))) + (progn + (cond + ((= dpos 0) + (setq str (concat "0" point str))) + ((and (<= exp 0) (> dpos 0)) + (setq str (concat (substring str 0 dpos) point + (substring str dpos)))) + ((> exp 0) + (setq str (concat str (make-string exp ?0) point))) + (t ; (< dpos 0) + (setq str (concat "0" point + (make-string (- dpos) ?0) str)))) + (if calc-group-digits + (setq str (math-group-float str)))) + (let* ((eadj (+ exp len)) + (scale (if (eq fmt 'eng) + (1+ (math-mod (+ eadj 300002) 3)) + 1))) + (if (> scale (length str)) + (setq str (concat str (make-string (- scale (length str)) + ?0)))) + (if (< scale (length str)) + (setq str (concat (substring str 0 scale) point + (substring str scale)))) + (if calc-group-digits + (setq str (math-group-float str))) + (setq str (format (if (memq calc-language '(math maple)) + (if (and prec (> prec 191)) + "(%s*10.^%d)" "%s*10.^%d") + "%se%d") + str (- eadj scale))))))) + str))) + (t + (calc-extensions) + (math-format-number-fancy a prec))) +) + +(defun math-format-bignum (a) ; [X L] + (if (and (= calc-number-radix 10) + (not calc-leading-zeros) + (not calc-group-digits)) + (math-format-bignum-decimal a) + (calc-extensions) + (math-format-bignum-fancy a)) +) + +(defun math-format-bignum-decimal (a) ; [X L] + (if a + (let ((s "")) + (while (cdr (cdr a)) + (setq s (concat (format "%06d" (+ (* (nth 1 a) 1000) (car a))) s) + a (cdr (cdr a)))) + (concat (int-to-string (+ (* (or (nth 1 a) 0) 1000) (car a))) s)) + "0") +) + + + +;;; Parse a simple number in string form. [N X] [Public] +(defun math-read-number (s) + (math-normalize + (cond + + ;; Integers (most common case) + ((string-match "\\` *\\([0-9]+\\) *\\'" s) + (let ((digs (math-match-substring s 1))) + (if (and (eq calc-language 'c) + (> (length digs) 1) + (eq (aref digs 0) ?0)) + (math-read-number (concat "8#" digs)) + (if (<= (length digs) 6) + (string-to-int digs) + (cons 'bigpos (math-read-bignum digs)))))) + + ;; Clean up the string if necessary + ((string-match "\\`\\(.*\\)[ \t\n]+\\([^\001]*\\)\\'" s) + (math-read-number (concat (math-match-substring s 1) + (math-match-substring s 2)))) + + ;; Plus and minus signs + ((string-match "^[-_+]\\(.*\\)$" s) + (let ((val (math-read-number (math-match-substring s 1)))) + (and val (if (eq (aref s 0) ?+) val (math-neg val))))) + + ;; Forms that require extensions module + ((string-match "[^-+0-9eE.]" s) + (calc-extensions) + (math-read-number-fancy s)) + + ;; Decimal point + ((string-match "^\\([0-9]*\\)\\.\\([0-9]*\\)$" s) + (let ((int (math-match-substring s 1)) + (frac (math-match-substring s 2))) + (let ((ilen (length int)) + (flen (length frac))) + (let ((int (if (> ilen 0) (math-read-number int) 0)) + (frac (if (> flen 0) (math-read-number frac) 0))) + (and int frac (or (> ilen 0) (> flen 0)) + (list 'float + (math-add (math-scale-int int flen) frac) + (- flen))))))) + + ;; "e" notation + ((string-match "^\\(.*\\)[eE]\\([-+]?[0-9]+\\)$" s) + (let ((mant (math-match-substring s 1)) + (exp (math-match-substring s 2))) + (let ((mant (if (> (length mant) 0) (math-read-number mant) 1)) + (exp (if (<= (length exp) (if (memq (aref exp 0) '(?+ ?-)) 8 7)) + (string-to-int exp)))) + (and mant exp (Math-realp mant) (> exp -4000000) (< exp 4000000) + (let ((mant (math-float mant))) + (list 'float (nth 1 mant) (+ (nth 2 mant) exp))))))) + + ;; Syntax error! + (t nil))) +) + +(defun math-match-substring (s n) + (if (match-beginning n) + (substring s (match-beginning n) (match-end n)) + "") +) + +(defun math-read-bignum (s) ; [l X] + (if (> (length s) 3) + (cons (string-to-int (substring s -3)) + (math-read-bignum (substring s 0 -3))) + (list (string-to-int s))) +) + + +(defconst math-tex-ignore-words + '( ("\\hbox") ("\\mbox") ("\\text") ("\\left") ("\\right") + ("\\,") ("\\>") ("\\:") ("\\;") ("\\!") ("\\ ") + ("\\quad") ("\\qquad") ("\\hfil") ("\\hfill") + ("\\displaystyle") ("\\textstyle") ("\\dsize") ("\\tsize") + ("\\scriptstyle") ("\\scriptscriptstyle") ("\\ssize") ("\\sssize") + ("\\rm") ("\\bf") ("\\it") ("\\sl") + ("\\roman") ("\\bold") ("\\italic") ("\\slanted") + ("\\cal") ("\\mit") ("\\Cal") ("\\Bbb") ("\\frak") ("\\goth") + ("\\evalto") + ("\\matrix" mat) ("\\bmatrix" mat) ("\\pmatrix" mat) + ("\\cr" punc ";") ("\\\\" punc ";") ("\\*" punc "*") + ("\\{" punc "[") ("\\}" punc "]") +)) + +(defconst math-eqn-ignore-words + '( ("roman") ("bold") ("italic") ("mark") ("lineup") ("evalto") + ("left" ("floor") ("ceil")) + ("right" ("floor") ("ceil")) + ("arc" ("sin") ("cos") ("tan") ("sinh") ("cosh") ("tanh")) + ("size" n) ("font" n) ("fwd" n) ("back" n) ("up" n) ("down" n) + ("above" punc ",") +)) + +(defconst math-standard-opers + '( ( "_" calcFunc-subscr 1200 1201 ) + ( "%" calcFunc-percent 1100 -1 ) + ( "u+" ident -1 1000 ) + ( "u-" neg -1 1000 197 ) + ( "u!" calcFunc-lnot -1 1000 ) + ( "mod" mod 400 400 185 ) + ( "+/-" sdev 300 300 185 ) + ( "!!" calcFunc-dfact 210 -1 ) + ( "!" calcFunc-fact 210 -1 ) + ( "^" ^ 201 200 ) + ( "**" ^ 201 200 ) + ( "*" * 196 195 ) + ( "2x" * 196 195 ) + ( "/" / 190 191 ) + ( "%" % 190 191 ) + ( "\\" calcFunc-idiv 190 191 ) + ( "+" + 180 181 ) + ( "-" - 180 181 ) + ( "|" | 170 171 ) + ( "<" calcFunc-lt 160 161 ) + ( ">" calcFunc-gt 160 161 ) + ( "<=" calcFunc-leq 160 161 ) + ( ">=" calcFunc-geq 160 161 ) + ( "=" calcFunc-eq 160 161 ) + ( "==" calcFunc-eq 160 161 ) + ( "!=" calcFunc-neq 160 161 ) + ( "&&" calcFunc-land 110 111 ) + ( "||" calcFunc-lor 100 101 ) + ( "?" (math-read-if) 91 90 ) + ( "!!!" calcFunc-pnot -1 85 ) + ( "&&&" calcFunc-pand 80 81 ) + ( "|||" calcFunc-por 75 76 ) + ( ":=" calcFunc-assign 51 50 ) + ( "::" calcFunc-condition 45 46 ) + ( "=>" calcFunc-evalto 40 41 ) + ( "=>" calcFunc-evalto 40 -1 ) +)) +(setq math-expr-opers math-standard-opers) + + +;;;###autoload +(defun calc-grab-region (top bot arg) + "Parse the region as a vector of numbers and push it on the Calculator stack." + (interactive "r\nP") + (calc-extensions) + (calc-do-grab-region top bot arg) +) + +;;;###autoload +(defun calc-grab-rectangle (top bot arg) + "Parse a rectangle as a matrix of numbers and push it on the Calculator stack." + (interactive "r\nP") + (calc-extensions) + (calc-do-grab-rectangle top bot arg) +) + +(defun calc-grab-sum-down (top bot arg) + "Parse a rectangle as a matrix of numbers and sum its columns." + (interactive "r\nP") + (calc-extensions) + (calc-do-grab-rectangle top bot arg 'calcFunc-reduced) +) + +(defun calc-grab-sum-across (top bot arg) + "Parse a rectangle as a matrix of numbers and sum its rows." + (interactive "r\nP") + (calc-extensions) + (calc-do-grab-rectangle top bot arg 'calcFunc-reducea) +) + + +;;;###autoload +(defun calc-embedded (arg &optional end obeg oend) + "Start Calc Embedded mode on the formula surrounding point." + (interactive "P") + (calc-extensions) + (calc-do-embedded arg end obeg oend) +) + +;;;###autoload +(defun calc-embedded-activate (&optional arg cbuf) + "Scan the current editing buffer for all embedded := and => formulas. +Also looks for the equivalent TeX words, \\gets and \\evalto." + (interactive "P") + (calc-do-embedded-activate arg cbuf) +) + + +(defun calc-user-invocation () + (interactive) + (or (stringp calc-invocation-macro) + (error "Use `Z I' inside Calc to define a `M-# Z' keyboard macro")) + (execute-kbd-macro calc-invocation-macro nil) +) + + + + +;;; User-programmability. + +;;;###autoload +(defmacro defmath (func args &rest body) ; [Public] + (calc-extensions) + (math-do-defmath func args body) +) + + +;;; Functions needed for Lucid Emacs support. + +(defun calc-read-key (&optional optkey) + (cond (calc-emacs-type-lucid + (let ((event (next-command-event))) + (let ((key (event-to-character event t t))) + (or key optkey (error "Expected a plain keystroke")) + (cons key event)))) + (calc-emacs-type-gnu19 + (let ((key (read-event))) + (cons key key))) + (t + (let ((key (read-char))) + (cons key key)))) +) + +(defun calc-unread-command (&optional input) + (cond (calc-emacs-type-gnu19 + (setq unread-command-events (cons (or input last-command-event) + unread-command-events))) + (calc-emacs-type-lucid + (setq unread-command-event + (if (integerp input) (character-to-event input) + (or input last-command-event)))) + (t + (setq unread-command-char (or input last-command-char)))) +) + +(defun calc-clear-unread-commands () + (cond (calc-emacs-type-gnu19 (setq unread-command-events nil)) + (calc-emacs-type-lucid (setq unread-command-event nil)) + (t (setq unread-command-char -1))) +) + +(if calc-always-load-extensions + (progn + (calc-extensions) + (calc-load-everything)) +) + + +(run-hooks 'calc-load-hook) + + diff --git a/lisp/calc/calcalg2.el b/lisp/calc/calcalg2.el new file mode 100644 index 0000000000..d748c98fe1 --- /dev/null +++ b/lisp/calc/calcalg2.el @@ -0,0 +1,3507 @@ +;; Calculator for GNU Emacs, part II [calc-alg-2.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-alg-2 () nil) + + +(defun calc-derivative (var num) + (interactive "sDifferentiate with respect to: \np") + (calc-slow-wrapper + (and (< num 0) (error "Order of derivative must be positive")) + (let ((func (if (calc-is-hyperbolic) 'calcFunc-tderiv 'calcFunc-deriv)) + n expr) + (if (or (equal var "") (equal var "$")) + (setq n 2 + expr (calc-top-n 2) + var (calc-top-n 1)) + (setq var (math-read-expr var)) + (if (eq (car-safe var) 'error) + (error "Bad format in expression: %s" (nth 1 var))) + (setq n 1 + expr (calc-top-n 1))) + (while (>= (setq num (1- num)) 0) + (setq expr (list func expr var))) + (calc-enter-result n "derv" expr))) +) + +(defun calc-integral (var) + (interactive "sIntegration variable: ") + (calc-slow-wrapper + (if (or (equal var "") (equal var "$")) + (calc-enter-result 2 "intg" (list 'calcFunc-integ + (calc-top-n 2) + (calc-top-n 1))) + (let ((var (math-read-expr var))) + (if (eq (car-safe var) 'error) + (error "Bad format in expression: %s" (nth 1 var))) + (calc-enter-result 1 "intg" (list 'calcFunc-integ + (calc-top-n 1) + var))))) +) + +(defun calc-num-integral (&optional varname lowname highname) + (interactive "sIntegration variable: ") + (calc-tabular-command 'calcFunc-ninteg "Integration" "nint" + nil varname lowname highname) +) + +(defun calc-summation (arg &optional varname lowname highname) + (interactive "P\nsSummation variable: ") + (calc-tabular-command 'calcFunc-sum "Summation" "sum" + arg varname lowname highname) +) + +(defun calc-alt-summation (arg &optional varname lowname highname) + (interactive "P\nsSummation variable: ") + (calc-tabular-command 'calcFunc-asum "Summation" "asum" + arg varname lowname highname) +) + +(defun calc-product (arg &optional varname lowname highname) + (interactive "P\nsIndex variable: ") + (calc-tabular-command 'calcFunc-prod "Index" "prod" + arg varname lowname highname) +) + +(defun calc-tabulate (arg &optional varname lowname highname) + (interactive "P\nsIndex variable: ") + (calc-tabular-command 'calcFunc-table "Index" "tabl" + arg varname lowname highname) +) + +(defun calc-tabular-command (func prompt prefix arg varname lowname highname) + (calc-slow-wrapper + (let (var (low nil) (high nil) (step nil) stepname stepnum (num 1) expr) + (if (consp arg) + (setq stepnum 1) + (setq stepnum 0)) + (if (or (equal varname "") (equal varname "$") (null varname)) + (setq high (calc-top-n (+ stepnum 1)) + low (calc-top-n (+ stepnum 2)) + var (calc-top-n (+ stepnum 3)) + num (+ stepnum 4)) + (setq var (if (stringp varname) (math-read-expr varname) varname)) + (if (eq (car-safe var) 'error) + (error "Bad format in expression: %s" (nth 1 var))) + (or lowname + (setq lowname (read-string (concat prompt " variable: " varname + ", from: ")))) + (if (or (equal lowname "") (equal lowname "$")) + (setq high (calc-top-n (+ stepnum 1)) + low (calc-top-n (+ stepnum 2)) + num (+ stepnum 3)) + (setq low (if (stringp lowname) (math-read-expr lowname) lowname)) + (if (eq (car-safe low) 'error) + (error "Bad format in expression: %s" (nth 1 low))) + (or highname + (setq highname (read-string (concat prompt " variable: " varname + ", from: " lowname + ", to: ")))) + (if (or (equal highname "") (equal highname "$")) + (setq high (calc-top-n (+ stepnum 1)) + num (+ stepnum 2)) + (setq high (if (stringp highname) (math-read-expr highname) + highname)) + (if (eq (car-safe high) 'error) + (error "Bad format in expression: %s" (nth 1 high))) + (if (consp arg) + (progn + (setq stepname (read-string (concat prompt " variable: " + varname + ", from: " lowname + ", to: " highname + ", step: "))) + (if (or (equal stepname "") (equal stepname "$")) + (setq step (calc-top-n 1) + num 2) + (setq step (math-read-expr stepname)) + (if (eq (car-safe step) 'error) + (error "Bad format in expression: %s" + (nth 1 step))))))))) + (or step + (if (consp arg) + (setq step (calc-top-n 1)) + (if arg + (setq step (prefix-numeric-value arg))))) + (setq expr (calc-top-n num)) + (calc-enter-result num prefix (append (list func expr var low high) + (and step (list step)))))) +) + +(defun calc-solve-for (var) + (interactive "sVariable to solve for: ") + (calc-slow-wrapper + (let ((func (if (calc-is-inverse) + (if (calc-is-hyperbolic) 'calcFunc-ffinv 'calcFunc-finv) + (if (calc-is-hyperbolic) 'calcFunc-fsolve 'calcFunc-solve)))) + (if (or (equal var "") (equal var "$")) + (calc-enter-result 2 "solv" (list func + (calc-top-n 2) + (calc-top-n 1))) + (let ((var (if (and (string-match ",\\|[^ ] +[^ ]" var) + (not (string-match "\\[" var))) + (math-read-expr (concat "[" var "]")) + (math-read-expr var)))) + (if (eq (car-safe var) 'error) + (error "Bad format in expression: %s" (nth 1 var))) + (calc-enter-result 1 "solv" (list func + (calc-top-n 1) + var)))))) +) + +(defun calc-poly-roots (var) + (interactive "sVariable to solve for: ") + (calc-slow-wrapper + (if (or (equal var "") (equal var "$")) + (calc-enter-result 2 "prts" (list 'calcFunc-roots + (calc-top-n 2) + (calc-top-n 1))) + (let ((var (if (and (string-match ",\\|[^ ] +[^ ]" var) + (not (string-match "\\[" var))) + (math-read-expr (concat "[" var "]")) + (math-read-expr var)))) + (if (eq (car-safe var) 'error) + (error "Bad format in expression: %s" (nth 1 var))) + (calc-enter-result 1 "prts" (list 'calcFunc-roots + (calc-top-n 1) + var))))) +) + +(defun calc-taylor (var nterms) + (interactive "sTaylor expansion variable: \nNNumber of terms: ") + (calc-slow-wrapper + (let ((var (math-read-expr var))) + (if (eq (car-safe var) 'error) + (error "Bad format in expression: %s" (nth 1 var))) + (calc-enter-result 1 "tylr" (list 'calcFunc-taylor + (calc-top-n 1) + var + (prefix-numeric-value nterms))))) +) + + +(defun math-derivative (expr) ; uses global values: deriv-var, deriv-total. + (cond ((equal expr deriv-var) + 1) + ((or (Math-scalarp expr) + (eq (car expr) 'sdev) + (and (eq (car expr) 'var) + (or (not deriv-total) + (math-const-var expr) + (progn + (math-setup-declarations) + (memq 'const (nth 1 (or (assq (nth 2 expr) + math-decls-cache) + math-decls-all))))))) + 0) + ((eq (car expr) '+) + (math-add (math-derivative (nth 1 expr)) + (math-derivative (nth 2 expr)))) + ((eq (car expr) '-) + (math-sub (math-derivative (nth 1 expr)) + (math-derivative (nth 2 expr)))) + ((memq (car expr) '(calcFunc-eq calcFunc-neq calcFunc-lt + calcFunc-gt calcFunc-leq calcFunc-geq)) + (list (car expr) + (math-derivative (nth 1 expr)) + (math-derivative (nth 2 expr)))) + ((eq (car expr) 'neg) + (math-neg (math-derivative (nth 1 expr)))) + ((eq (car expr) '*) + (math-add (math-mul (nth 2 expr) + (math-derivative (nth 1 expr))) + (math-mul (nth 1 expr) + (math-derivative (nth 2 expr))))) + ((eq (car expr) '/) + (math-sub (math-div (math-derivative (nth 1 expr)) + (nth 2 expr)) + (math-div (math-mul (nth 1 expr) + (math-derivative (nth 2 expr))) + (math-sqr (nth 2 expr))))) + ((eq (car expr) '^) + (let ((du (math-derivative (nth 1 expr))) + (dv (math-derivative (nth 2 expr)))) + (or (Math-zerop du) + (setq du (math-mul (nth 2 expr) + (math-mul (math-normalize + (list '^ + (nth 1 expr) + (math-add (nth 2 expr) -1))) + du)))) + (or (Math-zerop dv) + (setq dv (math-mul (math-normalize + (list 'calcFunc-ln (nth 1 expr))) + (math-mul expr dv)))) + (math-add du dv))) + ((eq (car expr) '%) + (math-derivative (nth 1 expr))) ; a reasonable definition + ((eq (car expr) 'vec) + (math-map-vec 'math-derivative expr)) + ((and (memq (car expr) '(calcFunc-conj calcFunc-re calcFunc-im)) + (= (length expr) 2)) + (list (car expr) (math-derivative (nth 1 expr)))) + ((and (memq (car expr) '(calcFunc-subscr calcFunc-mrow calcFunc-mcol)) + (= (length expr) 3)) + (let ((d (math-derivative (nth 1 expr)))) + (if (math-numberp d) + 0 ; assume x and x_1 are independent vars + (list (car expr) d (nth 2 expr))))) + (t (or (and (symbolp (car expr)) + (if (= (length expr) 2) + (let ((handler (get (car expr) 'math-derivative))) + (and handler + (let ((deriv (math-derivative (nth 1 expr)))) + (if (Math-zerop deriv) + deriv + (math-mul (funcall handler (nth 1 expr)) + deriv))))) + (let ((handler (get (car expr) 'math-derivative-n))) + (and handler + (funcall handler expr))))) + (and (not (eq deriv-symb 'pre-expand)) + (let ((exp (math-expand-formula expr))) + (and exp + (or (let ((deriv-symb 'pre-expand)) + (catch 'math-deriv (math-derivative expr))) + (math-derivative exp))))) + (if (or (Math-objvecp expr) + (eq (car expr) 'var) + (not (symbolp (car expr)))) + (if deriv-symb + (throw 'math-deriv nil) + (list (if deriv-total 'calcFunc-tderiv 'calcFunc-deriv) + expr + deriv-var)) + (let ((accum 0) + (arg expr) + (n 1) + derv) + (while (setq arg (cdr arg)) + (or (Math-zerop (setq derv (math-derivative (car arg)))) + (let ((func (intern (concat (symbol-name (car expr)) + "'" + (if (> n 1) + (int-to-string n) + "")))) + (prop (cond ((= (length expr) 2) + 'math-derivative-1) + ((= (length expr) 3) + 'math-derivative-2) + ((= (length expr) 4) + 'math-derivative-3) + ((= (length expr) 5) + 'math-derivative-4) + ((= (length expr) 6) + 'math-derivative-5)))) + (setq accum + (math-add + accum + (math-mul + derv + (let ((handler (get func prop))) + (or (and prop handler + (apply handler (cdr expr))) + (if (and deriv-symb + (not (get func + 'calc-user-defn))) + (throw 'math-deriv nil) + (cons func (cdr expr)))))))))) + (setq n (1+ n))) + accum))))) +) + +(defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb) + (let* ((deriv-total nil) + (res (catch 'math-deriv (math-derivative expr)))) + (or (eq (car-safe res) 'calcFunc-deriv) + (null res) + (setq res (math-normalize res))) + (and res + (if deriv-value + (math-expr-subst res deriv-var deriv-value) + res))) +) + +(defun calcFunc-tderiv (expr deriv-var &optional deriv-value deriv-symb) + (math-setup-declarations) + (let* ((deriv-total t) + (res (catch 'math-deriv (math-derivative expr)))) + (or (eq (car-safe res) 'calcFunc-tderiv) + (null res) + (setq res (math-normalize res))) + (and res + (if deriv-value + (math-expr-subst res deriv-var deriv-value) + res))) +) + +(put 'calcFunc-inv\' 'math-derivative-1 + (function (lambda (u) (math-neg (math-div 1 (math-sqr u)))))) + +(put 'calcFunc-sqrt\' 'math-derivative-1 + (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u)))))) + +(put 'calcFunc-deg\' 'math-derivative-1 + (function (lambda (u) (math-div-float '(float 18 1) (math-pi))))) + +(put 'calcFunc-rad\' 'math-derivative-1 + (function (lambda (u) (math-pi-over-180)))) + +(put 'calcFunc-ln\' 'math-derivative-1 + (function (lambda (u) (math-div 1 u)))) + +(put 'calcFunc-log10\' 'math-derivative-1 + (function (lambda (u) + (math-div (math-div 1 (math-normalize '(calcFunc-ln 10))) + u)))) + +(put 'calcFunc-lnp1\' 'math-derivative-1 + (function (lambda (u) (math-div 1 (math-add u 1))))) + +(put 'calcFunc-log\' 'math-derivative-2 + (function (lambda (x b) + (and (not (Math-zerop b)) + (let ((lnv (math-normalize + (list 'calcFunc-ln b)))) + (math-div 1 (math-mul lnv x))))))) + +(put 'calcFunc-log\'2 'math-derivative-2 + (function (lambda (x b) + (let ((lnv (list 'calcFunc-ln b))) + (math-neg (math-div (list 'calcFunc-log x b) + (math-mul lnv b))))))) + +(put 'calcFunc-exp\' 'math-derivative-1 + (function (lambda (u) (math-normalize (list 'calcFunc-exp u))))) + +(put 'calcFunc-expm1\' 'math-derivative-1 + (function (lambda (u) (math-normalize (list 'calcFunc-expm1 u))))) + +(put 'calcFunc-sin\' 'math-derivative-1 + (function (lambda (u) (math-to-radians-2 (math-normalize + (list 'calcFunc-cos u)))))) + +(put 'calcFunc-cos\' 'math-derivative-1 + (function (lambda (u) (math-neg (math-to-radians-2 + (math-normalize + (list 'calcFunc-sin u))))))) + +(put 'calcFunc-tan\' 'math-derivative-1 + (function (lambda (u) (math-to-radians-2 + (math-div 1 (math-sqr + (math-normalize + (list 'calcFunc-cos u)))))))) + +(put 'calcFunc-arcsin\' 'math-derivative-1 + (function (lambda (u) + (math-from-radians-2 + (math-div 1 (math-normalize + (list 'calcFunc-sqrt + (math-sub 1 (math-sqr u))))))))) + +(put 'calcFunc-arccos\' 'math-derivative-1 + (function (lambda (u) + (math-from-radians-2 + (math-div -1 (math-normalize + (list 'calcFunc-sqrt + (math-sub 1 (math-sqr u))))))))) + +(put 'calcFunc-arctan\' 'math-derivative-1 + (function (lambda (u) (math-from-radians-2 + (math-div 1 (math-add 1 (math-sqr u))))))) + +(put 'calcFunc-sinh\' 'math-derivative-1 + (function (lambda (u) (math-normalize (list 'calcFunc-cosh u))))) + +(put 'calcFunc-cosh\' 'math-derivative-1 + (function (lambda (u) (math-normalize (list 'calcFunc-sinh u))))) + +(put 'calcFunc-tanh\' 'math-derivative-1 + (function (lambda (u) (math-div 1 (math-sqr + (math-normalize + (list 'calcFunc-cosh u))))))) + +(put 'calcFunc-arcsinh\' 'math-derivative-1 + (function (lambda (u) + (math-div 1 (math-normalize + (list 'calcFunc-sqrt + (math-add (math-sqr u) 1))))))) + +(put 'calcFunc-arccosh\' 'math-derivative-1 + (function (lambda (u) + (math-div 1 (math-normalize + (list 'calcFunc-sqrt + (math-add (math-sqr u) -1))))))) + +(put 'calcFunc-arctanh\' 'math-derivative-1 + (function (lambda (u) (math-div 1 (math-sub 1 (math-sqr u)))))) + +(put 'calcFunc-bern\'2 'math-derivative-2 + (function (lambda (n x) + (math-mul n (list 'calcFunc-bern (math-add n -1) x))))) + +(put 'calcFunc-euler\'2 'math-derivative-2 + (function (lambda (n x) + (math-mul n (list 'calcFunc-euler (math-add n -1) x))))) + +(put 'calcFunc-gammag\'2 'math-derivative-2 + (function (lambda (a x) (math-deriv-gamma a x 1)))) + +(put 'calcFunc-gammaG\'2 'math-derivative-2 + (function (lambda (a x) (math-deriv-gamma a x -1)))) + +(put 'calcFunc-gammaP\'2 'math-derivative-2 + (function (lambda (a x) (math-deriv-gamma a x + (math-div + 1 (math-normalize + (list 'calcFunc-gamma + a))))))) + +(put 'calcFunc-gammaQ\'2 'math-derivative-2 + (function (lambda (a x) (math-deriv-gamma a x + (math-div + -1 (math-normalize + (list 'calcFunc-gamma + a))))))) + +(defun math-deriv-gamma (a x scale) + (math-mul scale + (math-mul (math-pow x (math-add a -1)) + (list 'calcFunc-exp (math-neg x)))) +) + +(put 'calcFunc-betaB\' 'math-derivative-3 + (function (lambda (x a b) (math-deriv-beta x a b 1)))) + +(put 'calcFunc-betaI\' 'math-derivative-3 + (function (lambda (x a b) (math-deriv-beta x a b + (math-div + 1 (list 'calcFunc-beta + a b)))))) + +(defun math-deriv-beta (x a b scale) + (math-mul (math-mul (math-pow x (math-add a -1)) + (math-pow (math-sub 1 x) (math-add b -1))) + scale) +) + +(put 'calcFunc-erf\' 'math-derivative-1 + (function (lambda (x) (math-div 2 + (math-mul (list 'calcFunc-exp + (math-sqr x)) + (if calc-symbolic-mode + '(calcFunc-sqrt + (var pi var-pi)) + (math-sqrt-pi))))))) + +(put 'calcFunc-erfc\' 'math-derivative-1 + (function (lambda (x) (math-div -2 + (math-mul (list 'calcFunc-exp + (math-sqr x)) + (if calc-symbolic-mode + '(calcFunc-sqrt + (var pi var-pi)) + (math-sqrt-pi))))))) + +(put 'calcFunc-besJ\'2 'math-derivative-2 + (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besJ + (math-add v -1) + z) + (list 'calcFunc-besJ + (math-add v 1) + z)) + 2)))) + +(put 'calcFunc-besY\'2 'math-derivative-2 + (function (lambda (v z) (math-div (math-sub (list 'calcFunc-besY + (math-add v -1) + z) + (list 'calcFunc-besY + (math-add v 1) + z)) + 2)))) + +(put 'calcFunc-sum 'math-derivative-n + (function + (lambda (expr) + (if (math-expr-contains (cons 'vec (cdr (cdr expr))) deriv-var) + (throw 'math-deriv nil) + (cons 'calcFunc-sum + (cons (math-derivative (nth 1 expr)) + (cdr (cdr expr)))))))) + +(put 'calcFunc-prod 'math-derivative-n + (function + (lambda (expr) + (if (math-expr-contains (cons 'vec (cdr (cdr expr))) deriv-var) + (throw 'math-deriv nil) + (math-mul expr + (cons 'calcFunc-sum + (cons (math-div (math-derivative (nth 1 expr)) + (nth 1 expr)) + (cdr (cdr expr))))))))) + +(put 'calcFunc-integ 'math-derivative-n + (function + (lambda (expr) + (if (= (length expr) 3) + (if (equal (nth 2 expr) deriv-var) + (nth 1 expr) + (math-normalize + (list 'calcFunc-integ + (math-derivative (nth 1 expr)) + (nth 2 expr)))) + (if (= (length expr) 5) + (let ((lower (math-expr-subst (nth 1 expr) (nth 2 expr) + (nth 3 expr))) + (upper (math-expr-subst (nth 1 expr) (nth 2 expr) + (nth 4 expr)))) + (math-add (math-sub (math-mul upper + (math-derivative (nth 4 expr))) + (math-mul lower + (math-derivative (nth 3 expr)))) + (if (equal (nth 2 expr) deriv-var) + 0 + (math-normalize + (list 'calcFunc-integ + (math-derivative (nth 1 expr)) (nth 2 expr) + (nth 3 expr) (nth 4 expr))))))))))) + +(put 'calcFunc-if 'math-derivative-n + (function + (lambda (expr) + (and (= (length expr) 4) + (list 'calcFunc-if (nth 1 expr) + (math-derivative (nth 2 expr)) + (math-derivative (nth 3 expr))))))) + +(put 'calcFunc-subscr 'math-derivative-n + (function + (lambda (expr) + (and (= (length expr) 3) + (list 'calcFunc-subscr (nth 1 expr) + (math-derivative (nth 2 expr))))))) + + + + + +(setq math-integ-var '(var X ---)) +(setq math-integ-var-2 '(var Y ---)) +(setq math-integ-vars (list 'f math-integ-var math-integ-var-2)) +(setq math-integ-var-list (list math-integ-var)) +(setq math-integ-var-list-list (list math-integ-var-list)) + +(defmacro math-tracing-integral (&rest parts) + (list 'and + 'trace-buffer + (list 'save-excursion + '(set-buffer trace-buffer) + '(goto-char (point-max)) + (list 'and + '(bolp) + '(insert (make-string (- math-integral-limit + math-integ-level) 32) + (format "%2d " math-integ-depth) + (make-string math-integ-level 32))) + ;;(list 'condition-case 'err + (cons 'insert parts) + ;; '(error (insert (prin1-to-string err)))) + '(sit-for 0))) +) + +;;; The following wrapper caches results and avoids infinite recursion. +;;; Each cache entry is: ( A B ) Integral of A is B; +;;; ( A N ) Integral of A failed at level N; +;;; ( A busy ) Currently working on integral of A; +;;; ( A parts ) Currently working, integ-by-parts; +;;; ( A parts2 ) Currently working, integ-by-parts; +;;; ( A cancelled ) Ignore this cache entry; +;;; ( A [B] ) Same result as for cur-record = B. +(defun math-integral (expr &optional simplify same-as-above) + (let* ((simp cur-record) + (cur-record (assoc expr math-integral-cache)) + (math-integ-depth (1+ math-integ-depth)) + (val 'cancelled)) + (math-tracing-integral "Integrating " + (math-format-value expr 1000) + "...\n") + (and cur-record + (progn + (math-tracing-integral "Found " + (math-format-value (nth 1 cur-record) 1000)) + (and (consp (nth 1 cur-record)) + (math-replace-integral-parts cur-record)) + (math-tracing-integral " => " + (math-format-value (nth 1 cur-record) 1000) + "\n"))) + (or (and cur-record + (not (eq (nth 1 cur-record) 'cancelled)) + (or (not (integerp (nth 1 cur-record))) + (>= (nth 1 cur-record) math-integ-level))) + (and (math-integral-contains-parts expr) + (progn + (setq val nil) + t)) + (unwind-protect + (progn + (let (math-integ-msg) + (if (eq calc-display-working-message 'lots) + (progn + (calc-set-command-flag 'clear-message) + (setq math-integ-msg (format + "Working... Integrating %s" + (math-format-flat-expr expr 0))) + (message math-integ-msg))) + (if cur-record + (setcar (cdr cur-record) + (if same-as-above (vector simp) 'busy)) + (setq cur-record + (list expr (if same-as-above (vector simp) 'busy)) + math-integral-cache (cons cur-record + math-integral-cache))) + (if (eq simplify 'yes) + (progn + (math-tracing-integral "Simplifying...") + (setq simp (math-simplify expr)) + (setq val (if (equal simp expr) + (progn + (math-tracing-integral " no change\n") + (math-do-integral expr)) + (math-tracing-integral " simplified\n") + (math-integral simp 'no t)))) + (or (setq val (math-do-integral expr)) + (eq simplify 'no) + (let ((simp (math-simplify expr))) + (or (equal simp expr) + (progn + (math-tracing-integral "Trying again after " + "simplification...\n") + (setq val (math-integral simp 'no t)))))))) + (if (eq calc-display-working-message 'lots) + (message math-integ-msg))) + (setcar (cdr cur-record) (or val + (if (or math-enable-subst + (not math-any-substs)) + math-integ-level + 'cancelled))))) + (setq val cur-record) + (while (vectorp (nth 1 val)) + (setq val (aref (nth 1 val) 0))) + (setq val (if (memq (nth 1 val) '(parts parts2)) + (progn + (setcar (cdr val) 'parts2) + (list 'var 'PARTS val)) + (and (consp (nth 1 val)) + (nth 1 val)))) + (math-tracing-integral "Integral of " + (math-format-value expr 1000) + " is " + (math-format-value val 1000) + "\n") + val) +) +(defvar math-integral-cache nil) +(defvar math-integral-cache-state nil) + +(defun math-integral-contains-parts (expr) + (if (Math-primp expr) + (and (eq (car-safe expr) 'var) + (eq (nth 1 expr) 'PARTS) + (listp (nth 2 expr))) + (while (and (setq expr (cdr expr)) + (not (math-integral-contains-parts (car expr))))) + expr) +) + +(defun math-replace-integral-parts (expr) + (or (Math-primp expr) + (while (setq expr (cdr expr)) + (and (consp (car expr)) + (if (eq (car (car expr)) 'var) + (and (eq (nth 1 (car expr)) 'PARTS) + (consp (nth 2 (car expr))) + (if (listp (nth 1 (nth 2 (car expr)))) + (progn + (setcar expr (nth 1 (nth 2 (car expr)))) + (math-replace-integral-parts (cons 'foo expr))) + (setcar (cdr cur-record) 'cancelled))) + (math-replace-integral-parts (car expr)))))) +) + +(defun math-do-integral (expr) + (let (t1 t2) + (or (cond ((not (math-expr-contains expr math-integ-var)) + (math-mul expr math-integ-var)) + ((equal expr math-integ-var) + (math-div (math-sqr expr) 2)) + ((eq (car expr) '+) + (and (setq t1 (math-integral (nth 1 expr))) + (setq t2 (math-integral (nth 2 expr))) + (math-add t1 t2))) + ((eq (car expr) '-) + (and (setq t1 (math-integral (nth 1 expr))) + (setq t2 (math-integral (nth 2 expr))) + (math-sub t1 t2))) + ((eq (car expr) 'neg) + (and (setq t1 (math-integral (nth 1 expr))) + (math-neg t1))) + ((eq (car expr) '*) + (cond ((not (math-expr-contains (nth 1 expr) math-integ-var)) + (and (setq t1 (math-integral (nth 2 expr))) + (math-mul (nth 1 expr) t1))) + ((not (math-expr-contains (nth 2 expr) math-integ-var)) + (and (setq t1 (math-integral (nth 1 expr))) + (math-mul t1 (nth 2 expr)))) + ((memq (car-safe (nth 1 expr)) '(+ -)) + (math-integral (list (car (nth 1 expr)) + (math-mul (nth 1 (nth 1 expr)) + (nth 2 expr)) + (math-mul (nth 2 (nth 1 expr)) + (nth 2 expr))) + 'yes t)) + ((memq (car-safe (nth 2 expr)) '(+ -)) + (math-integral (list (car (nth 2 expr)) + (math-mul (nth 1 (nth 2 expr)) + (nth 1 expr)) + (math-mul (nth 2 (nth 2 expr)) + (nth 1 expr))) + 'yes t)))) + ((eq (car expr) '/) + (cond ((and (not (math-expr-contains (nth 1 expr) + math-integ-var)) + (not (math-equal-int (nth 1 expr) 1))) + (and (setq t1 (math-integral (math-div 1 (nth 2 expr)))) + (math-mul (nth 1 expr) t1))) + ((not (math-expr-contains (nth 2 expr) math-integ-var)) + (and (setq t1 (math-integral (nth 1 expr))) + (math-div t1 (nth 2 expr)))) + ((and (eq (car-safe (nth 1 expr)) '*) + (not (math-expr-contains (nth 1 (nth 1 expr)) + math-integ-var))) + (and (setq t1 (math-integral + (math-div (nth 2 (nth 1 expr)) + (nth 2 expr)))) + (math-mul t1 (nth 1 (nth 1 expr))))) + ((and (eq (car-safe (nth 1 expr)) '*) + (not (math-expr-contains (nth 2 (nth 1 expr)) + math-integ-var))) + (and (setq t1 (math-integral + (math-div (nth 1 (nth 1 expr)) + (nth 2 expr)))) + (math-mul t1 (nth 2 (nth 1 expr))))) + ((and (eq (car-safe (nth 2 expr)) '*) + (not (math-expr-contains (nth 1 (nth 2 expr)) + math-integ-var))) + (and (setq t1 (math-integral + (math-div (nth 1 expr) + (nth 2 (nth 2 expr))))) + (math-div t1 (nth 1 (nth 2 expr))))) + ((and (eq (car-safe (nth 2 expr)) '*) + (not (math-expr-contains (nth 2 (nth 2 expr)) + math-integ-var))) + (and (setq t1 (math-integral + (math-div (nth 1 expr) + (nth 1 (nth 2 expr))))) + (math-div t1 (nth 2 (nth 2 expr))))) + ((eq (car-safe (nth 2 expr)) 'calcFunc-exp) + (math-integral + (math-mul (nth 1 expr) + (list 'calcFunc-exp + (math-neg (nth 1 (nth 2 expr))))))))) + ((eq (car expr) '^) + (cond ((not (math-expr-contains (nth 1 expr) math-integ-var)) + (or (and (setq t1 (math-is-polynomial (nth 2 expr) + math-integ-var 1)) + (math-div expr + (math-mul (nth 1 t1) + (math-normalize + (list 'calcFunc-ln + (nth 1 expr)))))) + (math-integral + (list 'calcFunc-exp + (math-mul (nth 2 expr) + (math-normalize + (list 'calcFunc-ln + (nth 1 expr))))) + 'yes t))) + ((not (math-expr-contains (nth 2 expr) math-integ-var)) + (if (and (integerp (nth 2 expr)) (< (nth 2 expr) 0)) + (math-integral + (list '/ 1 (math-pow (nth 1 expr) (- (nth 2 expr)))) + nil t) + (or (and (setq t1 (math-is-polynomial (nth 1 expr) + math-integ-var + 1)) + (setq t2 (math-add (nth 2 expr) 1)) + (math-div (math-pow (nth 1 expr) t2) + (math-mul t2 (nth 1 t1)))) + (and (Math-negp (nth 2 expr)) + (math-integral + (math-div 1 + (math-pow (nth 1 expr) + (math-neg + (nth 2 expr)))) + nil t)) + nil)))))) + + ;; Integral of a polynomial. + (and (setq t1 (math-is-polynomial expr math-integ-var 20)) + (let ((accum 0) + (n 1)) + (while t1 + (if (setq accum (math-add accum + (math-div (math-mul (car t1) + (math-pow + math-integ-var + n)) + n)) + t1 (cdr t1)) + (setq n (1+ n)))) + accum)) + + ;; Try looking it up! + (cond ((= (length expr) 2) + (and (symbolp (car expr)) + (setq t1 (get (car expr) 'math-integral)) + (progn + (while (and t1 + (not (setq t2 (funcall (car t1) + (nth 1 expr))))) + (setq t1 (cdr t1))) + (and t2 (math-normalize t2))))) + ((= (length expr) 3) + (and (symbolp (car expr)) + (setq t1 (get (car expr) 'math-integral-2)) + (progn + (while (and t1 + (not (setq t2 (funcall (car t1) + (nth 1 expr) + (nth 2 expr))))) + (setq t1 (cdr t1))) + (and t2 (math-normalize t2)))))) + + ;; Integral of a rational function. + (and (math-ratpoly-p expr math-integ-var) + (setq t1 (calcFunc-apart expr math-integ-var)) + (not (equal t1 expr)) + (math-integral t1)) + + ;; Try user-defined integration rules. + (and has-rules + (let ((math-old-integ (symbol-function 'calcFunc-integ)) + (input (list 'calcFunc-integtry expr math-integ-var)) + res part) + (unwind-protect + (progn + (fset 'calcFunc-integ 'math-sub-integration) + (setq res (math-rewrite input + '(var IntegRules var-IntegRules) + 1)) + (fset 'calcFunc-integ math-old-integ) + (and (not (equal res input)) + (if (setq part (math-expr-calls + res '(calcFunc-integsubst))) + (and (memq (length part) '(3 4 5)) + (let ((parts (mapcar + (function + (lambda (x) + (math-expr-subst + x (nth 2 part) + math-integ-var))) + (cdr part)))) + (math-integrate-by-substitution + expr (car parts) t + (or (nth 2 parts) + (list 'calcFunc-integfailed + math-integ-var)) + (nth 3 parts)))) + (if (not (math-expr-calls res + '(calcFunc-integtry + calcFunc-integfailed))) + res)))) + (fset 'calcFunc-integ math-old-integ)))) + + ;; See if the function is a symbolic derivative. + (and (string-match "'" (symbol-name (car expr))) + (let ((name (symbol-name (car expr))) + (p expr) (n 0) (which nil) (bad nil)) + (while (setq n (1+ n) p (cdr p)) + (if (equal (car p) math-integ-var) + (if which (setq bad t) (setq which n)) + (if (math-expr-contains (car p) math-integ-var) + (setq bad t)))) + (and which (not bad) + (let ((prime (if (= which 1) "'" (format "'%d" which)))) + (and (string-match (concat prime "\\('['0-9]*\\|$\\)") + name) + (cons (intern + (concat + (substring name 0 (match-beginning 0)) + (substring name (+ (match-beginning 0) + (length prime))))) + (cdr expr))))))) + + ;; Try transformation methods (parts, substitutions). + (and (> math-integ-level 0) + (math-do-integral-methods expr)) + + ;; Try expanding the function's definition. + (let ((res (math-expand-formula expr))) + (and res + (math-integral res))))) +) + +(defun math-sub-integration (expr &rest rest) + (or (if (or (not rest) + (and (< math-integ-level math-integral-limit) + (eq (car rest) math-integ-var))) + (math-integral expr) + (let ((res (apply math-old-integ expr rest))) + (and (or (= math-integ-level math-integral-limit) + (not (math-expr-calls res 'calcFunc-integ))) + res))) + (list 'calcFunc-integfailed expr)) +) + +(defun math-do-integral-methods (expr) + (let ((so-far math-integ-var-list-list) + rat-in) + + ;; Integration by substitution, for various likely sub-expressions. + ;; (In first pass, we look only for sub-exprs that are linear in X.) + (or (if math-enable-subst + (math-integ-try-substitutions expr) + (math-integ-try-linear-substitutions expr)) + + ;; If function has sines and cosines, try tan(x/2) substitution. + (and (let ((p (setq rat-in (math-expr-rational-in expr)))) + (while (and p + (memq (car (car p)) '(calcFunc-sin + calcFunc-cos + calcFunc-tan)) + (equal (nth 1 (car p)) math-integ-var)) + (setq p (cdr p))) + (null p)) + (or (and (math-integ-parts-easy expr) + (math-integ-try-parts expr t)) + (math-integrate-by-good-substitution + expr (list 'calcFunc-tan (math-div math-integ-var 2))))) + + ;; If function has sinh and cosh, try tanh(x/2) substitution. + (and (let ((p rat-in)) + (while (and p + (memq (car (car p)) '(calcFunc-sinh + calcFunc-cosh + calcFunc-tanh + calcFunc-exp)) + (equal (nth 1 (car p)) math-integ-var)) + (setq p (cdr p))) + (null p)) + (or (and (math-integ-parts-easy expr) + (math-integ-try-parts expr t)) + (math-integrate-by-good-substitution + expr (list 'calcFunc-tanh (math-div math-integ-var 2))))) + + ;; If function has square roots, try sin, tan, or sec substitution. + (and (let ((p rat-in)) + (setq t1 nil) + (while (and p + (or (equal (car p) math-integ-var) + (and (eq (car (car p)) 'calcFunc-sqrt) + (setq t1 (math-is-polynomial + (nth 1 (setq t2 (car p))) + math-integ-var 2))))) + (setq p (cdr p))) + (and (null p) t1)) + (if (cdr (cdr t1)) + (if (math-guess-if-neg (nth 2 t1)) + (let* ((c (math-sqrt (math-neg (nth 2 t1)))) + (d (math-div (nth 1 t1) (math-mul -2 c))) + (a (math-sqrt (math-add (car t1) (math-sqr d))))) + (math-integrate-by-good-substitution + expr (list 'calcFunc-arcsin + (math-div-thru + (math-add (math-mul c math-integ-var) d) + a)))) + (let* ((c (math-sqrt (nth 2 t1))) + (d (math-div (nth 1 t1) (math-mul 2 c))) + (aa (math-sub (car t1) (math-sqr d)))) + (if (and nil (not (and (eq d 0) (eq c 1)))) + (math-integrate-by-good-substitution + expr (math-add (math-mul c math-integ-var) d)) + (if (math-guess-if-neg aa) + (math-integrate-by-good-substitution + expr (list 'calcFunc-arccosh + (math-div-thru + (math-add (math-mul c math-integ-var) + d) + (math-sqrt (math-neg aa))))) + (math-integrate-by-good-substitution + expr (list 'calcFunc-arcsinh + (math-div-thru + (math-add (math-mul c math-integ-var) + d) + (math-sqrt aa)))))))) + (math-integrate-by-good-substitution expr t2)) ) + + ;; Try integration by parts. + (math-integ-try-parts expr) + + ;; Give up. + nil)) +) + +(defun math-integ-parts-easy (expr) + (cond ((Math-primp expr) t) + ((memq (car expr) '(+ - *)) + (and (math-integ-parts-easy (nth 1 expr)) + (math-integ-parts-easy (nth 2 expr)))) + ((eq (car expr) '/) + (and (math-integ-parts-easy (nth 1 expr)) + (math-atomic-factorp (nth 2 expr)))) + ((eq (car expr) '^) + (and (natnump (nth 2 expr)) + (math-integ-parts-easy (nth 1 expr)))) + ((eq (car expr) 'neg) + (math-integ-parts-easy (nth 1 expr))) + (t t)) +) + +(defun math-integ-try-parts (expr &optional math-good-parts) + ;; Integration by parts: + ;; integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x) + ;; where h(x) = integ(g(x),x). + (or (let ((exp (calcFunc-expand expr))) + (and (not (equal exp expr)) + (math-integral exp))) + (and (eq (car expr) '*) + (let ((first-bad (or (math-polynomial-p (nth 1 expr) + math-integ-var) + (equal (nth 2 expr) math-prev-parts-v)))) + (or (and first-bad ; so try this one first + (math-integrate-by-parts (nth 1 expr) (nth 2 expr))) + (math-integrate-by-parts (nth 2 expr) (nth 1 expr)) + (and (not first-bad) + (math-integrate-by-parts (nth 1 expr) (nth 2 expr)))))) + (and (eq (car expr) '/) + (math-expr-contains (nth 1 expr) math-integ-var) + (let ((recip (math-div 1 (nth 2 expr)))) + (or (math-integrate-by-parts (nth 1 expr) recip) + (math-integrate-by-parts recip (nth 1 expr))))) + (and (eq (car expr) '^) + (math-integrate-by-parts (math-pow (nth 1 expr) + (math-sub (nth 2 expr) 1)) + (nth 1 expr)))) +) + +(defun math-integrate-by-parts (u vprime) + (let ((math-integ-level (if (or math-good-parts + (math-polynomial-p u math-integ-var)) + math-integ-level + (1- math-integ-level))) + (math-doing-parts t) + v temp) + (and (>= math-integ-level 0) + (unwind-protect + (progn + (setcar (cdr cur-record) 'parts) + (math-tracing-integral "Integrating by parts, u = " + (math-format-value u 1000) + ", v' = " + (math-format-value vprime 1000) + "\n") + (and (setq v (math-integral vprime)) + (setq temp (calcFunc-deriv u math-integ-var nil t)) + (setq temp (let ((math-prev-parts-v v)) + (math-integral (math-mul v temp) 'yes))) + (setq temp (math-sub (math-mul u v) temp)) + (if (eq (nth 1 cur-record) 'parts) + (calcFunc-expand temp) + (setq v (list 'var 'PARTS cur-record) + var-thing (list 'vec (math-sub v temp) v) + temp (let (calc-next-why) + (math-solve-for (math-sub v temp) 0 v nil))) + (and temp (not (integerp temp)) + (math-simplify-extended temp))))) + (setcar (cdr cur-record) 'busy)))) +) + +;;; This tries two different formulations, hoping the algebraic simplifier +;;; will be strong enough to handle at least one. +(defun math-integrate-by-substitution (expr u &optional user uinv uinvprime) + (and (> math-integ-level 0) + (let ((math-integ-level (max (- math-integ-level 2) 0))) + (math-integrate-by-good-substitution expr u user uinv uinvprime))) +) + +(defun math-integrate-by-good-substitution (expr u &optional user + uinv uinvprime) + (let ((math-living-dangerously t) + deriv temp) + (and (setq uinv (if uinv + (math-expr-subst uinv math-integ-var + math-integ-var-2) + (let (calc-next-why) + (math-solve-for u + math-integ-var-2 + math-integ-var nil)))) + (progn + (math-tracing-integral "Integrating by substitution, u = " + (math-format-value u 1000) + "\n") + (or (and (setq deriv (calcFunc-deriv u + math-integ-var nil + (not user))) + (setq temp (math-integral (math-expr-subst + (math-expr-subst + (math-expr-subst + (math-div expr deriv) + u + math-integ-var-2) + math-integ-var + uinv) + math-integ-var-2 + math-integ-var) + 'yes))) + (and (setq deriv (or uinvprime + (calcFunc-deriv uinv + math-integ-var-2 + math-integ-var + (not user)))) + (setq temp (math-integral (math-mul + (math-expr-subst + (math-expr-subst + (math-expr-subst + expr + u + math-integ-var-2) + math-integ-var + uinv) + math-integ-var-2 + math-integ-var) + deriv) + 'yes))))) + (math-simplify-extended + (math-expr-subst temp math-integ-var u)))) +) + +;;; Look for substitutions of the form u = a x + b. +(defun math-integ-try-linear-substitutions (sub-expr) + (and (not (Math-primp sub-expr)) + (or (and (not (memq (car sub-expr) '(+ - * / neg))) + (not (and (eq (car sub-expr) '^) + (integerp (nth 2 sub-expr)))) + (math-expr-contains sub-expr math-integ-var) + (let ((res nil)) + (while (and (setq sub-expr (cdr sub-expr)) + (or (not (math-linear-in (car sub-expr) + math-integ-var)) + (assoc (car sub-expr) so-far) + (progn + (setq so-far (cons (list (car sub-expr)) + so-far)) + (not (setq res + (math-integrate-by-substitution + expr (car sub-expr)))))))) + res)) + (let ((res nil)) + (while (and (setq sub-expr (cdr sub-expr)) + (not (setq res (math-integ-try-linear-substitutions + (car sub-expr)))))) + res))) +) + +;;; Recursively try different substitutions based on various sub-expressions. +(defun math-integ-try-substitutions (sub-expr &optional allow-rat) + (and (not (Math-primp sub-expr)) + (not (assoc sub-expr so-far)) + (math-expr-contains sub-expr math-integ-var) + (or (and (if (and (not (memq (car sub-expr) '(+ - * / neg))) + (not (and (eq (car sub-expr) '^) + (integerp (nth 2 sub-expr))))) + (setq allow-rat t) + (prog1 allow-rat (setq allow-rat nil))) + (not (eq sub-expr expr)) + (or (math-integrate-by-substitution expr sub-expr) + (and (eq (car sub-expr) '^) + (integerp (nth 2 sub-expr)) + (< (nth 2 sub-expr) 0) + (math-integ-try-substitutions + (math-pow (nth 1 sub-expr) (- (nth 2 sub-expr))) + t)))) + (let ((res nil)) + (setq so-far (cons (list sub-expr) so-far)) + (while (and (setq sub-expr (cdr sub-expr)) + (not (setq res (math-integ-try-substitutions + (car sub-expr) allow-rat))))) + res))) +) + +(defun math-expr-rational-in (expr) + (let ((parts nil)) + (math-expr-rational-in-rec expr) + (mapcar 'car parts)) +) + +(defun math-expr-rational-in-rec (expr) + (cond ((Math-primp expr) + (and (equal expr math-integ-var) + (not (assoc expr parts)) + (setq parts (cons (list expr) parts)))) + ((or (memq (car expr) '(+ - * / neg)) + (and (eq (car expr) '^) (integerp (nth 2 expr)))) + (math-expr-rational-in-rec (nth 1 expr)) + (and (nth 2 expr) (math-expr-rational-in-rec (nth 2 expr)))) + ((and (eq (car expr) '^) + (eq (math-quarter-integer (nth 2 expr)) 2)) + (math-expr-rational-in-rec (list 'calcFunc-sqrt (nth 1 expr)))) + (t + (and (not (assoc expr parts)) + (math-expr-contains expr math-integ-var) + (setq parts (cons (list expr) parts))))) +) + +(defun math-expr-calls (expr funcs &optional arg-contains) + (if (consp expr) + (if (or (memq (car expr) funcs) + (and (eq (car expr) '^) (eq (car funcs) 'calcFunc-sqrt) + (eq (math-quarter-integer (nth 2 expr)) 2))) + (and (or (not arg-contains) + (math-expr-contains expr arg-contains)) + expr) + (and (not (Math-primp expr)) + (let ((res nil)) + (while (and (setq expr (cdr expr)) + (not (setq res (math-expr-calls + (car expr) funcs arg-contains))))) + res)))) +) + +(defun math-fix-const-terms (expr except-vars) + (cond ((not (math-expr-depends expr except-vars)) 0) + ((Math-primp expr) expr) + ((eq (car expr) '+) + (math-add (math-fix-const-terms (nth 1 expr) except-vars) + (math-fix-const-terms (nth 2 expr) except-vars))) + ((eq (car expr) '-) + (math-sub (math-fix-const-terms (nth 1 expr) except-vars) + (math-fix-const-terms (nth 2 expr) except-vars))) + (t expr)) +) + +;; Command for debugging the Calculator's symbolic integrator. +(defun calc-dump-integral-cache (&optional arg) + (interactive "P") + (let ((buf (current-buffer))) + (unwind-protect + (let ((p math-integral-cache) + cur-record) + (display-buffer (get-buffer-create "*Integral Cache*")) + (set-buffer (get-buffer "*Integral Cache*")) + (erase-buffer) + (while p + (setq cur-record (car p)) + (or arg (math-replace-integral-parts cur-record)) + (insert (math-format-flat-expr (car cur-record) 0) + " --> " + (if (symbolp (nth 1 cur-record)) + (concat "(" (symbol-name (nth 1 cur-record)) ")") + (math-format-flat-expr (nth 1 cur-record) 0)) + "\n") + (setq p (cdr p))) + (goto-char (point-min))) + (set-buffer buf))) +) + +(defun math-try-integral (expr) + (let ((math-integ-level math-integral-limit) + (math-integ-depth 0) + (math-integ-msg "Working...done") + (cur-record nil) ; a technicality + (math-integrating t) + (calc-prefer-frac t) + (calc-symbolic-mode t) + (has-rules (calc-has-rules 'var-IntegRules))) + (or (math-integral expr 'yes) + (and math-any-substs + (setq math-enable-subst t) + (math-integral expr 'yes)) + (and (> math-max-integral-limit math-integral-limit) + (setq math-integral-limit math-max-integral-limit + math-integ-level math-integral-limit) + (math-integral expr 'yes)))) +) + +(defun calcFunc-integ (expr var &optional low high) + (cond + ;; Do these even if the parts turn out not to be integrable. + ((eq (car-safe expr) '+) + (math-add (calcFunc-integ (nth 1 expr) var low high) + (calcFunc-integ (nth 2 expr) var low high))) + ((eq (car-safe expr) '-) + (math-sub (calcFunc-integ (nth 1 expr) var low high) + (calcFunc-integ (nth 2 expr) var low high))) + ((eq (car-safe expr) 'neg) + (math-neg (calcFunc-integ (nth 1 expr) var low high))) + ((and (eq (car-safe expr) '*) + (not (math-expr-contains (nth 1 expr) var))) + (math-mul (nth 1 expr) (calcFunc-integ (nth 2 expr) var low high))) + ((and (eq (car-safe expr) '*) + (not (math-expr-contains (nth 2 expr) var))) + (math-mul (calcFunc-integ (nth 1 expr) var low high) (nth 2 expr))) + ((and (eq (car-safe expr) '/) + (not (math-expr-contains (nth 1 expr) var)) + (not (math-equal-int (nth 1 expr) 1))) + (math-mul (nth 1 expr) + (calcFunc-integ (math-div 1 (nth 2 expr)) var low high))) + ((and (eq (car-safe expr) '/) + (not (math-expr-contains (nth 2 expr) var))) + (math-div (calcFunc-integ (nth 1 expr) var low high) (nth 2 expr))) + ((and (eq (car-safe expr) '/) + (eq (car-safe (nth 1 expr)) '*) + (not (math-expr-contains (nth 1 (nth 1 expr)) var))) + (math-mul (nth 1 (nth 1 expr)) + (calcFunc-integ (math-div (nth 2 (nth 1 expr)) (nth 2 expr)) + var low high))) + ((and (eq (car-safe expr) '/) + (eq (car-safe (nth 1 expr)) '*) + (not (math-expr-contains (nth 2 (nth 1 expr)) var))) + (math-mul (nth 2 (nth 1 expr)) + (calcFunc-integ (math-div (nth 1 (nth 1 expr)) (nth 2 expr)) + var low high))) + ((and (eq (car-safe expr) '/) + (eq (car-safe (nth 2 expr)) '*) + (not (math-expr-contains (nth 1 (nth 2 expr)) var))) + (math-div (calcFunc-integ (math-div (nth 1 expr) (nth 2 (nth 2 expr))) + var low high) + (nth 1 (nth 2 expr)))) + ((and (eq (car-safe expr) '/) + (eq (car-safe (nth 2 expr)) '*) + (not (math-expr-contains (nth 2 (nth 2 expr)) var))) + (math-div (calcFunc-integ (math-div (nth 1 expr) (nth 1 (nth 2 expr))) + var low high) + (nth 2 (nth 2 expr)))) + ((eq (car-safe expr) 'vec) + (cons 'vec (mapcar (function (lambda (x) (calcFunc-integ x var low high))) + (cdr expr)))) + (t + (let ((state (list calc-angle-mode + ;;calc-symbolic-mode + ;;calc-prefer-frac + calc-internal-prec + (calc-var-value 'var-IntegRules) + (calc-var-value 'var-IntegSimpRules)))) + (or (equal state math-integral-cache-state) + (setq math-integral-cache-state state + math-integral-cache nil))) + (let* ((math-max-integral-limit (or (and (boundp 'var-IntegLimit) + (natnump var-IntegLimit) + var-IntegLimit) + 3)) + (math-integral-limit 1) + (sexpr (math-expr-subst expr var math-integ-var)) + (trace-buffer (get-buffer "*Trace*")) + (calc-language (if (eq calc-language 'big) nil calc-language)) + (math-any-substs t) + (math-enable-subst nil) + (math-prev-parts-v nil) + (math-doing-parts nil) + (math-good-parts nil) + (res + (if trace-buffer + (let ((calcbuf (current-buffer)) + (calcwin (selected-window))) + (unwind-protect + (progn + (if (get-buffer-window trace-buffer) + (select-window (get-buffer-window trace-buffer))) + (set-buffer trace-buffer) + (goto-char (point-max)) + (or (assq 'scroll-stop (buffer-local-variables)) + (progn + (make-local-variable 'scroll-step) + (setq scroll-step 3))) + (insert "\n\n\n") + (set-buffer calcbuf) + (math-try-integral sexpr)) + (select-window calcwin) + (set-buffer calcbuf))) + (math-try-integral sexpr)))) + (if res + (progn + (if (calc-has-rules 'var-IntegAfterRules) + (setq res (math-rewrite res '(var IntegAfterRules + var-IntegAfterRules)))) + (math-simplify + (if (and low high) + (math-sub (math-expr-subst res math-integ-var high) + (math-expr-subst res math-integ-var low)) + (setq res (math-fix-const-terms res math-integ-vars)) + (if low + (math-expr-subst res math-integ-var low) + (math-expr-subst res math-integ-var var))))) + (append (list 'calcFunc-integ expr var) + (and low (list low)) + (and high (list high))))))) +) + + +(math-defintegral calcFunc-inv + (math-integral (math-div 1 u))) + +(math-defintegral calcFunc-conj + (let ((int (math-integral u))) + (and int + (list 'calcFunc-conj int)))) + +(math-defintegral calcFunc-deg + (let ((int (math-integral u))) + (and int + (list 'calcFunc-deg int)))) + +(math-defintegral calcFunc-rad + (let ((int (math-integral u))) + (and int + (list 'calcFunc-rad int)))) + +(math-defintegral calcFunc-re + (let ((int (math-integral u))) + (and int + (list 'calcFunc-re int)))) + +(math-defintegral calcFunc-im + (let ((int (math-integral u))) + (and int + (list 'calcFunc-im int)))) + +(math-defintegral calcFunc-sqrt + (and (equal u math-integ-var) + (math-mul '(frac 2 3) + (list 'calcFunc-sqrt (math-pow u 3))))) + +(math-defintegral calcFunc-exp + (or (and (equal u math-integ-var) + (list 'calcFunc-exp u)) + (let ((p (math-is-polynomial u math-integ-var 2))) + (and (nth 2 p) + (let ((sqa (math-sqrt (math-neg (nth 2 p))))) + (math-div + (math-mul + (math-mul (math-div (list 'calcFunc-sqrt '(var pi var-pi)) + sqa) + (math-normalize + (list 'calcFunc-exp + (math-div (math-sub (math-mul (car p) + (nth 2 p)) + (math-div + (math-sqr (nth 1 p)) + 4)) + (nth 2 p))))) + (list 'calcFunc-erf + (math-sub (math-mul sqa math-integ-var) + (math-div (nth 1 p) (math-mul 2 sqa))))) + 2)))))) + +(math-defintegral calcFunc-ln + (or (and (equal u math-integ-var) + (math-sub (math-mul u (list 'calcFunc-ln u)) u)) + (and (eq (car u) '*) + (math-integral (math-add (list 'calcFunc-ln (nth 1 u)) + (list 'calcFunc-ln (nth 2 u))))) + (and (eq (car u) '/) + (math-integral (math-sub (list 'calcFunc-ln (nth 1 u)) + (list 'calcFunc-ln (nth 2 u))))) + (and (eq (car u) '^) + (math-integral (math-mul (nth 2 u) + (list 'calcFunc-ln (nth 1 u))))))) + +(math-defintegral calcFunc-log10 + (and (equal u math-integ-var) + (math-sub (math-mul u (list 'calcFunc-ln u)) + (math-div u (list 'calcFunc-ln 10))))) + +(math-defintegral-2 calcFunc-log + (math-integral (math-div (list 'calcFunc-ln u) + (list 'calcFunc-ln v)))) + +(math-defintegral calcFunc-sin + (or (and (equal u math-integ-var) + (math-neg (math-from-radians-2 (list 'calcFunc-cos u)))) + (and (nth 2 (math-is-polynomial u math-integ-var 2)) + (math-integral (math-to-exponentials (list 'calcFunc-sin u)))))) + +(math-defintegral calcFunc-cos + (or (and (equal u math-integ-var) + (math-from-radians-2 (list 'calcFunc-sin u))) + (and (nth 2 (math-is-polynomial u math-integ-var 2)) + (math-integral (math-to-exponentials (list 'calcFunc-cos u)))))) + +(math-defintegral calcFunc-tan + (and (equal u math-integ-var) + (math-neg (math-from-radians-2 + (list 'calcFunc-ln (list 'calcFunc-cos u)))))) + +(math-defintegral calcFunc-arcsin + (and (equal u math-integ-var) + (math-add (math-mul u (list 'calcFunc-arcsin u)) + (math-from-radians-2 + (list 'calcFunc-sqrt (math-sub 1 (math-sqr u))))))) + +(math-defintegral calcFunc-arccos + (and (equal u math-integ-var) + (math-sub (math-mul u (list 'calcFunc-arccos u)) + (math-from-radians-2 + (list 'calcFunc-sqrt (math-sub 1 (math-sqr u))))))) + +(math-defintegral calcFunc-arctan + (and (equal u math-integ-var) + (math-sub (math-mul u (list 'calcFunc-arctan u)) + (math-from-radians-2 + (math-div (list 'calcFunc-ln (math-add 1 (math-sqr u))) + 2))))) + +(math-defintegral calcFunc-sinh + (and (equal u math-integ-var) + (list 'calcFunc-cosh u))) + +(math-defintegral calcFunc-cosh + (and (equal u math-integ-var) + (list 'calcFunc-sinh u))) + +(math-defintegral calcFunc-tanh + (and (equal u math-integ-var) + (list 'calcFunc-ln (list 'calcFunc-cosh u)))) + +(math-defintegral calcFunc-arcsinh + (and (equal u math-integ-var) + (math-sub (math-mul u (list 'calcFunc-arcsinh u)) + (list 'calcFunc-sqrt (math-add (math-sqr u) 1))))) + +(math-defintegral calcFunc-arccosh + (and (equal u math-integ-var) + (math-sub (math-mul u (list 'calcFunc-arccosh u)) + (list 'calcFunc-sqrt (math-sub 1 (math-sqr u)))))) + +(math-defintegral calcFunc-arctanh + (and (equal u math-integ-var) + (math-sub (math-mul u (list 'calcFunc-arctan u)) + (math-div (list 'calcFunc-ln + (math-add 1 (math-sqr u))) + 2)))) + +;;; (Ax + B) / (ax^2 + bx + c)^n forms. +(math-defintegral-2 / + (math-integral-rational-funcs u v)) + +(defun math-integral-rational-funcs (u v) + (let ((pu (math-is-polynomial u math-integ-var 1)) + (vpow 1) pv) + (and pu + (catch 'int-rat + (if (and (eq (car-safe v) '^) (natnump (nth 2 v))) + (setq vpow (nth 2 v) + v (nth 1 v))) + (and (setq pv (math-is-polynomial v math-integ-var 2)) + (let ((int (math-mul-thru + (car pu) + (math-integral-q02 (car pv) (nth 1 pv) + (nth 2 pv) v vpow)))) + (if (cdr pu) + (setq int (math-add int + (math-mul-thru + (nth 1 pu) + (math-integral-q12 + (car pv) (nth 1 pv) + (nth 2 pv) v vpow))))) + int)))))) + +(defun math-integral-q12 (a b c v vpow) + (let (q) + (cond ((not c) + (cond ((= vpow 1) + (math-sub (math-div math-integ-var b) + (math-mul (math-div a (math-sqr b)) + (list 'calcFunc-ln v)))) + ((= vpow 2) + (math-div (math-add (list 'calcFunc-ln v) + (math-div a v)) + (math-sqr b))) + (t + (let ((nm1 (math-sub vpow 1)) + (nm2 (math-sub vpow 2))) + (math-div (math-sub + (math-div a (math-mul nm1 (math-pow v nm1))) + (math-div 1 (math-mul nm2 (math-pow v nm2)))) + (math-sqr b)))))) + ((math-zerop + (setq q (math-sub (math-mul 4 (math-mul a c)) (math-sqr b)))) + (let ((part (math-div b (math-mul 2 c)))) + (math-mul-thru (math-pow c vpow) + (math-integral-q12 part 1 nil + (math-add math-integ-var part) + (* vpow 2))))) + ((= vpow 1) + (and (math-ratp q) (math-negp q) + (let ((calc-symbolic-mode t)) + (math-ratp (math-sqrt (math-neg q)))) + (throw 'int-rat nil)) ; should have used calcFunc-apart first + (math-sub (math-div (list 'calcFunc-ln v) (math-mul 2 c)) + (math-mul-thru (math-div b (math-mul 2 c)) + (math-integral-q02 a b c v 1)))) + (t + (let ((n (1- vpow))) + (math-sub (math-neg (math-div + (math-add (math-mul b math-integ-var) + (math-mul 2 a)) + (math-mul n (math-mul q (math-pow v n))))) + (math-mul-thru (math-div (math-mul b (1- (* 2 n))) + (math-mul n q)) + (math-integral-q02 a b c v n))))))) +) + +(defun math-integral-q02 (a b c v vpow) + (let (q rq part) + (cond ((not c) + (cond ((= vpow 1) + (math-div (list 'calcFunc-ln v) b)) + (t + (math-div (math-pow v (- 1 vpow)) + (math-mul (- 1 vpow) b))))) + ((math-zerop + (setq q (math-sub (math-mul 4 (math-mul a c)) (math-sqr b)))) + (let ((part (math-div b (math-mul 2 c)))) + (math-mul-thru (math-pow c vpow) + (math-integral-q02 part 1 nil + (math-add math-integ-var part) + (* vpow 2))))) + ((progn + (setq part (math-add (math-mul 2 (math-mul c math-integ-var)) b)) + (> vpow 1)) + (let ((n (1- vpow))) + (math-add (math-div part (math-mul n (math-mul q (math-pow v n)))) + (math-mul-thru (math-div (math-mul (- (* 4 n) 2) c) + (math-mul n q)) + (math-integral-q02 a b c v n))))) + ((math-guess-if-neg q) + (setq rq (list 'calcFunc-sqrt (math-neg q))) + ;;(math-div-thru (list 'calcFunc-ln + ;; (math-div (math-sub part rq) + ;; (math-add part rq))) + ;; rq) + (math-div (math-mul -2 (list 'calcFunc-arctanh + (math-div part rq))) + rq)) + (t + (setq rq (list 'calcFunc-sqrt q)) + (math-div (math-mul 2 (math-to-radians-2 + (list 'calcFunc-arctan + (math-div part rq)))) + rq)))) +) + + +(math-defintegral calcFunc-erf + (and (equal u math-integ-var) + (math-add (math-mul u (list 'calcFunc-erf u)) + (math-div 1 (math-mul (list 'calcFunc-exp (math-sqr u)) + (list 'calcFunc-sqrt + '(var pi var-pi))))))) + +(math-defintegral calcFunc-erfc + (and (equal u math-integ-var) + (math-sub (math-mul u (list 'calcFunc-erfc u)) + (math-div 1 (math-mul (list 'calcFunc-exp (math-sqr u)) + (list 'calcFunc-sqrt + '(var pi var-pi))))))) + + + + +(defun calcFunc-table (expr var &optional low high step) + (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf))) + (or high (setq high low low 1)) + (and (or (math-infinitep low) (math-infinitep high)) + (not step) + (math-scan-for-limits expr)) + (and step (math-zerop step) (math-reject-arg step 'nonzerop)) + (let ((known (+ (if (Math-objectp low) 1 0) + (if (Math-objectp high) 1 0) + (if (or (null step) (Math-objectp step)) 1 0))) + (count '(var inf var-inf)) + vec) + (or (= known 2) ; handy optimization + (equal high '(var inf var-inf)) + (progn + (setq count (math-div (math-sub high low) (or step 1))) + (or (Math-objectp count) + (setq count (math-simplify count))) + (if (Math-messy-integerp count) + (setq count (math-trunc count))))) + (if (Math-negp count) + (setq count -1)) + (if (integerp count) + (let ((var-DUMMY nil) + (vec math-tabulate-initial) + (math-working-step-2 (1+ count)) + (math-working-step 0)) + (setq expr (math-evaluate-expr + (math-expr-subst expr var '(var DUMMY var-DUMMY)))) + (while (>= count 0) + (setq math-working-step (1+ math-working-step) + var-DUMMY low + vec (cond ((eq math-tabulate-function 'calcFunc-sum) + (math-add vec (math-evaluate-expr expr))) + ((eq math-tabulate-function 'calcFunc-prod) + (math-mul vec (math-evaluate-expr expr))) + (t + (cons (math-evaluate-expr expr) vec))) + low (math-add low (or step 1)) + count (1- count))) + (if math-tabulate-function + vec + (cons 'vec (nreverse vec)))) + (if (Math-integerp count) + (calc-record-why 'fixnump high) + (if (Math-num-integerp low) + (if (Math-num-integerp high) + (calc-record-why 'integerp step) + (calc-record-why 'integerp high)) + (calc-record-why 'integerp low))) + (append (list (or math-tabulate-function 'calcFunc-table) + expr var) + (and (not (and (equal low '(neg (var inf var-inf))) + (equal high '(var inf var-inf)))) + (list low high)) + (and step (list step))))) +) + +(setq math-tabulate-initial nil) +(setq math-tabulate-function nil) + +(defun math-scan-for-limits (x) + (cond ((Math-primp x)) + ((and (eq (car x) 'calcFunc-subscr) + (Math-vectorp (nth 1 x)) + (math-expr-contains (nth 2 x) var)) + (let* ((calc-next-why nil) + (low-val (math-solve-for (nth 2 x) 1 var nil)) + (high-val (math-solve-for (nth 2 x) (1- (length (nth 1 x))) + var nil)) + temp) + (and low-val (math-realp low-val) + high-val (math-realp high-val)) + (and (Math-lessp high-val low-val) + (setq temp low-val low-val high-val high-val temp)) + (setq low (math-max low (math-ceiling low-val)) + high (math-min high (math-floor high-val))))) + (t + (while (setq x (cdr x)) + (math-scan-for-limits (car x))))) +) + + +(defun calcFunc-sum (expr var &optional low high step) + (if math-disable-sums (math-reject-arg)) + (let* ((res (let* ((calc-internal-prec (+ calc-internal-prec 2))) + (math-sum-rec expr var low high step))) + (math-disable-sums t)) + (math-normalize res)) +) +(setq math-disable-sums nil) + +(defun math-sum-rec (expr var &optional low high step) + (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf))) + (and low (not high) (setq high low low 1)) + (let (t1 t2 val) + (setq val + (cond + ((not (math-expr-contains expr var)) + (math-mul expr (math-add (math-div (math-sub high low) (or step 1)) + 1))) + ((and step (not (math-equal-int step 1))) + (if (math-negp step) + (math-sum-rec expr var high low (math-neg step)) + (let ((lo (math-simplify (math-div low step)))) + (if (math-known-num-integerp lo) + (math-sum-rec (math-normalize + (math-expr-subst expr var + (math-mul step var))) + var lo (math-simplify (math-div high step))) + (math-sum-rec (math-normalize + (math-expr-subst expr var + (math-add (math-mul step var) + low))) + var 0 + (math-simplify (math-div (math-sub high low) + step))))))) + ((memq (setq t1 (math-compare low high)) '(0 1)) + (if (eq t1 0) + (math-expr-subst expr var low) + 0)) + ((setq t1 (math-is-polynomial expr var 20)) + (let ((poly nil) + (n 0)) + (while t1 + (setq poly (math-poly-mix poly 1 + (math-sum-integer-power n) (car t1)) + n (1+ n) + t1 (cdr t1))) + (setq n (math-build-polynomial-expr poly high)) + (if (memq low '(0 1)) + n + (math-sub n (math-build-polynomial-expr poly + (math-sub low 1)))))) + ((and (memq (car expr) '(+ -)) + (setq t1 (math-sum-rec (nth 1 expr) var low high) + t2 (math-sum-rec (nth 2 expr) var low high)) + (not (and (math-expr-calls t1 '(calcFunc-sum)) + (math-expr-calls t2 '(calcFunc-sum))))) + (list (car expr) t1 t2)) + ((and (eq (car expr) '*) + (setq t1 (math-sum-const-factors expr var))) + (math-mul (car t1) (math-sum-rec (cdr t1) var low high))) + ((and (eq (car expr) '*) (memq (car-safe (nth 1 expr)) '(+ -))) + (math-sum-rec (math-add-or-sub (math-mul (nth 1 (nth 1 expr)) + (nth 2 expr)) + (math-mul (nth 2 (nth 1 expr)) + (nth 2 expr)) + nil (eq (car (nth 1 expr)) '-)) + var low high)) + ((and (eq (car expr) '*) (memq (car-safe (nth 2 expr)) '(+ -))) + (math-sum-rec (math-add-or-sub (math-mul (nth 1 expr) + (nth 1 (nth 2 expr))) + (math-mul (nth 1 expr) + (nth 2 (nth 2 expr))) + nil (eq (car (nth 2 expr)) '-)) + var low high)) + ((and (eq (car expr) '/) + (not (math-primp (nth 1 expr))) + (setq t1 (math-sum-const-factors (nth 1 expr) var))) + (math-mul (car t1) + (math-sum-rec (math-div (cdr t1) (nth 2 expr)) + var low high))) + ((and (eq (car expr) '/) + (setq t1 (math-sum-const-factors (nth 2 expr) var))) + (math-div (math-sum-rec (math-div (nth 1 expr) (cdr t1)) + var low high) + (car t1))) + ((eq (car expr) 'neg) + (math-neg (math-sum-rec (nth 1 expr) var low high))) + ((and (eq (car expr) '^) + (not (math-expr-contains (nth 1 expr) var)) + (setq t1 (math-is-polynomial (nth 2 expr) var 1))) + (let ((x (math-pow (nth 1 expr) (nth 1 t1)))) + (math-div (math-mul (math-sub (math-pow x (math-add 1 high)) + (math-pow x low)) + (math-pow (nth 1 expr) (car t1))) + (math-sub x 1)))) + ((and (setq t1 (math-to-exponentials expr)) + (setq t1 (math-sum-rec t1 var low high)) + (not (math-expr-calls t1 '(calcFunc-sum)))) + (math-to-exps t1)) + ((memq (car expr) '(calcFunc-ln calcFunc-log10)) + (list (car expr) (calcFunc-prod (nth 1 expr) var low high))) + ((and (eq (car expr) 'calcFunc-log) + (= (length expr) 3) + (not (math-expr-contains (nth 2 expr) var))) + (list 'calcFunc-log + (calcFunc-prod (nth 1 expr) var low high) + (nth 2 expr))))) + (if (equal val '(var nan var-nan)) (setq val nil)) + (or val + (let* ((math-tabulate-initial 0) + (math-tabulate-function 'calcFunc-sum)) + (calcFunc-table expr var low high)))) +) + +(defun calcFunc-asum (expr var low &optional high step no-mul-flag) + (or high (setq high low low 1)) + (if (and step (not (math-equal-int step 1))) + (if (math-negp step) + (math-mul (math-pow -1 low) + (calcFunc-asum expr var high low (math-neg step) t)) + (let ((lo (math-simplify (math-div low step)))) + (if (math-num-integerp lo) + (calcFunc-asum (math-normalize + (math-expr-subst expr var + (math-mul step var))) + var lo (math-simplify (math-div high step))) + (calcFunc-asum (math-normalize + (math-expr-subst expr var + (math-add (math-mul step var) + low))) + var 0 + (math-simplify (math-div (math-sub high low) + step)))))) + (math-mul (if no-mul-flag 1 (math-pow -1 low)) + (calcFunc-sum (math-mul (math-pow -1 var) expr) var low high))) +) + +(defun math-sum-const-factors (expr var) + (let ((const nil) + (not-const nil) + (p expr)) + (while (eq (car-safe p) '*) + (if (math-expr-contains (nth 1 p) var) + (setq not-const (cons (nth 1 p) not-const)) + (setq const (cons (nth 1 p) const))) + (setq p (nth 2 p))) + (if (math-expr-contains p var) + (setq not-const (cons p not-const)) + (setq const (cons p const))) + (and const + (cons (let ((temp (car const))) + (while (setq const (cdr const)) + (setq temp (list '* (car const) temp))) + temp) + (let ((temp (or (car not-const) 1))) + (while (setq not-const (cdr not-const)) + (setq temp (list '* (car not-const) temp))) + temp)))) +) + +;; Following is from CRC Math Tables, 27th ed, pp. 52-53. +(defun math-sum-integer-power (pow) + (let ((calc-prefer-frac t) + (n (length math-sum-int-pow-cache))) + (while (<= n pow) + (let* ((new (list 0 0)) + (lin new) + (pp (cdr (nth (1- n) math-sum-int-pow-cache))) + (p 2) + (sum 0) + q) + (while pp + (setq q (math-div (car pp) p) + new (cons (math-mul q n) new) + sum (math-add sum q) + p (1+ p) + pp (cdr pp))) + (setcar lin (math-sub 1 (math-mul n sum))) + (setq math-sum-int-pow-cache + (nconc math-sum-int-pow-cache (list (nreverse new))) + n (1+ n)))) + (nth pow math-sum-int-pow-cache)) +) +(setq math-sum-int-pow-cache (list '(0 1))) + +(defun math-to-exponentials (expr) + (and (consp expr) + (= (length expr) 2) + (let ((x (nth 1 expr)) + (pi (if calc-symbolic-mode '(var pi var-pi) (math-pi))) + (i (if calc-symbolic-mode '(var i var-i) '(cplx 0 1)))) + (cond ((eq (car expr) 'calcFunc-exp) + (list '^ '(var e var-e) x)) + ((eq (car expr) 'calcFunc-sin) + (or (eq calc-angle-mode 'rad) + (setq x (list '/ (list '* x pi) 180))) + (list '/ (list '- + (list '^ '(var e var-e) (list '* x i)) + (list '^ '(var e var-e) + (list 'neg (list '* x i)))) + (list '* 2 i))) + ((eq (car expr) 'calcFunc-cos) + (or (eq calc-angle-mode 'rad) + (setq x (list '/ (list '* x pi) 180))) + (list '/ (list '+ + (list '^ '(var e var-e) + (list '* x i)) + (list '^ '(var e var-e) + (list 'neg (list '* x i)))) + 2)) + ((eq (car expr) 'calcFunc-sinh) + (list '/ (list '- + (list '^ '(var e var-e) x) + (list '^ '(var e var-e) (list 'neg x))) + 2)) + ((eq (car expr) 'calcFunc-cosh) + (list '/ (list '+ + (list '^ '(var e var-e) x) + (list '^ '(var e var-e) (list 'neg x))) + 2)) + (t nil)))) +) + +(defun math-to-exps (expr) + (cond (calc-symbolic-mode expr) + ((Math-primp expr) + (if (equal expr '(var e var-e)) (math-e) expr)) + ((and (eq (car expr) '^) + (equal (nth 1 expr) '(var e var-e))) + (list 'calcFunc-exp (nth 2 expr))) + (t + (cons (car expr) (mapcar 'math-to-exps (cdr expr))))) +) + + +(defun calcFunc-prod (expr var &optional low high step) + (if math-disable-prods (math-reject-arg)) + (let* ((res (let* ((calc-internal-prec (+ calc-internal-prec 2))) + (math-prod-rec expr var low high step))) + (math-disable-prods t)) + (math-normalize res)) +) +(setq math-disable-prods nil) + +(defun math-prod-rec (expr var &optional low high step) + (or low (setq low '(neg (var inf var-inf)) high '(var inf var-inf))) + (and low (not high) (setq high '(var inf var-inf))) + (let (t1 t2 t3 val) + (setq val + (cond + ((not (math-expr-contains expr var)) + (math-pow expr (math-add (math-div (math-sub high low) (or step 1)) + 1))) + ((and step (not (math-equal-int step 1))) + (if (math-negp step) + (math-prod-rec expr var high low (math-neg step)) + (let ((lo (math-simplify (math-div low step)))) + (if (math-known-num-integerp lo) + (math-prod-rec (math-normalize + (math-expr-subst expr var + (math-mul step var))) + var lo (math-simplify (math-div high step))) + (math-prod-rec (math-normalize + (math-expr-subst expr var + (math-add (math-mul step + var) + low))) + var 0 + (math-simplify (math-div (math-sub high low) + step))))))) + ((and (memq (car expr) '(* /)) + (setq t1 (math-prod-rec (nth 1 expr) var low high) + t2 (math-prod-rec (nth 2 expr) var low high)) + (not (and (math-expr-calls t1 '(calcFunc-prod)) + (math-expr-calls t2 '(calcFunc-prod))))) + (list (car expr) t1 t2)) + ((and (eq (car expr) '^) + (not (math-expr-contains (nth 2 expr) var))) + (math-pow (math-prod-rec (nth 1 expr) var low high) + (nth 2 expr))) + ((and (eq (car expr) '^) + (not (math-expr-contains (nth 1 expr) var))) + (math-pow (nth 1 expr) + (calcFunc-sum (nth 2 expr) var low high))) + ((eq (car expr) 'sqrt) + (math-normalize (list 'calcFunc-sqrt + (list 'calcFunc-prod (nth 1 expr) + var low high)))) + ((eq (car expr) 'neg) + (math-mul (math-pow -1 (math-add (math-sub high low) 1)) + (math-prod-rec (nth 1 expr) var low high))) + ((eq (car expr) 'calcFunc-exp) + (list 'calcFunc-exp (calcFunc-sum (nth 1 expr) var low high))) + ((and (setq t1 (math-is-polynomial expr var 1)) + (setq t2 + (cond + ((or (and (math-equal-int (nth 1 t1) 1) + (setq low (math-simplify + (math-add low (car t1))) + high (math-simplify + (math-add high (car t1))))) + (and (math-equal-int (nth 1 t1) -1) + (setq t2 low + low (math-simplify + (math-sub (car t1) high)) + high (math-simplify + (math-sub (car t1) t2))))) + (if (or (math-zerop low) (math-zerop high)) + 0 + (if (and (or (math-negp low) (math-negp high)) + (or (math-num-integerp low) + (math-num-integerp high))) + (if (math-posp high) + 0 + (math-mul (math-pow -1 + (math-add + (math-add low high) 1)) + (list '/ + (list 'calcFunc-fact + (math-neg low)) + (list 'calcFunc-fact + (math-sub -1 high))))) + (list '/ + (list 'calcFunc-fact high) + (list 'calcFunc-fact (math-sub low 1)))))) + ((and (or (and (math-equal-int (nth 1 t1) 2) + (setq t2 (math-simplify + (math-add (math-mul low 2) + (car t1))) + t3 (math-simplify + (math-add (math-mul high 2) + (car t1))))) + (and (math-equal-int (nth 1 t1) -2) + (setq t2 (math-simplify + (math-sub (car t1) + (math-mul high 2))) + t3 (math-simplify + (math-sub (car t1) + (math-mul low + 2)))))) + (or (math-integerp t2) + (and (math-messy-integerp t2) + (setq t2 (math-trunc t2))) + (math-integerp t3) + (and (math-messy-integerp t3) + (setq t3 (math-trunc t3))))) + (if (or (math-zerop t2) (math-zerop t3)) + 0 + (if (or (math-evenp t2) (math-evenp t3)) + (if (or (math-negp t2) (math-negp t3)) + (if (math-posp high) + 0 + (list '/ + (list 'calcFunc-dfact + (math-neg t2)) + (list 'calcFunc-dfact + (math-sub -2 t3)))) + (list '/ + (list 'calcFunc-dfact t3) + (list 'calcFunc-dfact + (math-sub t2 2)))) + (if (math-negp t3) + (list '* + (list '^ -1 + (list '/ (list '- (list '- t2 t3) + 2) + 2)) + (list '/ + (list 'calcFunc-dfact + (math-neg t2)) + (list 'calcFunc-dfact + (math-sub -2 t3)))) + (if (math-posp t2) + (list '/ + (list 'calcFunc-dfact t3) + (list 'calcFunc-dfact + (math-sub t2 2))) + nil)))))))) + t2))) + (if (equal val '(var nan var-nan)) (setq val nil)) + (or val + (let* ((math-tabulate-initial 1) + (math-tabulate-function 'calcFunc-prod)) + (calcFunc-table expr var low high)))) +) + + + + +;;; Attempt to reduce lhs = rhs to solve-var = rhs', where solve-var appears +;;; in lhs but not in rhs or rhs'; return rhs'. +;;; Uses global values: solve-*. +(defun math-try-solve-for (lhs rhs &optional sign no-poly) + (let (t1 t2 t3) + (cond ((equal lhs solve-var) + (setq math-solve-sign sign) + (if (eq solve-full 'all) + (let ((vec (list 'vec (math-evaluate-expr rhs))) + newvec var p) + (while math-solve-ranges + (setq p (car math-solve-ranges) + var (car p) + newvec (list 'vec)) + (while (setq p (cdr p)) + (setq newvec (nconc newvec + (cdr (math-expr-subst + vec var (car p)))))) + (setq vec newvec + math-solve-ranges (cdr math-solve-ranges))) + (math-normalize vec)) + rhs)) + ((Math-primp lhs) + nil) + ((and (eq (car lhs) '-) + (eq (car-safe (nth 1 lhs)) (car-safe (nth 2 lhs))) + (Math-zerop rhs) + (= (length (nth 1 lhs)) 2) + (= (length (nth 2 lhs)) 2) + (setq t1 (get (car (nth 1 lhs)) 'math-inverse)) + (setq t2 (funcall t1 '(var SOLVEDUM SOLVEDUM))) + (eq (math-expr-contains-count t2 '(var SOLVEDUM SOLVEDUM)) 1) + (setq t3 (math-solve-above-dummy t2)) + (setq t1 (math-try-solve-for (math-sub (nth 1 (nth 1 lhs)) + (math-expr-subst + t2 t3 + (nth 1 (nth 2 lhs)))) + 0))) + t1) + ((eq (car lhs) 'neg) + (math-try-solve-for (nth 1 lhs) (math-neg rhs) + (and sign (- sign)))) + ((and (not (eq solve-full 't)) (math-try-solve-prod))) + ((and (not no-poly) + (setq t2 (math-decompose-poly lhs solve-var 15 rhs))) + (setq t1 (cdr (nth 1 t2)) + t1 (let ((math-solve-ranges math-solve-ranges)) + (cond ((= (length t1) 5) + (apply 'math-solve-quartic (car t2) t1)) + ((= (length t1) 4) + (apply 'math-solve-cubic (car t2) t1)) + ((= (length t1) 3) + (apply 'math-solve-quadratic (car t2) t1)) + ((= (length t1) 2) + (apply 'math-solve-linear (car t2) sign t1)) + (solve-full + (math-poly-all-roots (car t2) t1)) + (calc-symbolic-mode nil) + (t + (math-try-solve-for + (car t2) + (math-poly-any-root (reverse t1) 0 t) + nil t))))) + (if t1 + (if (eq (nth 2 t2) 1) + t1 + (math-solve-prod t1 (math-try-solve-for (nth 2 t2) 0 nil t))) + (calc-record-why "*Unable to find a symbolic solution") + nil)) + ((and (math-solve-find-root-term lhs nil) + (eq (math-expr-contains-count lhs t1) 1)) ; just in case + (math-try-solve-for (math-simplify + (math-sub (if (or t3 (math-evenp t2)) + (math-pow t1 t2) + (math-neg (math-pow t1 t2))) + (math-expand-power + (math-sub (math-normalize + (math-expr-subst + lhs t1 0)) + rhs) + t2 solve-var))) + 0)) + ((eq (car lhs) '+) + (cond ((not (math-expr-contains (nth 1 lhs) solve-var)) + (math-try-solve-for (nth 2 lhs) + (math-sub rhs (nth 1 lhs)) + sign)) + ((not (math-expr-contains (nth 2 lhs) solve-var)) + (math-try-solve-for (nth 1 lhs) + (math-sub rhs (nth 2 lhs)) + sign)))) + ((eq (car lhs) 'calcFunc-eq) + (math-try-solve-for (math-sub (nth 1 lhs) (nth 2 lhs)) + rhs sign no-poly)) + ((eq (car lhs) '-) + (cond ((or (and (eq (car-safe (nth 1 lhs)) 'calcFunc-sin) + (eq (car-safe (nth 2 lhs)) 'calcFunc-cos)) + (and (eq (car-safe (nth 1 lhs)) 'calcFunc-cos) + (eq (car-safe (nth 2 lhs)) 'calcFunc-sin))) + (math-try-solve-for (math-sub (nth 1 lhs) + (list (car (nth 1 lhs)) + (math-sub + (math-quarter-circle t) + (nth 1 (nth 2 lhs))))) + rhs)) + ((not (math-expr-contains (nth 1 lhs) solve-var)) + (math-try-solve-for (nth 2 lhs) + (math-sub (nth 1 lhs) rhs) + (and sign (- sign)))) + ((not (math-expr-contains (nth 2 lhs) solve-var)) + (math-try-solve-for (nth 1 lhs) + (math-add rhs (nth 2 lhs)) + sign)))) + ((and (eq solve-full 't) (math-try-solve-prod))) + ((and (eq (car lhs) '%) + (not (math-expr-contains (nth 2 lhs) solve-var))) + (math-try-solve-for (nth 1 lhs) (math-add rhs + (math-solve-get-int + (nth 2 lhs))))) + ((eq (car lhs) 'calcFunc-log) + (cond ((not (math-expr-contains (nth 2 lhs) solve-var)) + (math-try-solve-for (nth 1 lhs) (math-pow (nth 2 lhs) rhs))) + ((not (math-expr-contains (nth 1 lhs) solve-var)) + (math-try-solve-for (nth 2 lhs) (math-pow + (nth 1 lhs) + (math-div 1 rhs)))))) + ((and (= (length lhs) 2) + (symbolp (car lhs)) + (setq t1 (get (car lhs) 'math-inverse)) + (setq t2 (funcall t1 rhs))) + (setq t1 (get (car lhs) 'math-inverse-sign)) + (math-try-solve-for (nth 1 lhs) (math-normalize t2) + (and sign t1 + (if (integerp t1) + (* t1 sign) + (funcall t1 lhs sign))))) + ((and (symbolp (car lhs)) + (setq t1 (get (car lhs) 'math-inverse-n)) + (setq t2 (funcall t1 lhs rhs))) + t2) + ((setq t1 (math-expand-formula lhs)) + (math-try-solve-for t1 rhs sign)) + (t + (calc-record-why "*No inverse known" lhs) + nil))) +) + +(setq math-solve-ranges nil) + +(defun math-try-solve-prod () + (cond ((eq (car lhs) '*) + (cond ((not (math-expr-contains (nth 1 lhs) solve-var)) + (math-try-solve-for (nth 2 lhs) + (math-div rhs (nth 1 lhs)) + (math-solve-sign sign (nth 1 lhs)))) + ((not (math-expr-contains (nth 2 lhs) solve-var)) + (math-try-solve-for (nth 1 lhs) + (math-div rhs (nth 2 lhs)) + (math-solve-sign sign (nth 2 lhs)))) + ((Math-zerop rhs) + (math-solve-prod (let ((math-solve-ranges math-solve-ranges)) + (math-try-solve-for (nth 2 lhs) 0)) + (math-try-solve-for (nth 1 lhs) 0))))) + ((eq (car lhs) '/) + (cond ((not (math-expr-contains (nth 1 lhs) solve-var)) + (math-try-solve-for (nth 2 lhs) + (math-div (nth 1 lhs) rhs) + (math-solve-sign sign (nth 1 lhs)))) + ((not (math-expr-contains (nth 2 lhs) solve-var)) + (math-try-solve-for (nth 1 lhs) + (math-mul rhs (nth 2 lhs)) + (math-solve-sign sign (nth 2 lhs)))) + ((setq t1 (math-try-solve-for (math-sub (nth 1 lhs) + (math-mul (nth 2 lhs) + rhs)) + 0)) + t1))) + ((eq (car lhs) '^) + (cond ((not (math-expr-contains (nth 1 lhs) solve-var)) + (math-try-solve-for + (nth 2 lhs) + (math-add (math-normalize + (list 'calcFunc-log rhs (nth 1 lhs))) + (math-div + (math-mul 2 + (math-mul '(var pi var-pi) + (math-solve-get-int + '(var i var-i)))) + (math-normalize + (list 'calcFunc-ln (nth 1 lhs))))))) + ((not (math-expr-contains (nth 2 lhs) solve-var)) + (cond ((and (integerp (nth 2 lhs)) + (>= (nth 2 lhs) 2) + (setq t1 (math-integer-log2 (nth 2 lhs)))) + (setq t2 rhs) + (if (and (eq solve-full t) + (math-known-realp (nth 1 lhs))) + (progn + (while (>= (setq t1 (1- t1)) 0) + (setq t2 (list 'calcFunc-sqrt t2))) + (setq t2 (math-solve-get-sign t2))) + (while (>= (setq t1 (1- t1)) 0) + (setq t2 (math-solve-get-sign + (math-normalize + (list 'calcFunc-sqrt t2)))))) + (math-try-solve-for + (nth 1 lhs) + (math-normalize t2))) + ((math-looks-negp (nth 2 lhs)) + (math-try-solve-for + (list '^ (nth 1 lhs) (math-neg (nth 2 lhs))) + (math-div 1 rhs))) + ((and (eq solve-full t) + (Math-integerp (nth 2 lhs)) + (math-known-realp (nth 1 lhs))) + (setq t1 (math-normalize + (list 'calcFunc-nroot rhs (nth 2 lhs)))) + (if (math-evenp (nth 2 lhs)) + (setq t1 (math-solve-get-sign t1))) + (math-try-solve-for + (nth 1 lhs) t1 + (and sign + (math-oddp (nth 2 lhs)) + (math-solve-sign sign (nth 2 lhs))))) + (t (math-try-solve-for + (nth 1 lhs) + (math-mul + (math-normalize + (list 'calcFunc-exp + (if (Math-realp (nth 2 lhs)) + (math-div (math-mul + '(var pi var-pi) + (math-solve-get-int + '(var i var-i) + (and (integerp (nth 2 lhs)) + (math-abs + (nth 2 lhs))))) + (math-div (nth 2 lhs) 2)) + (math-div (math-mul + 2 + (math-mul + '(var pi var-pi) + (math-solve-get-int + '(var i var-i) + (and (integerp (nth 2 lhs)) + (math-abs + (nth 2 lhs)))))) + (nth 2 lhs))))) + (math-normalize + (list 'calcFunc-nroot + rhs + (nth 2 lhs)))) + (and sign + (math-oddp (nth 2 lhs)) + (math-solve-sign sign (nth 2 lhs))))))))) + (t nil)) +) + +(defun math-solve-prod (lsoln rsoln) + (cond ((null lsoln) + rsoln) + ((null rsoln) + lsoln) + ((eq solve-full 'all) + (cons 'vec (append (cdr lsoln) (cdr rsoln)))) + (solve-full + (list 'calcFunc-if + (list 'calcFunc-gt (math-solve-get-sign 1) 0) + lsoln + rsoln)) + (t lsoln)) +) + +;;; This deals with negative, fractional, and symbolic powers of "x". +(defun math-solve-poly-funny-powers (sub-rhs) ; uses "t1", "t2" + (setq t1 lhs) + (let ((pp math-poly-neg-powers) + fac) + (while pp + (setq fac (math-pow (car pp) (or math-poly-mult-powers 1)) + t1 (math-mul t1 fac) + rhs (math-mul rhs fac) + pp (cdr pp)))) + (if sub-rhs (setq t1 (math-sub t1 rhs))) + (let ((math-poly-neg-powers nil)) + (setq t2 (math-mul (or math-poly-mult-powers 1) + (let ((calc-prefer-frac t)) + (math-div 1 math-poly-frac-powers))) + t1 (math-is-polynomial (math-simplify (calcFunc-expand t1)) b 50))) +) + +;;; This converts "a x^8 + b x^5 + c x^2" to "(a (x^3)^2 + b (x^3) + c) * x^2". +(defun math-solve-crunch-poly (max-degree) ; uses "t1", "t3" + (let ((count 0)) + (while (and t1 (Math-zerop (car t1))) + (setq t1 (cdr t1) + count (1+ count))) + (and t1 + (let* ((degree (1- (length t1))) + (scale degree)) + (while (and (> scale 1) (= (car t3) 1)) + (and (= (% degree scale) 0) + (let ((p t1) + (n 0) + (new-t1 nil) + (okay t)) + (while (and p okay) + (if (= (% n scale) 0) + (setq new-t1 (nconc new-t1 (list (car p)))) + (or (Math-zerop (car p)) + (setq okay nil))) + (setq p (cdr p) + n (1+ n))) + (if okay + (setq t3 (cons scale (cdr t3)) + t1 new-t1)))) + (setq scale (1- scale))) + (setq t3 (list (math-mul (car t3) t2) (math-mul count t2))) + (<= (1- (length t1)) max-degree)))) +) + +(defun calcFunc-poly (expr var &optional degree) + (if degree + (or (natnump degree) (math-reject-arg degree 'fixnatnump)) + (setq degree 50)) + (let ((p (math-is-polynomial expr var degree 'gen))) + (if p + (if (equal p '(0)) + (list 'vec) + (cons 'vec p)) + (math-reject-arg expr "Expected a polynomial"))) +) + +(defun calcFunc-gpoly (expr var &optional degree) + (if degree + (or (natnump degree) (math-reject-arg degree 'fixnatnump)) + (setq degree 50)) + (let* ((math-poly-base-variable var) + (d (math-decompose-poly expr var degree nil))) + (if d + (cons 'vec d) + (math-reject-arg expr "Expected a polynomial"))) +) + +(defun math-decompose-poly (lhs solve-var degree sub-rhs) + (let ((rhs (or sub-rhs 1)) + t1 t2 t3) + (setq t2 (math-polynomial-base + lhs + (function + (lambda (b) + (let ((math-poly-neg-powers '(1)) + (math-poly-mult-powers nil) + (math-poly-frac-powers 1) + (math-poly-exp-base t)) + (and (not (equal b lhs)) + (or (not (memq (car-safe b) '(+ -))) sub-rhs) + (setq t3 '(1 0) t2 1 + t1 (math-is-polynomial lhs b 50)) + (if (and (equal math-poly-neg-powers '(1)) + (memq math-poly-mult-powers '(nil 1)) + (eq math-poly-frac-powers 1) + sub-rhs) + (setq t1 (cons (math-sub (car t1) rhs) + (cdr t1))) + (math-solve-poly-funny-powers sub-rhs)) + (math-solve-crunch-poly degree) + (or (math-expr-contains b solve-var) + (math-expr-contains (car t3) solve-var)))))))) + (if t2 + (list (math-pow t2 (car t3)) + (cons 'vec t1) + (if sub-rhs + (math-pow t2 (nth 1 t3)) + (math-div (math-pow t2 (nth 1 t3)) rhs))))) +) + +(defun math-solve-linear (var sign b a) + (math-try-solve-for var + (math-div (math-neg b) a) + (math-solve-sign sign a) + t) +) + +(defun math-solve-quadratic (var c b a) + (math-try-solve-for + var + (if (math-looks-evenp b) + (let ((halfb (math-div b 2))) + (math-div + (math-add + (math-neg halfb) + (math-solve-get-sign + (math-normalize + (list 'calcFunc-sqrt + (math-add (math-sqr halfb) + (math-mul (math-neg c) a)))))) + a)) + (math-div + (math-add + (math-neg b) + (math-solve-get-sign + (math-normalize + (list 'calcFunc-sqrt + (math-add (math-sqr b) + (math-mul 4 (math-mul (math-neg c) a))))))) + (math-mul 2 a))) + nil t) +) + +(defun math-solve-cubic (var d c b a) + (let* ((p (math-div b a)) + (q (math-div c a)) + (r (math-div d a)) + (psqr (math-sqr p)) + (aa (math-sub q (math-div psqr 3))) + (bb (math-add r + (math-div (math-sub (math-mul 2 (math-mul psqr p)) + (math-mul 9 (math-mul p q))) + 27))) + m) + (if (Math-zerop aa) + (math-try-solve-for (math-pow (math-add var (math-div p 3)) 3) + (math-neg bb) nil t) + (if (Math-zerop bb) + (math-try-solve-for + (math-mul (math-add var (math-div p 3)) + (math-add (math-sqr (math-add var (math-div p 3))) + aa)) + 0 nil t) + (setq m (math-mul 2 (list 'calcFunc-sqrt (math-div aa -3)))) + (math-try-solve-for + var + (math-sub + (math-normalize + (math-mul + m + (list 'calcFunc-cos + (math-div + (math-sub (list 'calcFunc-arccos + (math-div (math-mul 3 bb) + (math-mul aa m))) + (math-mul 2 + (math-mul + (math-add 1 (math-solve-get-int + 1 3)) + (math-half-circle + calc-symbolic-mode)))) + 3)))) + (math-div p 3)) + nil t)))) +) + +(defun math-solve-quartic (var d c b a aa) + (setq a (math-div a aa)) + (setq b (math-div b aa)) + (setq c (math-div c aa)) + (setq d (math-div d aa)) + (math-try-solve-for + var + (let* ((asqr (math-sqr a)) + (asqr4 (math-div asqr 4)) + (y (let ((solve-full nil) + calc-next-why) + (math-solve-cubic solve-var + (math-sub (math-sub + (math-mul 4 (math-mul b d)) + (math-mul asqr d)) + (math-sqr c)) + (math-sub (math-mul a c) + (math-mul 4 d)) + (math-neg b) + 1))) + (rsqr (math-add (math-sub asqr4 b) y)) + (r (list 'calcFunc-sqrt rsqr)) + (sign1 (math-solve-get-sign 1)) + (de (list 'calcFunc-sqrt + (math-add + (math-sub (math-mul 3 asqr4) + (math-mul 2 b)) + (if (Math-zerop rsqr) + (math-mul + 2 + (math-mul sign1 + (list 'calcFunc-sqrt + (math-sub (math-sqr y) + (math-mul 4 d))))) + (math-sub + (math-mul sign1 + (math-div + (math-sub (math-sub + (math-mul 4 (math-mul a b)) + (math-mul 8 c)) + (math-mul asqr a)) + (math-mul 4 r))) + rsqr)))))) + (math-normalize + (math-sub (math-add (math-mul sign1 (math-div r 2)) + (math-solve-get-sign (math-div de 2))) + (math-div a 4)))) + nil t) +) + +(defun math-poly-all-roots (var p &optional math-factoring) + (catch 'ouch + (let* ((math-symbolic-solve calc-symbolic-mode) + (roots nil) + (deg (1- (length p))) + (orig-p (reverse p)) + (math-int-coefs nil) + (math-int-scale nil) + (math-double-roots nil) + (math-int-factors nil) + (math-int-threshold nil) + (pp p)) + ;; If rational coefficients, look for exact rational factors. + (while (and pp (Math-ratp (car pp))) + (setq pp (cdr pp))) + (if pp + (if (or math-factoring math-symbolic-solve) + (throw 'ouch nil)) + (let ((lead (car orig-p)) + (calc-prefer-frac t) + (scale (apply 'math-lcm-denoms p))) + (setq math-int-scale (math-abs (math-mul scale lead)) + math-int-threshold (math-div '(float 5 -2) math-int-scale) + math-int-coefs (cdr (math-div (cons 'vec orig-p) lead))))) + (if (> deg 4) + (let ((calc-prefer-frac nil) + (calc-symbolic-mode nil) + (pp p) + (def-p (copy-sequence orig-p))) + (while pp + (if (Math-numberp (car pp)) + (setq pp (cdr pp)) + (throw 'ouch nil))) + (while (> deg (if math-symbolic-solve 2 4)) + (let* ((x (math-poly-any-root def-p '(float 0 0) nil)) + b c pp) + (if (and (eq (car-safe x) 'cplx) + (math-nearly-zerop (nth 2 x) (nth 1 x))) + (setq x (calcFunc-re x))) + (or math-factoring + (setq roots (cons x roots))) + (or (math-numberp x) + (setq x (math-evaluate-expr x))) + (setq pp def-p + b (car def-p)) + (while (setq pp (cdr pp)) + (setq c (car pp)) + (setcar pp b) + (setq b (math-add (math-mul x b) c))) + (setq def-p (cdr def-p) + deg (1- deg)))) + (setq p (reverse def-p)))) + (if (> deg 1) + (let ((solve-var '(var DUMMY var-DUMMY)) + (math-solve-sign nil) + (math-solve-ranges nil) + (solve-full 'all)) + (if (= (length p) (length math-int-coefs)) + (setq p (reverse math-int-coefs))) + (setq roots (append (cdr (apply (cond ((= deg 2) + 'math-solve-quadratic) + ((= deg 3) + 'math-solve-cubic) + (t + 'math-solve-quartic)) + solve-var p)) + roots))) + (if (> deg 0) + (setq roots (cons (math-div (math-neg (car p)) (nth 1 p)) + roots)))) + (if math-factoring + (progn + (while roots + (math-poly-integer-root (car roots)) + (setq roots (cdr roots))) + (list math-int-factors (nreverse math-int-coefs) math-int-scale)) + (let ((vec nil) res) + (while roots + (let ((root (car roots)) + (solve-full (and solve-full 'all))) + (if (math-floatp root) + (setq root (math-poly-any-root orig-p root t))) + (setq vec (append vec + (cdr (or (math-try-solve-for var root nil t) + (throw 'ouch nil)))))) + (setq roots (cdr roots))) + (setq vec (cons 'vec (nreverse vec))) + (if math-symbolic-solve + (setq vec (math-normalize vec))) + (if (eq solve-full t) + (list 'calcFunc-subscr + vec + (math-solve-get-int 1 (1- (length orig-p)) 1)) + vec))))) +) +(setq math-symbolic-solve nil) + +(defun math-lcm-denoms (&rest fracs) + (let ((den 1)) + (while fracs + (if (eq (car-safe (car fracs)) 'frac) + (setq den (calcFunc-lcm den (nth 2 (car fracs))))) + (setq fracs (cdr fracs))) + den) +) + +(defun math-poly-any-root (p x polish) ; p is a reverse poly coeff list + (let* ((newt (if (math-zerop x) + (math-poly-newton-root + p '(cplx (float 123 -6) (float 1 -4)) 4) + (math-poly-newton-root p x 4))) + (res (if (math-zerop (cdr newt)) + (car newt) + (if (and (math-lessp (cdr newt) '(float 1 -3)) (not polish)) + (setq newt (math-poly-newton-root p (car newt) 30))) + (if (math-zerop (cdr newt)) + (car newt) + (math-poly-laguerre-root p x polish))))) + (and math-symbolic-solve (math-floatp res) + (throw 'ouch nil)) + res) +) + +(defun math-poly-newton-root (p x iters) + (let* ((calc-prefer-frac nil) + (calc-symbolic-mode nil) + (try-integer math-int-coefs) + (dx x) b d) + (while (and (> (setq iters (1- iters)) 0) + (let ((pp p)) + (math-working "newton" x) + (setq b (car p) + d 0) + (while (setq pp (cdr pp)) + (setq d (math-add (math-mul x d) b) + b (math-add (math-mul x b) (car pp)))) + (not (math-zerop d))) + (progn + (setq dx (math-div b d) + x (math-sub x dx)) + (if try-integer + (let ((adx (math-abs-approx dx))) + (and (math-lessp adx math-int-threshold) + (let ((iroot (math-poly-integer-root x))) + (if iroot + (setq x iroot dx 0) + (setq try-integer nil)))))) + (or (not (or (eq dx 0) + (math-nearly-zerop dx (math-abs-approx x)))) + (progn (setq dx 0) nil))))) + (cons x (if (math-zerop x) + 1 (math-div (math-abs-approx dx) (math-abs-approx x))))) +) + +(defun math-poly-integer-root (x) + (and (math-lessp (calcFunc-xpon (math-abs-approx x)) calc-internal-prec) + math-int-coefs + (let* ((calc-prefer-frac t) + (xre (calcFunc-re x)) + (xim (calcFunc-im x)) + (xresq (math-sqr xre)) + (ximsq (math-sqr xim))) + (if (math-lessp ximsq (calcFunc-scf xresq -1)) + ;; Look for linear factor + (let* ((rnd (math-div (math-round (math-mul xre math-int-scale)) + math-int-scale)) + (icp math-int-coefs) + (rem (car icp)) + (newcoef nil)) + (while (setq icp (cdr icp)) + (setq newcoef (cons rem newcoef) + rem (math-add (car icp) + (math-mul rem rnd)))) + (and (math-zerop rem) + (progn + (setq math-int-coefs (nreverse newcoef) + math-int-factors (cons (list (math-neg rnd)) + math-int-factors)) + rnd))) + ;; Look for irreducible quadratic factor + (let* ((rnd1 (math-div (math-round + (math-mul xre (math-mul -2 math-int-scale))) + math-int-scale)) + (sqscale (math-sqr math-int-scale)) + (rnd0 (math-div (math-round (math-mul (math-add xresq ximsq) + sqscale)) + sqscale)) + (rem1 (car math-int-coefs)) + (icp (cdr math-int-coefs)) + (rem0 (car icp)) + (newcoef nil) + (found (assoc (list rnd0 rnd1 (math-posp xim)) + math-double-roots)) + this) + (if found + (setq math-double-roots (delq found math-double-roots) + rem0 0 rem1 0) + (while (setq icp (cdr icp)) + (setq this rem1 + newcoef (cons rem1 newcoef) + rem1 (math-sub rem0 (math-mul this rnd1)) + rem0 (math-sub (car icp) (math-mul this rnd0))))) + (and (math-zerop rem0) + (math-zerop rem1) + (let ((aa (math-div rnd1 -2))) + (or found (setq math-int-coefs (reverse newcoef) + math-double-roots (cons (list + (list + rnd0 rnd1 + (math-negp xim))) + math-double-roots) + math-int-factors (cons (cons rnd0 rnd1) + math-int-factors))) + (math-add aa + (let ((calc-symbolic-mode math-symbolic-solve)) + (math-mul (math-sqrt (math-sub (math-sqr aa) + rnd0)) + (if (math-negp xim) -1 1)))))))))) +) +(setq math-int-coefs nil) + +;;; The following routine is from Numerical Recipes, section 9.5. +(defun math-poly-laguerre-root (p x polish) + (let* ((calc-prefer-frac nil) + (calc-symbolic-mode nil) + (iters 0) + (m (1- (length p))) + (try-newt (not polish)) + (tried-newt nil) + b d f x1 dx dxold) + (while + (and (or (< (setq iters (1+ iters)) 50) + (math-reject-arg x "*Laguerre's method failed to converge")) + (let ((err (math-abs-approx (car p))) + (abx (math-abs-approx x)) + (pp p)) + (setq b (car p) + d 0 f 0) + (while (setq pp (cdr pp)) + (setq f (math-add (math-mul x f) d) + d (math-add (math-mul x d) b) + b (math-add (math-mul x b) (car pp)) + err (math-add (math-abs-approx b) (math-mul abx err)))) + (math-lessp (calcFunc-scf err (- -2 calc-internal-prec)) + (math-abs-approx b))) + (or (not (math-zerop d)) + (not (math-zerop f)) + (progn + (setq x (math-pow (math-neg b) (list 'frac 1 m))) + nil)) + (let* ((g (math-div d b)) + (g2 (math-sqr g)) + (h (math-sub g2 (math-mul 2 (math-div f b)))) + (sq (math-sqrt + (math-mul (1- m) (math-sub (math-mul m h) g2)))) + (gp (math-add g sq)) + (gm (math-sub g sq))) + (if (math-lessp (calcFunc-abssqr gp) (calcFunc-abssqr gm)) + (setq gp gm)) + (setq dx (math-div m gp) + x1 (math-sub x dx)) + (if (and try-newt + (math-lessp (math-abs-approx dx) + (calcFunc-scf (math-abs-approx x) -3))) + (let ((newt (math-poly-newton-root p x1 7))) + (setq tried-newt t + try-newt nil) + (if (math-zerop (cdr newt)) + (setq x (car newt) x1 x) + (if (math-lessp (cdr newt) '(float 1 -6)) + (let ((newt2 (math-poly-newton-root + p (car newt) 20))) + (if (math-zerop (cdr newt2)) + (setq x (car newt2) x1 x) + (setq x (car newt)))))))) + (not (or (eq x x1) + (math-nearly-equal x x1)))) + (let ((cdx (math-abs-approx dx))) + (setq x x1 + tried-newt nil) + (prog1 + (or (<= iters 6) + (math-lessp cdx dxold) + (progn + (if polish + (let ((digs (calcFunc-xpon + (math-div (math-abs-approx x) cdx)))) + (calc-record-why + "*Could not attain full precision") + (if (natnump digs) + (let ((calc-internal-prec (max 3 digs))) + (setq x (math-normalize x)))))) + nil)) + (setq dxold cdx))) + (or polish + (math-lessp (calcFunc-scf (math-abs-approx x) + (- calc-internal-prec)) + dxold)))) + (or (and (math-floatp x) + (math-poly-integer-root x)) + x)) +) + +(defun math-solve-above-dummy (x) + (and (not (Math-primp x)) + (if (and (equal (nth 1 x) '(var SOLVEDUM SOLVEDUM)) + (= (length x) 2)) + x + (let ((res nil)) + (while (and (setq x (cdr x)) + (not (setq res (math-solve-above-dummy (car x)))))) + res))) +) + +(defun math-solve-find-root-term (x neg) ; sets "t2", "t3" + (if (math-solve-find-root-in-prod x) + (setq t3 neg + t1 x) + (and (memq (car-safe x) '(+ -)) + (or (math-solve-find-root-term (nth 1 x) neg) + (math-solve-find-root-term (nth 2 x) + (if (eq (car x) '-) (not neg) neg))))) +) + +(defun math-solve-find-root-in-prod (x) + (and (consp x) + (math-expr-contains x solve-var) + (or (and (eq (car x) 'calcFunc-sqrt) + (setq t2 2)) + (and (eq (car x) '^) + (or (and (memq (math-quarter-integer (nth 2 x)) '(1 2 3)) + (setq t2 2)) + (and (eq (car-safe (nth 2 x)) 'frac) + (eq (nth 2 (nth 2 x)) 3) + (setq t2 3)))) + (and (memq (car x) '(* /)) + (or (and (not (math-expr-contains (nth 1 x) solve-var)) + (math-solve-find-root-in-prod (nth 2 x))) + (and (not (math-expr-contains (nth 2 x) solve-var)) + (math-solve-find-root-in-prod (nth 1 x))))))) +) + + +(defun math-solve-system (exprs solve-vars solve-full) + (setq exprs (mapcar 'list (if (Math-vectorp exprs) + (cdr exprs) + (list exprs))) + solve-vars (if (Math-vectorp solve-vars) + (cdr solve-vars) + (list solve-vars))) + (or (let ((math-solve-simplifying nil)) + (math-solve-system-rec exprs solve-vars nil)) + (let ((math-solve-simplifying t)) + (math-solve-system-rec exprs solve-vars nil))) +) + +;;; The following backtracking solver works by choosing a variable +;;; and equation, and trying to solve the equation for the variable. +;;; If it succeeds it calls itself recursively with that variable and +;;; equation removed from their respective lists, and with the solution +;;; added to solns as well as being substituted into all existing +;;; equations. The algorithm terminates when any solution path +;;; manages to remove all the variables from var-list. + +;;; To support calcFunc-roots, entries in eqn-list and solns are +;;; actually lists of equations. + +(defun math-solve-system-rec (eqn-list var-list solns) + (if var-list + (let ((v var-list) + (res nil)) + + ;; Try each variable in turn. + (while + (and + v + (let* ((vv (car v)) + (e eqn-list) + (elim (eq (car-safe vv) 'calcFunc-elim))) + (if elim + (setq vv (nth 1 vv))) + + ;; Try each equation in turn. + (while + (and + e + (let ((e2 (car e)) + (eprev nil) + res2) + (setq res nil) + + ;; Try to solve for vv the list of equations e2. + (while (and e2 + (setq res2 (or (and (eq (car e2) eprev) + res2) + (math-solve-for (car e2) 0 vv + solve-full)))) + (setq eprev (car e2) + res (cons (if (eq solve-full 'all) + (cdr res2) + (list res2)) + res) + e2 (cdr e2))) + (if e2 + (setq res nil) + + ;; Found a solution. Now try other variables. + (setq res (nreverse res) + res (math-solve-system-rec + (mapcar + 'math-solve-system-subst + (delq (car e) + (copy-sequence eqn-list))) + (delq (car v) (copy-sequence var-list)) + (let ((math-solve-simplifying nil) + (s (mapcar + (function + (lambda (x) + (cons + (car x) + (math-solve-system-subst + (cdr x))))) + solns))) + (if elim + s + (cons (cons vv (apply 'append res)) + s))))) + (not res)))) + (setq e (cdr e))) + (not res))) + (setq v (cdr v))) + res) + + ;; Eliminated all variables, so now put solution into the proper format. + (setq solns (sort solns + (function + (lambda (x y) + (not (memq (car x) (memq (car y) solve-vars))))))) + (if (eq solve-full 'all) + (math-transpose + (math-normalize + (cons 'vec + (if solns + (mapcar (function (lambda (x) (cons 'vec (cdr x)))) solns) + (mapcar (function (lambda (x) (cons 'vec x))) eqn-list))))) + (math-normalize + (cons 'vec + (if solns + (mapcar (function (lambda (x) (cons 'calcFunc-eq x))) solns) + (mapcar 'car eqn-list)))))) +) + +(defun math-solve-system-subst (x) ; uses "res" and "v" + (let ((accum nil) + (res2 res)) + (while x + (setq accum (nconc accum + (mapcar (function + (lambda (r) + (if math-solve-simplifying + (math-simplify + (math-expr-subst (car x) vv r)) + (math-expr-subst (car x) vv r)))) + (car res2))) + x (cdr x) + res2 (cdr res2))) + accum) +) + + +(defun math-get-from-counter (name) + (let ((ctr (assq name calc-command-flags))) + (if ctr + (setcdr ctr (1+ (cdr ctr))) + (setq ctr (cons name 1) + calc-command-flags (cons ctr calc-command-flags))) + (cdr ctr)) +) + +(defun math-solve-get-sign (val) + (setq val (math-simplify val)) + (if (and (eq (car-safe val) '*) + (Math-numberp (nth 1 val))) + (list '* (nth 1 val) (math-solve-get-sign (nth 2 val))) + (and (eq (car-safe val) 'calcFunc-sqrt) + (eq (car-safe (nth 1 val)) '^) + (setq val (math-normalize (list '^ + (nth 1 (nth 1 val)) + (math-div (nth 2 (nth 1 val)) 2))))) + (if solve-full + (if (and (calc-var-value 'var-GenCount) + (Math-natnump var-GenCount) + (not (eq solve-full 'all))) + (prog1 + (math-mul (list 'calcFunc-as var-GenCount) val) + (setq var-GenCount (math-add var-GenCount 1)) + (calc-refresh-evaltos 'var-GenCount)) + (let* ((var (concat "s" (math-get-from-counter 'solve-sign))) + (var2 (list 'var (intern var) (intern (concat "var-" var))))) + (if (eq solve-full 'all) + (setq math-solve-ranges (cons (list var2 1 -1) + math-solve-ranges))) + (math-mul var2 val))) + (calc-record-why "*Choosing positive solution") + val)) +) + +(defun math-solve-get-int (val &optional range first) + (if solve-full + (if (and (calc-var-value 'var-GenCount) + (Math-natnump var-GenCount) + (not (eq solve-full 'all))) + (prog1 + (math-mul val (list 'calcFunc-an var-GenCount)) + (setq var-GenCount (math-add var-GenCount 1)) + (calc-refresh-evaltos 'var-GenCount)) + (let* ((var (concat "n" (math-get-from-counter 'solve-int))) + (var2 (list 'var (intern var) (intern (concat "var-" var))))) + (if (and range (eq solve-full 'all)) + (setq math-solve-ranges (cons (cons var2 + (cdr (calcFunc-index + range (or first 0)))) + math-solve-ranges))) + (math-mul val var2))) + (calc-record-why "*Choosing 0 for arbitrary integer in solution") + 0) +) + +(defun math-solve-sign (sign expr) + (and sign + (let ((s1 (math-possible-signs expr))) + (cond ((memq s1 '(4 6)) + sign) + ((memq s1 '(1 3)) + (- sign))))) +) + +(defun math-looks-evenp (expr) + (if (Math-integerp expr) + (math-evenp expr) + (if (memq (car expr) '(* /)) + (math-looks-evenp (nth 1 expr)))) +) + +(defun math-solve-for (lhs rhs solve-var solve-full &optional sign) + (if (math-expr-contains rhs solve-var) + (math-solve-for (math-sub lhs rhs) 0 solve-var solve-full) + (and (math-expr-contains lhs solve-var) + (math-with-extra-prec 1 + (let* ((math-poly-base-variable solve-var) + (res (math-try-solve-for lhs rhs sign))) + (if (and (eq solve-full 'all) + (math-known-realp solve-var)) + (let ((old-len (length res)) + new-len) + (setq res (delq nil + (mapcar (function + (lambda (x) + (and (not (memq (car-safe x) + '(cplx polar))) + x))) + res)) + new-len (length res)) + (if (< new-len old-len) + (calc-record-why (if (= new-len 1) + "*All solutions were complex" + (format + "*Omitted %d complex solutions" + (- old-len new-len))))))) + res)))) +) + +(defun math-solve-eqn (expr var full) + (if (memq (car-safe expr) '(calcFunc-neq calcFunc-lt calcFunc-gt + calcFunc-leq calcFunc-geq)) + (let ((res (math-solve-for (cons '- (cdr expr)) + 0 var full + (if (eq (car expr) 'calcFunc-neq) nil 1)))) + (and res + (if (eq math-solve-sign 1) + (list (car expr) var res) + (if (eq math-solve-sign -1) + (list (car expr) res var) + (or (eq (car expr) 'calcFunc-neq) + (calc-record-why + "*Can't determine direction of inequality")) + (and (memq (car expr) '(calcFunc-neq calcFunc-lt calcFunc-gt)) + (list 'calcFunc-neq var res)))))) + (let ((res (math-solve-for expr 0 var full))) + (and res + (list 'calcFunc-eq var res)))) +) + +(defun math-reject-solution (expr var func) + (if (math-expr-contains expr var) + (or (equal (car calc-next-why) '(* "Unable to find a symbolic solution")) + (calc-record-why "*Unable to find a solution"))) + (list func expr var) +) + +(defun calcFunc-solve (expr var) + (or (if (or (Math-vectorp expr) (Math-vectorp var)) + (math-solve-system expr var nil) + (math-solve-eqn expr var nil)) + (math-reject-solution expr var 'calcFunc-solve)) +) + +(defun calcFunc-fsolve (expr var) + (or (if (or (Math-vectorp expr) (Math-vectorp var)) + (math-solve-system expr var t) + (math-solve-eqn expr var t)) + (math-reject-solution expr var 'calcFunc-fsolve)) +) + +(defun calcFunc-roots (expr var) + (let ((math-solve-ranges nil)) + (or (if (or (Math-vectorp expr) (Math-vectorp var)) + (math-solve-system expr var 'all) + (math-solve-for expr 0 var 'all)) + (math-reject-solution expr var 'calcFunc-roots))) +) + +(defun calcFunc-finv (expr var) + (let ((res (math-solve-for expr math-integ-var var nil))) + (if res + (math-normalize (math-expr-subst res math-integ-var var)) + (math-reject-solution expr var 'calcFunc-finv))) +) + +(defun calcFunc-ffinv (expr var) + (let ((res (math-solve-for expr math-integ-var var t))) + (if res + (math-normalize (math-expr-subst res math-integ-var var)) + (math-reject-solution expr var 'calcFunc-finv))) +) + + +(put 'calcFunc-inv 'math-inverse + (function (lambda (x) (math-div 1 x)))) +(put 'calcFunc-inv 'math-inverse-sign -1) + +(put 'calcFunc-sqrt 'math-inverse + (function (lambda (x) (math-sqr x)))) + +(put 'calcFunc-conj 'math-inverse + (function (lambda (x) (list 'calcFunc-conj x)))) + +(put 'calcFunc-abs 'math-inverse + (function (lambda (x) (math-solve-get-sign x)))) + +(put 'calcFunc-deg 'math-inverse + (function (lambda (x) (list 'calcFunc-rad x)))) +(put 'calcFunc-deg 'math-inverse-sign 1) + +(put 'calcFunc-rad 'math-inverse + (function (lambda (x) (list 'calcFunc-deg x)))) +(put 'calcFunc-rad 'math-inverse-sign 1) + +(put 'calcFunc-ln 'math-inverse + (function (lambda (x) (list 'calcFunc-exp x)))) +(put 'calcFunc-ln 'math-inverse-sign 1) + +(put 'calcFunc-log10 'math-inverse + (function (lambda (x) (list 'calcFunc-exp10 x)))) +(put 'calcFunc-log10 'math-inverse-sign 1) + +(put 'calcFunc-lnp1 'math-inverse + (function (lambda (x) (list 'calcFunc-expm1 x)))) +(put 'calcFunc-lnp1 'math-inverse-sign 1) + +(put 'calcFunc-exp 'math-inverse + (function (lambda (x) (math-add (math-normalize (list 'calcFunc-ln x)) + (math-mul 2 + (math-mul '(var pi var-pi) + (math-solve-get-int + '(var i var-i)))))))) +(put 'calcFunc-exp 'math-inverse-sign 1) + +(put 'calcFunc-expm1 'math-inverse + (function (lambda (x) (math-add (math-normalize (list 'calcFunc-lnp1 x)) + (math-mul 2 + (math-mul '(var pi var-pi) + (math-solve-get-int + '(var i var-i)))))))) +(put 'calcFunc-expm1 'math-inverse-sign 1) + +(put 'calcFunc-sin 'math-inverse + (function (lambda (x) (let ((n (math-solve-get-int 1))) + (math-add (math-mul (math-normalize + (list 'calcFunc-arcsin x)) + (math-pow -1 n)) + (math-mul (math-half-circle t) + n)))))) + +(put 'calcFunc-cos 'math-inverse + (function (lambda (x) (math-add (math-solve-get-sign + (math-normalize + (list 'calcFunc-arccos x))) + (math-solve-get-int + (math-full-circle t)))))) + +(put 'calcFunc-tan 'math-inverse + (function (lambda (x) (math-add (math-normalize (list 'calcFunc-arctan x)) + (math-solve-get-int + (math-half-circle t)))))) + +(put 'calcFunc-arcsin 'math-inverse + (function (lambda (x) (math-normalize (list 'calcFunc-sin x))))) + +(put 'calcFunc-arccos 'math-inverse + (function (lambda (x) (math-normalize (list 'calcFunc-cos x))))) + +(put 'calcFunc-arctan 'math-inverse + (function (lambda (x) (math-normalize (list 'calcFunc-tan x))))) + +(put 'calcFunc-sinh 'math-inverse + (function (lambda (x) (let ((n (math-solve-get-int 1))) + (math-add (math-mul (math-normalize + (list 'calcFunc-arcsinh x)) + (math-pow -1 n)) + (math-mul (math-half-circle t) + (math-mul + '(var i var-i) + n))))))) +(put 'calcFunc-sinh 'math-inverse-sign 1) + +(put 'calcFunc-cosh 'math-inverse + (function (lambda (x) (math-add (math-solve-get-sign + (math-normalize + (list 'calcFunc-arccosh x))) + (math-mul (math-full-circle t) + (math-solve-get-int + '(var i var-i))))))) + +(put 'calcFunc-tanh 'math-inverse + (function (lambda (x) (math-add (math-normalize + (list 'calcFunc-arctanh x)) + (math-mul (math-half-circle t) + (math-solve-get-int + '(var i var-i))))))) +(put 'calcFunc-tanh 'math-inverse-sign 1) + +(put 'calcFunc-arcsinh 'math-inverse + (function (lambda (x) (math-normalize (list 'calcFunc-sinh x))))) +(put 'calcFunc-arcsinh 'math-inverse-sign 1) + +(put 'calcFunc-arccosh 'math-inverse + (function (lambda (x) (math-normalize (list 'calcFunc-cosh x))))) + +(put 'calcFunc-arctanh 'math-inverse + (function (lambda (x) (math-normalize (list 'calcFunc-tanh x))))) +(put 'calcFunc-arctanh 'math-inverse-sign 1) + + + +(defun calcFunc-taylor (expr var num) + (let ((x0 0) (v var)) + (if (memq (car-safe var) '(+ - calcFunc-eq)) + (setq x0 (if (eq (car var) '+) (math-neg (nth 2 var)) (nth 2 var)) + v (nth 1 var))) + (or (and (eq (car-safe v) 'var) + (math-expr-contains expr v) + (natnump num) + (let ((accum (math-expr-subst expr v x0)) + (var2 (if (eq (car var) 'calcFunc-eq) + (cons '- (cdr var)) + var)) + (n 0) + (nfac 1) + (fprime expr)) + (while (and (<= (setq n (1+ n)) num) + (setq fprime (calcFunc-deriv fprime v nil t))) + (setq fprime (math-simplify fprime) + nfac (math-mul nfac n) + accum (math-add accum + (math-div (math-mul (math-pow var2 n) + (math-expr-subst + fprime v x0)) + nfac)))) + (and fprime + (math-normalize accum)))) + (list 'calcFunc-taylor expr var num))) +) + + + + diff --git a/lisp/calc/calcalg3.el b/lisp/calc/calcalg3.el new file mode 100644 index 0000000000..bb04ef900f --- /dev/null +++ b/lisp/calc/calcalg3.el @@ -0,0 +1,1824 @@ +;; Calculator for GNU Emacs, part II [calc-alg-3.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-alg-3 () nil) + + +(defun calc-find-root (var) + (interactive "sVariable(s) to solve for: ") + (calc-slow-wrapper + (let ((func (if (calc-is-hyperbolic) 'calcFunc-wroot 'calcFunc-root))) + (if (or (equal var "") (equal var "$")) + (calc-enter-result 2 "root" (list func + (calc-top-n 3) + (calc-top-n 1) + (calc-top-n 2))) + (let ((var (if (and (string-match ",\\|[^ ] +[^ ]" var) + (not (string-match "\\[" var))) + (math-read-expr (concat "[" var "]")) + (math-read-expr var)))) + (if (eq (car-safe var) 'error) + (error "Bad format in expression: %s" (nth 1 var))) + (calc-enter-result 1 "root" (list func + (calc-top-n 2) + var + (calc-top-n 1))))))) +) + +(defun calc-find-minimum (var) + (interactive "sVariable(s) to minimize over: ") + (calc-slow-wrapper + (let ((func (if (calc-is-inverse) + (if (calc-is-hyperbolic) + 'calcFunc-wmaximize 'calcFunc-maximize) + (if (calc-is-hyperbolic) + 'calcFunc-wminimize 'calcFunc-minimize))) + (tag (if (calc-is-inverse) "max" "min"))) + (if (or (equal var "") (equal var "$")) + (calc-enter-result 2 tag (list func + (calc-top-n 3) + (calc-top-n 1) + (calc-top-n 2))) + (let ((var (if (and (string-match ",\\|[^ ] +[^ ]" var) + (not (string-match "\\[" var))) + (math-read-expr (concat "[" var "]")) + (math-read-expr var)))) + (if (eq (car-safe var) 'error) + (error "Bad format in expression: %s" (nth 1 var))) + (calc-enter-result 1 tag (list func + (calc-top-n 2) + var + (calc-top-n 1))))))) +) + +(defun calc-find-maximum (var) + (interactive "sVariable to maximize over: ") + (calc-invert-func) + (calc-find-minimum var) +) + + +(defun calc-poly-interp (arg) + (interactive "P") + (calc-slow-wrapper + (let ((data (calc-top 2))) + (if (or (consp arg) (eq arg 0) (eq arg 2)) + (setq data (cons 'vec (calc-top-list 2 2))) + (or (null arg) + (error "Bad prefix argument"))) + (if (calc-is-hyperbolic) + (calc-enter-result 1 "rati" (list 'calcFunc-ratint data (calc-top 1))) + (calc-enter-result 1 "poli" (list 'calcFunc-polint data + (calc-top 1)))))) +) + + +(defun calc-curve-fit (arg &optional model coefnames varnames) + (interactive "P") + (calc-slow-wrapper + (setq calc-aborted-prefix nil) + (let ((func (if (calc-is-inverse) 'calcFunc-xfit + (if (calc-is-hyperbolic) 'calcFunc-efit + 'calcFunc-fit))) + key (which 0) + n nvars temp data + (homog nil) + (msgs '( "(Press ? for help)" + "1 = linear or multilinear" + "2-9 = polynomial fits; i = interpolating polynomial" + "p = a x^b, ^ = a b^x" + "e = a exp(b x), x = exp(a + b x), l = a + b ln(x)" + "E = a 10^(b x), X = 10^(a + b x), L = a + b log10(x)" + "q = a + b (x-c)^2" + "g = (a/b sqrt(2 pi)) exp(-0.5*((x-c)/b)^2)" + "h prefix = homogeneous model (no constant term)" + "' = alg entry, $ = stack, u = Model1, U = Model2"))) + (while (not model) + (message "Fit to model: %s:%s" + (nth which msgs) + (if homog " h" "")) + (setq key (read-char)) + (cond ((= key ?\C-g) + (keyboard-quit)) + ((= key ??) + (setq which (% (1+ which) (length msgs)))) + ((memq key '(?h ?H)) + (setq homog (not homog))) + ((progn + (if (eq key ?\$) + (setq n 1) + (setq n 0)) + (cond ((null arg) + (setq n (1+ n) + data (calc-top n))) + ((or (consp arg) (eq arg 0)) + (setq n (+ n 2) + data (calc-top n) + data (if (math-matrixp data) + (append data (list (calc-top (1- n)))) + (list 'vec data (calc-top (1- n)))))) + ((> (setq arg (prefix-numeric-value arg)) 0) + (setq data (cons 'vec (calc-top-list arg (1+ n))) + n (+ n arg))) + (t (error "Bad prefix argument"))) + (or (math-matrixp data) (not (cdr (cdr data))) + (error "Data matrix is not a matrix!")) + (setq nvars (- (length data) 2) + coefnames nil + varnames nil) + nil)) + ((= key ?1) ; linear or multilinear + (calc-get-fit-variables nvars (1+ nvars) (and homog 0)) + (setq model (math-mul coefnames + (cons 'vec (cons 1 (cdr varnames)))))) + ((and (>= key ?2) (<= key ?9)) ; polynomial + (calc-get-fit-variables 1 (- key ?0 -1) (and homog 0)) + (setq model (math-build-polynomial-expr (cdr coefnames) + (nth 1 varnames)))) + ((= key ?i) ; exact polynomial + (calc-get-fit-variables 1 (1- (length (nth 1 data))) + (and homog 0)) + (setq model (math-build-polynomial-expr (cdr coefnames) + (nth 1 varnames)))) + ((= key ?p) ; power law + (calc-get-fit-variables nvars (1+ nvars) (and homog 1)) + (setq model (math-mul (nth 1 coefnames) + (calcFunc-reduce + '(var mul var-mul) + (calcFunc-map + '(var pow var-pow) + varnames + (cons 'vec (cdr (cdr coefnames)))))))) + ((= key ?^) ; exponential law + (calc-get-fit-variables nvars (1+ nvars) (and homog 1)) + (setq model (math-mul (nth 1 coefnames) + (calcFunc-reduce + '(var mul var-mul) + (calcFunc-map + '(var pow var-pow) + (cons 'vec (cdr (cdr coefnames))) + varnames))))) + ((memq key '(?e ?E)) + (calc-get-fit-variables nvars (1+ nvars) (and homog 1)) + (setq model (math-mul (nth 1 coefnames) + (calcFunc-reduce + '(var mul var-mul) + (calcFunc-map + (if (eq key ?e) + '(var exp var-exp) + '(calcFunc-lambda + (var a var-a) + (^ 10 (var a var-a)))) + (calcFunc-map + '(var mul var-mul) + (cons 'vec (cdr (cdr coefnames))) + varnames)))))) + ((memq key '(?x ?X)) + (calc-get-fit-variables nvars (1+ nvars) (and homog 0)) + (setq model (math-mul coefnames + (cons 'vec (cons 1 (cdr varnames))))) + (setq model (if (eq key ?x) + (list 'calcFunc-exp model) + (list '^ 10 model)))) + ((memq key '(?l ?L)) + (calc-get-fit-variables nvars (1+ nvars) (and homog 0)) + (setq model (math-mul coefnames + (cons 'vec + (cons 1 (cdr (calcFunc-map + (if (eq key ?l) + '(var ln var-ln) + '(var log10 + var-log10)) + varnames))))))) + ((= key ?q) + (calc-get-fit-variables nvars (1+ (* 2 nvars)) (and homog 0)) + (let ((c coefnames) + (v varnames)) + (setq model (nth 1 c)) + (while (setq v (cdr v) c (cdr (cdr c))) + (setq model (math-add + model + (list '* + (car c) + (list '^ + (list '- (car v) (nth 1 c)) + 2))))))) + ((= key ?g) + (setq model (math-read-expr "(AFit / BFit sqrt(2 pi)) exp(-0.5 * ((XFit - CFit) / BFit)^2)") + varnames '(vec (var XFit var-XFit)) + coefnames '(vec (var AFit var-AFit) + (var BFit var-BFit) + (var CFit var-CFit))) + (calc-get-fit-variables 1 (1- (length coefnames)) (and homog 1))) + ((memq key '(?\$ ?\' ?u ?U)) + (let* ((defvars nil) + (record-entry nil)) + (if (eq key ?\') + (let* ((calc-dollar-values calc-arg-values) + (calc-dollar-used 0) + (calc-hashes-used 0)) + (setq model (calc-do-alg-entry "" "Model formula: ")) + (if (/= (length model) 1) + (error "Bad format")) + (setq model (car model) + record-entry t) + (if (> calc-dollar-used 0) + (setq coefnames + (cons 'vec + (nthcdr (- (length calc-arg-values) + calc-dollar-used) + (reverse calc-arg-values)))) + (if (> calc-hashes-used 0) + (setq coefnames + (cons 'vec (calc-invent-args + calc-hashes-used)))))) + (progn + (setq model (cond ((eq key ?u) + (calc-var-value 'var-Model1)) + ((eq key ?U) + (calc-var-value 'var-Model2)) + (t (calc-top 1)))) + (or model (error "User model not yet defined")) + (if (math-vectorp model) + (if (and (memq (length model) '(3 4)) + (not (math-objvecp (nth 1 model))) + (math-vectorp (nth 2 model)) + (or (null (nth 3 model)) + (math-vectorp (nth 3 model)))) + (setq varnames (nth 2 model) + coefnames (or (nth 3 model) + (cons 'vec + (math-all-vars-but + model varnames))) + model (nth 1 model)) + (error "Incorrect model specifier"))))) + (or varnames + (let ((with-y (eq (car-safe model) 'calcFunc-eq))) + (if coefnames + (calc-get-fit-variables (if with-y (1+ nvars) nvars) + (1- (length coefnames)) + (math-all-vars-but + model coefnames) + nil with-y) + (let* ((coefs (math-all-vars-but model nil)) + (vars nil) + (n (- (length coefs) nvars (if with-y 2 1))) + p) + (if (< n 0) + (error "Not enough variables in model")) + (setq p (nthcdr n coefs)) + (setq vars (cdr p)) + (setcdr p nil) + (calc-get-fit-variables (if with-y (1+ nvars) nvars) + (length coefs) + vars coefs with-y))))) + (if record-entry + (calc-record (list 'vec model varnames coefnames) + "modl")))) + (t (beep)))) + (let ((calc-fit-to-trail t)) + (calc-enter-result n (substring (symbol-name func) 9) + (list func model + (if (= (length varnames) 2) + (nth 1 varnames) + varnames) + (if (= (length coefnames) 2) + (nth 1 coefnames) + coefnames) + data)) + (if (consp calc-fit-to-trail) + (calc-record (calc-normalize calc-fit-to-trail) "parm"))))) +) + +(defun calc-invent-independent-variables (n &optional but) + (calc-invent-variables n but '(x y z t) "x") +) + +(defun calc-invent-parameter-variables (n &optional but) + (calc-invent-variables n but '(a b c d) "a") +) + +(defun calc-invent-variables (num but names base) + (let ((vars nil) + (n num) (nn 0) + var) + (while (and (> n 0) names) + (setq var (math-build-var-name (if (consp names) + (car names) + (concat base (setq nn (1+ nn)))))) + (or (math-expr-contains (cons 'vec but) var) + (setq vars (cons var vars) + n (1- n))) + (or (symbolp names) (setq names (cdr names)))) + (if (= n 0) + (nreverse vars) + (calc-invent-variables num but t base))) +) + +(defun calc-get-fit-variables (nv nc &optional defv defc with-y homog) + (or (= nv (if with-y (1+ nvars) nvars)) + (error "Wrong number of data vectors for this type of model")) + (if (integerp defv) + (setq homog defv + defv nil)) + (if homog + (setq nc (1- nc))) + (or defv + (setq defv (calc-invent-independent-variables nv))) + (or defc + (setq defc (calc-invent-parameter-variables nc defv))) + (let ((vars (read-string (format "Fitting variables: (default %s; %s) " + (mapconcat 'symbol-name + (mapcar (function (lambda (v) + (nth 1 v))) + defv) + ",") + (mapconcat 'symbol-name + (mapcar (function (lambda (v) + (nth 1 v))) + defc) + ",")))) + (coefs nil)) + (setq vars (if (string-match "\\[" vars) + (math-read-expr vars) + (math-read-expr (concat "[" vars "]")))) + (if (eq (car-safe vars) 'error) + (error "Bad format in expression: %s" (nth 2 vars))) + (or (math-vectorp vars) + (error "Expected a variable or vector of variables")) + (if (equal vars '(vec)) + (setq vars (cons 'vec defv) + coefs (cons 'vec defc)) + (if (math-vectorp (nth 1 vars)) + (if (and (= (length vars) 3) + (math-vectorp (nth 2 vars))) + (setq coefs (nth 2 vars) + vars (nth 1 vars)) + (error + "Expected independent variables vector, then parameters vector")) + (setq coefs (cons 'vec defc)))) + (or (= nv (1- (length vars))) + (and (not with-y) (= (1+ nv) (1- (length vars)))) + (error "Expected %d independent variable%s" nv (if (= nv 1) "" "s"))) + (or (= nc (1- (length coefs))) + (error "Expected %d parameter variable%s" nc (if (= nc 1) "" "s"))) + (if homog + (setq coefs (cons 'vec (cons homog (cdr coefs))))) + (if varnames + (setq model (math-multi-subst model (cdr varnames) (cdr vars)))) + (if coefnames + (setq model (math-multi-subst model (cdr coefnames) (cdr coefs)))) + (setq varnames vars + coefnames coefs)) +) + + + + +;;; The following algorithms are from Numerical Recipes chapter 9. + +;;; "rtnewt" with safety kludges +(defun math-newton-root (expr deriv guess orig-guess limit) + (math-working "newton" guess) + (let* ((var-DUMMY guess) + next dval) + (setq next (math-evaluate-expr expr) + dval (math-evaluate-expr deriv)) + (if (and (Math-numberp next) + (Math-numberp dval) + (not (Math-zerop dval))) + (progn + (setq next (math-sub guess (math-div next dval))) + (if (math-nearly-equal guess (setq next (math-float next))) + (progn + (setq var-DUMMY next) + (list 'vec next (math-evaluate-expr expr))) + (if (Math-lessp (math-abs-approx (math-sub next orig-guess)) + limit) + (math-newton-root expr deriv next orig-guess limit) + (math-reject-arg next "*Newton's method failed to converge")))) + (math-reject-arg next "*Newton's method encountered a singularity"))) +) + +;;; Inspired by "rtsafe" +(defun math-newton-search-root (expr deriv guess vguess ostep oostep + low vlow high vhigh) + (let ((var-DUMMY guess) + (better t) + pos step next vnext) + (if guess + (math-working "newton" (list 'intv 0 low high)) + (math-working "bisect" (list 'intv 0 low high)) + (setq ostep (math-mul-float (math-sub-float high low) + '(float 5 -1)) + guess (math-add-float low ostep) + var-DUMMY guess + vguess (math-evaluate-expr expr)) + (or (Math-realp vguess) + (progn + (setq ostep (math-mul-float ostep '(float 6 -1)) + guess (math-add-float low ostep) + var-DUMMY guess + vguess (math-evaluate-expr expr)) + (or (math-realp vguess) + (progn + (setq ostep (math-mul-float ostep '(float 123456 -5)) + guess (math-add-float low ostep) + var-DUMMY guess + vguess nil)))))) + (or vguess + (setq vguess (math-evaluate-expr expr))) + (or (Math-realp vguess) + (math-reject-arg guess "*Newton's method encountered a singularity")) + (setq vguess (math-float vguess)) + (if (eq (Math-negp vlow) (setq pos (Math-posp vguess))) + (setq high guess + vhigh vguess) + (if (eq (Math-negp vhigh) pos) + (setq low guess + vlow vguess) + (setq better nil))) + (if (or (Math-zerop vguess) + (math-nearly-equal low high)) + (list 'vec guess vguess) + (setq step (math-evaluate-expr deriv)) + (if (and (Math-realp step) + (not (Math-zerop step)) + (setq step (math-div-float vguess (math-float step)) + next (math-sub-float guess step)) + (not (math-lessp-float high next)) + (not (math-lessp-float next low))) + (progn + (setq var-DUMMY next + vnext (math-evaluate-expr expr)) + (if (or (Math-zerop vnext) + (math-nearly-equal next guess)) + (list 'vec next vnext) + (if (and better + (math-lessp-float (math-abs (or oostep + (math-sub-float + high low))) + (math-abs + (math-mul-float '(float 2 0) + step)))) + (math-newton-search-root expr deriv nil nil nil ostep + low vlow high vhigh) + (math-newton-search-root expr deriv next vnext step ostep + low vlow high vhigh)))) + (if (or (and (Math-posp vlow) (Math-posp vhigh)) + (and (Math-negp vlow) (Math-negp vhigh))) + (math-search-root expr deriv low vlow high vhigh) + (math-newton-search-root expr deriv nil nil nil ostep + low vlow high vhigh))))) +) + +;;; Search for a root in an interval with no overt zero crossing. +(defun math-search-root (expr deriv low vlow high vhigh) + (let (found) + (if root-widen + (let ((iters 0) + (iterlim (if (eq root-widen 'point) + (+ calc-internal-prec 10) + 20)) + (factor (if (eq root-widen 'point) + '(float 9 0) + '(float 16 -1))) + (prev nil) vprev waslow + diff) + (while (or (and (math-posp vlow) (math-posp vhigh)) + (and (math-negp vlow) (math-negp vhigh))) + (math-working "widen" (list 'intv 0 low high)) + (if (> (setq iters (1+ iters)) iterlim) + (math-reject-arg (list 'intv 0 low high) + "*Unable to bracket root")) + (if (= iters calc-internal-prec) + (setq factor '(float 16 -1))) + (setq diff (math-mul-float (math-sub-float high low) factor)) + (if (Math-zerop diff) + (setq high (calcFunc-incr high 10)) + (if (math-lessp-float (math-abs vlow) (math-abs vhigh)) + (setq waslow t + prev low + low (math-sub low diff) + var-DUMMY low + vprev vlow + vlow (math-evaluate-expr expr)) + (setq waslow nil + prev high + high (math-add high diff) + var-DUMMY high + vprev vhigh + vhigh (math-evaluate-expr expr))))) + (if prev + (if waslow + (setq high prev vhigh vprev) + (setq low prev vlow vprev))) + (setq found t)) + (or (Math-realp vlow) + (math-reject-arg vlow 'realp)) + (or (Math-realp vhigh) + (math-reject-arg vhigh 'realp)) + (let ((xvals (list low high)) + (yvals (list vlow vhigh)) + (pos (Math-posp vlow)) + (levels 0) + (step (math-sub-float high low)) + xp yp var-DUMMY) + (while (and (<= (setq levels (1+ levels)) 5) + (not found)) + (setq xp xvals + yp yvals + step (math-mul-float step '(float 497 -3))) + (while (and (cdr xp) (not found)) + (if (Math-realp (car yp)) + (setq low (car xp) + vlow (car yp))) + (setq high (math-add-float (car xp) step) + var-DUMMY high + vhigh (math-evaluate-expr expr)) + (math-working "search" high) + (if (and (Math-realp vhigh) + (eq (math-negp vhigh) pos)) + (setq found t) + (setcdr xp (cons high (cdr xp))) + (setcdr yp (cons vhigh (cdr yp))) + (setq xp (cdr (cdr xp)) + yp (cdr (cdr yp)))))))) + (if found + (if (Math-zerop vhigh) + (list 'vec high vhigh) + (if (Math-zerop vlow) + (list 'vec low vlow) + (if deriv + (math-newton-search-root expr deriv nil nil nil nil + low vlow high vhigh) + (math-bisect-root expr low vlow high vhigh)))) + (math-reject-arg (list 'intv 3 low high) + "*Unable to find a sign change in this interval"))) +) + +;;; "rtbis" (but we should be using Brent's method) +(defun math-bisect-root (expr low vlow high vhigh) + (let ((step (math-sub-float high low)) + (pos (Math-posp vhigh)) + var-DUMMY + mid vmid) + (while (not (or (math-nearly-equal low + (setq step (math-mul-float + step '(float 5 -1)) + mid (math-add-float low step))) + (progn + (setq var-DUMMY mid + vmid (math-evaluate-expr expr)) + (Math-zerop vmid)))) + (math-working "bisect" mid) + (if (eq (Math-posp vmid) pos) + (setq high mid + vhigh vmid) + (setq low mid + vlow vmid))) + (list 'vec mid vmid)) +) + +;;; "mnewt" +(defun math-newton-multi (expr jacob n guess orig-guess limit) + (let ((m -1) + (p guess) + p2 expr-val jacob-val next) + (while (< (setq p (cdr p) m (1+ m)) n) + (set (nth 2 (aref math-root-vars m)) (car p))) + (setq expr-val (math-evaluate-expr expr) + jacob-val (math-evaluate-expr jacob)) + (or (and (math-constp expr-val) + (math-constp jacob-val)) + (math-reject-arg guess "*Newton's method encountered a singularity")) + (setq next (math-add guess (math-div (math-float (math-neg expr-val)) + (math-float jacob-val))) + p guess p2 next) + (math-working "newton" next) + (while (and (setq p (cdr p) p2 (cdr p2)) + (math-nearly-equal (car p) (car p2)))) + (if p + (if (Math-lessp (math-abs-approx (math-sub next orig-guess)) + limit) + (math-newton-multi expr jacob n next orig-guess limit) + (math-reject-arg nil "*Newton's method failed to converge")) + (list 'vec next expr-val))) +) + +(defvar math-root-vars [(var DUMMY var-DUMMY)]) + +(defun math-find-root (expr var guess root-widen) + (if (eq (car-safe expr) 'vec) + (let ((n (1- (length expr))) + (calc-symbolic-mode nil) + (var-DUMMY nil) + (jacob (list 'vec)) + p p2 m row) + (or (eq (car-safe var) 'vec) + (math-reject-arg var 'vectorp)) + (or (= (length var) (1+ n)) + (math-dimension-error)) + (setq expr (copy-sequence expr)) + (while (>= n (length math-root-vars)) + (let ((symb (intern (concat "math-root-v" + (int-to-string + (length math-root-vars)))))) + (setq math-root-vars (vconcat math-root-vars + (vector (list 'var symb symb)))))) + (setq m -1) + (while (< (setq m (1+ m)) n) + (set (nth 2 (aref math-root-vars m)) nil)) + (setq m -1 p var) + (while (setq m (1+ m) p (cdr p)) + (or (eq (car-safe (car p)) 'var) + (math-reject-arg var "*Expected a variable")) + (setq p2 expr) + (while (setq p2 (cdr p2)) + (setcar p2 (math-expr-subst (car p2) (car p) + (aref math-root-vars m))))) + (or (eq (car-safe guess) 'vec) + (math-reject-arg guess 'vectorp)) + (or (= (length guess) (1+ n)) + (math-dimension-error)) + (setq guess (copy-sequence guess) + p guess) + (while (setq p (cdr p)) + (or (Math-numberp (car guess)) + (math-reject-arg guess 'numberp)) + (setcar p (math-float (car p)))) + (setq p expr) + (while (setq p (cdr p)) + (if (assq (car-safe (car p)) calc-tweak-eqn-table) + (setcar p (math-sub (nth 1 (car p)) (nth 2 (car p))))) + (setcar p (math-evaluate-expr (car p))) + (setq row (list 'vec) + m -1) + (while (< (setq m (1+ m)) n) + (nconc row (list (math-evaluate-expr + (or (calcFunc-deriv (car p) + (aref math-root-vars m) + nil t) + (math-reject-arg + expr + "*Formulas must be differentiable")))))) + (nconc jacob (list row))) + (setq m (math-abs-approx guess)) + (math-newton-multi expr jacob n guess guess + (if (math-zerop m) '(float 1 3) (math-mul m 10)))) + (or (eq (car-safe var) 'var) + (math-reject-arg var "*Expected a variable")) + (or (math-expr-contains expr var) + (math-reject-arg expr "*Formula does not contain specified variable")) + (if (assq (car expr) calc-tweak-eqn-table) + (setq expr (math-sub (nth 1 expr) (nth 2 expr)))) + (math-with-extra-prec 2 + (setq expr (math-expr-subst expr var '(var DUMMY var-DUMMY))) + (let* ((calc-symbolic-mode nil) + (var-DUMMY nil) + (expr (math-evaluate-expr expr)) + (deriv (calcFunc-deriv expr '(var DUMMY var-DUMMY) nil t)) + low high vlow vhigh) + (and deriv (setq deriv (math-evaluate-expr deriv))) + (setq guess (math-float guess)) + (if (and (math-numberp guess) + deriv) + (math-newton-root expr deriv guess guess + (if (math-zerop guess) '(float 1 6) + (math-mul (math-abs-approx guess) 100))) + (if (Math-realp guess) + (setq low guess + high guess + var-DUMMY guess + vlow (math-evaluate-expr expr) + vhigh vlow + root-widen 'point) + (if (eq (car guess) 'intv) + (progn + (or (math-constp guess) (math-reject-arg guess 'constp)) + (setq low (nth 2 guess) + high (nth 3 guess)) + (if (memq (nth 1 guess) '(0 1)) + (setq low (calcFunc-incr low 1 high))) + (if (memq (nth 1 guess) '(0 2)) + (setq high (calcFunc-incr high -1 low))) + (setq var-DUMMY low + vlow (math-evaluate-expr expr) + var-DUMMY high + vhigh (math-evaluate-expr expr))) + (if (math-complexp guess) + (math-reject-arg "*Complex root finder must have derivative") + (math-reject-arg guess 'realp)))) + (if (Math-zerop vlow) + (list 'vec low vlow) + (if (Math-zerop vhigh) + (list 'vec high vhigh) + (if (and deriv (Math-numberp vlow) (Math-numberp vhigh)) + (math-newton-search-root expr deriv nil nil nil nil + low vlow high vhigh) + (if (or (and (Math-posp vlow) (Math-posp vhigh)) + (and (Math-negp vlow) (Math-negp vhigh)) + (not (Math-numberp vlow)) + (not (Math-numberp vhigh))) + (math-search-root expr deriv low vlow high vhigh) + (math-bisect-root expr low vlow high vhigh))))))))) +) + +(defun calcFunc-root (expr var guess) + (math-find-root expr var guess nil) +) + +(defun calcFunc-wroot (expr var guess) + (math-find-root expr var guess t) +) + + + + +;;; The following algorithms come from Numerical Recipes, chapter 10. + +(defun math-min-eval (expr a) + (if (Math-vectorp a) + (let ((m -1)) + (while (setq m (1+ m) a (cdr a)) + (set (nth 2 (aref math-min-vars m)) (car a)))) + (setq var-DUMMY a)) + (setq a (math-evaluate-expr expr)) + (if (Math-ratp a) + (math-float a) + (if (eq (car a) 'float) + a + (math-reject-arg a 'realp))) +) + + +;;; A bracket for a minimum is a < b < c where f(b) < f(a) and f(b) < f(c). + +;;; "mnbrak" +(defun math-widen-min (expr a b) + (let ((done nil) + (iters 30) + incr c va vb vc u vu r q ulim bc ba qr) + (or b (setq b (math-mul a '(float 101 -2)))) + (setq va (math-min-eval expr a) + vb (math-min-eval expr b)) + (if (math-lessp-float va vb) + (setq u a a b b u + vu va va vb vb vu)) + (setq c (math-add-float b (math-mul-float '(float 161803 -5) + (math-sub-float b a))) + vc (math-min-eval expr c)) + (while (and (not done) (math-lessp-float vc vb)) + (math-working "widen" (list 'intv 0 a c)) + (if (= (setq iters (1- iters)) 0) + (math-reject-arg nil (format "*Unable to find a %s near the interval" + math-min-or-max))) + (setq bc (math-sub-float b c) + ba (math-sub-float b a) + r (math-mul-float ba (math-sub-float vb vc)) + q (math-mul-float bc (math-sub-float vb va)) + qr (math-sub-float q r)) + (if (math-lessp-float (math-abs qr) '(float 1 -20)) + (setq qr (if (math-negp qr) '(float -1 -20) '(float 1 -20)))) + (setq u (math-sub-float + b + (math-div-float (math-sub-float (math-mul-float bc q) + (math-mul-float ba r)) + (math-mul-float '(float 2 0) qr))) + ulim (math-add-float b (math-mul-float '(float -1 2) bc)) + incr (math-negp bc)) + (if (if incr (math-lessp-float b u) (math-lessp-float u b)) + (if (if incr (math-lessp-float u c) (math-lessp-float c u)) + (if (math-lessp-float (setq vu (math-min-eval expr u)) vc) + (setq a b va vb + b u vb vu + done t) + (if (math-lessp-float vb vu) + (setq c u vc vu + done t) + (setq u (math-add-float c (math-mul-float '(float -161803 -5) + bc)) + vu (math-min-eval expr u)))) + (if (if incr (math-lessp-float u ulim) (math-lessp-float ulim u)) + (if (math-lessp-float (setq vu (math-min-eval expr u)) vc) + (setq b c vb vc + c u vc vu + u (math-add-float c (math-mul-float + '(float -161803 -5) + (math-sub-float b c))) + vu (math-min-eval expr u))) + (setq u ulim + vu (math-min-eval expr u)))) + (setq u (math-add-float c (math-mul-float '(float -161803 -5) + bc)) + vu (math-min-eval expr u))) + (setq a b va vb + b c vb vc + c u vc vu)) + (if (math-lessp-float a c) + (list a va b vb c vc) + (list c vc b vb a va))) +) + +(defun math-narrow-min (expr a c intv) + (let ((xvals (list a c)) + (yvals (list (math-min-eval expr a) + (math-min-eval expr c))) + (levels 0) + (step (math-sub-float c a)) + (found nil) + xp yp b) + (while (and (<= (setq levels (1+ levels)) 5) + (not found)) + (setq xp xvals + yp yvals + step (math-mul-float step '(float 497 -3))) + (while (and (cdr xp) (not found)) + (setq b (math-add-float (car xp) step)) + (math-working "search" b) + (setcdr xp (cons b (cdr xp))) + (setcdr yp (cons (math-min-eval expr b) (cdr yp))) + (if (and (math-lessp-float (nth 1 yp) (car yp)) + (math-lessp-float (nth 1 yp) (nth 2 yp))) + (setq found t) + (setq xp (cdr xp) + yp (cdr yp)) + (if (and (cdr (cdr yp)) + (math-lessp-float (nth 1 yp) (car yp)) + (math-lessp-float (nth 1 yp) (nth 2 yp))) + (setq found t) + (setq xp (cdr xp) + yp (cdr yp)))))) + (if found + (list (car xp) (car yp) + (nth 1 xp) (nth 1 yp) + (nth 2 xp) (nth 2 yp)) + (or (if (math-lessp-float (car yvals) (nth 1 yvals)) + (and (memq (nth 1 intv) '(2 3)) + (let ((min (car yvals))) + (while (and (setq yvals (cdr yvals)) + (math-lessp-float min (car yvals)))) + (and (not yvals) + (list (nth 2 intv) min)))) + (and (memq (nth 1 intv) '(1 3)) + (setq yvals (nreverse yvals)) + (let ((min (car yvals))) + (while (and (setq yvals (cdr yvals)) + (math-lessp-float min (car yvals)))) + (and (not yvals) + (list (nth 3 intv) min))))) + (math-reject-arg nil (format "*Unable to find a %s in the interval" + math-min-or-max))))) +) + +;;; "brent" +(defun math-brent-min (expr prec a va x vx b vb) + (let ((iters (+ 20 (* 5 prec))) + (w x) + (vw vx) + (v x) + (vv vx) + (tol (list 'float 1 (- -1 prec))) + (zeps (list 'float 1 (- -5 prec))) + (e '(float 0 0)) + u vu xm tol1 tol2 etemp p q r xv xw) + (while (progn + (setq xm (math-mul-float '(float 5 -1) + (math-add-float a b)) + tol1 (math-add-float + zeps + (math-mul-float tol (math-abs x))) + tol2 (math-mul-float tol1 '(float 2 0))) + (math-lessp-float (math-sub-float tol2 + (math-mul-float + '(float 5 -1) + (math-sub-float b a))) + (math-abs (math-sub-float x xm)))) + (if (= (setq iters (1- iters)) 0) + (math-reject-arg nil (format "*Unable to converge on a %s" + math-min-or-max))) + (math-working "brent" x) + (if (math-lessp-float (math-abs e) tol1) + (setq e (if (math-lessp-float x xm) + (math-sub-float b x) + (math-sub-float a x)) + d (math-mul-float '(float 381966 -6) e)) + (setq xw (math-sub-float x w) + r (math-mul-float xw (math-sub-float vx vv)) + xv (math-sub-float x v) + q (math-mul-float xv (math-sub-float vx vw)) + p (math-sub-float (math-mul-float xv q) + (math-mul-float xw r)) + q (math-mul-float '(float 2 0) (math-sub-float q r))) + (if (math-posp q) + (setq p (math-neg-float p)) + (setq q (math-neg-float q))) + (setq etemp e + e d) + (if (and (math-lessp-float (math-abs p) + (math-abs (math-mul-float + '(float 5 -1) + (math-mul-float q etemp)))) + (math-lessp-float (math-mul-float + q (math-sub-float a x)) p) + (math-lessp-float p (math-mul-float + q (math-sub-float b x)))) + (progn + (setq d (math-div-float p q) + u (math-add-float x d)) + (if (or (math-lessp-float (math-sub-float u a) tol2) + (math-lessp-float (math-sub-float b u) tol2)) + (setq d (if (math-lessp-float xm x) + (math-neg-float tol1) + tol1)))) + (setq e (if (math-lessp-float x xm) + (math-sub-float b x) + (math-sub-float a x)) + d (math-mul-float '(float 381966 -6) e)))) + (setq u (math-add-float x + (if (math-lessp-float (math-abs d) tol1) + (if (math-negp d) + (math-neg-float tol1) + tol1) + d)) + vu (math-min-eval expr u)) + (if (math-lessp-float vx vu) + (progn + (if (math-lessp-float u x) + (setq a u) + (setq b u)) + (if (or (equal w x) + (not (math-lessp-float vw vu))) + (setq v w vv vw + w u vw vu) + (if (or (equal v x) + (equal v w) + (not (math-lessp-float vv vu))) + (setq v u vv vu)))) + (if (math-lessp-float u x) + (setq b x) + (setq a x)) + (setq v w vv vw + w x vw vx + x u vx vu))) + (list 'vec x vx)) +) + +;;; "powell" +(defun math-powell-min (expr n guesses prec) + (let* ((f1dim (math-line-min-func expr n)) + (xi (calcFunc-idn 1 n)) + (p (cons 'vec (mapcar 'car guesses))) + (pt p) + (ftol (list 'float 1 (- prec))) + (fret (math-min-eval expr p)) + fp ptt fptt xit i ibig del diff res) + (while (progn + (setq fp fret + ibig 0 + del '(float 0 0) + i 0) + (while (<= (setq i (1+ i)) n) + (setq fptt fret + res (math-line-min f1dim p + (math-mat-col xi i) + n prec) + p (let ((calc-internal-prec prec)) + (math-normalize (car res))) + fret (nth 2 res) + diff (math-abs (math-sub-float fptt fret))) + (if (math-lessp-float del diff) + (setq del diff + ibig i))) + (math-lessp-float + (math-mul-float ftol + (math-add-float (math-abs fp) + (math-abs fret))) + (math-mul-float '(float 2 0) + (math-abs (math-sub-float fp + fret))))) + (setq ptt (math-sub (math-mul '(float 2 0) p) pt) + xit (math-sub p pt) + pt p + fptt (math-min-eval expr ptt)) + (if (and (math-lessp-float fptt fp) + (math-lessp-float + (math-mul-float + (math-mul-float '(float 2 0) + (math-add-float + (math-sub-float fp + (math-mul-float '(float 2 0) + fret)) + fptt)) + (math-sqr-float (math-sub-float + (math-sub-float fp fret) del))) + (math-mul-float del + (math-sqr-float (math-sub-float fp fptt))))) + (progn + (setq res (math-line-min f1dim p xit n prec) + p (car res) + fret (nth 2 res) + i 0) + (while (<= (setq i (1+ i)) n) + (setcar (nthcdr ibig (nth i xi)) + (nth i (nth 1 res))))))) + (list 'vec p fret)) +) + +(defun math-line-min-func (expr n) + (let ((m -1)) + (while (< (setq m (1+ m)) n) + (set (nth 2 (aref math-min-vars m)) + (list '+ + (list '* + '(var DUMMY var-DUMMY) + (list 'calcFunc-mrow '(var line-xi line-xi) (1+ m))) + (list 'calcFunc-mrow '(var line-p line-p) (1+ m))))) + (math-evaluate-expr expr)) +) + +(defun math-line-min (f1dim line-p line-xi n prec) + (let* ((var-DUMMY nil) + (expr (math-evaluate-expr f1dim)) + (params (math-widen-min expr '(float 0 0) '(float 1 0))) + (res (apply 'math-brent-min expr prec params)) + (xi (math-mul (nth 1 res) line-xi))) + (list (math-add line-p xi) xi (nth 2 res))) +) + + +(defvar math-min-vars [(var DUMMY var-DUMMY)]) + +(defun math-find-minimum (expr var guess min-widen) + (let* ((calc-symbolic-mode nil) + (n 0) + (var-DUMMY nil) + (isvec (math-vectorp var)) + g guesses) + (or (math-vectorp var) + (setq var (list 'vec var))) + (or (math-vectorp guess) + (setq guess (list 'vec guess))) + (or (= (length var) (length guess)) + (math-dimension-error)) + (while (setq var (cdr var) guess (cdr guess)) + (or (eq (car-safe (car var)) 'var) + (math-reject-arg (car vg) "*Expected a variable")) + (or (math-expr-contains expr (car var)) + (math-reject-arg (car var) + "*Formula does not contain specified variable")) + (while (>= (1+ n) (length math-min-vars)) + (let ((symb (intern (concat "math-min-v" + (int-to-string + (length math-min-vars)))))) + (setq math-min-vars (vconcat math-min-vars + (vector (list 'var symb symb)))))) + (set (nth 2 (aref math-min-vars n)) nil) + (set (nth 2 (aref math-min-vars (1+ n))) nil) + (if (math-complexp (car guess)) + (setq expr (math-expr-subst expr + (car var) + (list '+ (aref math-min-vars n) + (list '* + (aref math-min-vars (1+ n)) + '(cplx 0 1)))) + guesses (let ((g (math-float (math-complex (car guess))))) + (cons (list (nth 2 g) nil nil) + (cons (list (nth 1 g) nil nil t) + guesses))) + n (+ n 2)) + (setq expr (math-expr-subst expr + (car var) + (aref math-min-vars n)) + guesses (cons (if (math-realp (car guess)) + (list (math-float (car guess)) nil nil) + (if (and (eq (car-safe (car guess)) 'intv) + (math-constp (car guess))) + (list (math-mul + (math-add (nth 2 (car guess)) + (nth 3 (car guess))) + '(float 5 -1)) + (math-float (nth 2 (car guess))) + (math-float (nth 3 (car guess))) + (car guess)) + (math-reject-arg (car guess) 'realp))) + guesses) + n (1+ n)))) + (setq guesses (nreverse guesses) + expr (math-evaluate-expr expr)) + (if (= n 1) + (let* ((params (if (nth 1 (car guesses)) + (if min-widen + (math-widen-min expr + (nth 1 (car guesses)) + (nth 2 (car guesses))) + (math-narrow-min expr + (nth 1 (car guesses)) + (nth 2 (car guesses)) + (nth 3 (car guesses)))) + (math-widen-min expr + (car (car guesses)) + nil))) + (prec calc-internal-prec) + (res (if (cdr (cdr params)) + (math-with-extra-prec (+ calc-internal-prec 2) + (apply 'math-brent-min expr prec params)) + (cons 'vec params)))) + (if isvec + (list 'vec (list 'vec (nth 1 res)) (nth 2 res)) + res)) + (let* ((prec calc-internal-prec) + (res (math-with-extra-prec (+ calc-internal-prec 2) + (math-powell-min expr n guesses prec))) + (p (nth 1 res)) + (vec (list 'vec))) + (while (setq p (cdr p)) + (if (nth 3 (car guesses)) + (progn + (nconc vec (list (math-normalize + (list 'cplx (car p) (nth 1 p))))) + (setq p (cdr p) + guesses (cdr guesses))) + (nconc vec (list (car p)))) + (setq guesses (cdr guesses))) + (if isvec + (list 'vec vec (nth 2 res)) + (list 'vec (nth 1 vec) (nth 2 res)))))) +) +(setq math-min-or-max "minimum") + +(defun calcFunc-minimize (expr var guess) + (let ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) + (math-min-or-max "minimum")) + (math-find-minimum (math-normalize expr) + (math-normalize var) + (math-normalize guess) nil)) +) + +(defun calcFunc-wminimize (expr var guess) + (let ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) + (math-min-or-max "minimum")) + (math-find-minimum (math-normalize expr) + (math-normalize var) + (math-normalize guess) t)) +) + +(defun calcFunc-maximize (expr var guess) + (let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) + (math-min-or-max "maximum") + (res (math-find-minimum (math-normalize (math-neg expr)) + (math-normalize var) + (math-normalize guess) nil))) + (list 'vec (nth 1 res) (math-neg (nth 2 res)))) +) + +(defun calcFunc-wmaximize (expr var guess) + (let* ((calc-internal-prec (max (/ calc-internal-prec 2) 3)) + (math-min-or-max "maximum") + (res (math-find-minimum (math-normalize (math-neg expr)) + (math-normalize var) + (math-normalize guess) t))) + (list 'vec (nth 1 res) (math-neg (nth 2 res)))) +) + + + + +;;; The following algorithms come from Numerical Recipes, chapter 3. + +(defun calcFunc-polint (data x) + (or (math-matrixp data) (math-reject-arg data 'matrixp)) + (or (= (length data) 3) + (math-reject-arg data "*Wrong number of data rows")) + (or (> (length (nth 1 data)) 2) + (math-reject-arg data "*Too few data points")) + (if (and (math-vectorp x) (or (math-constp x) math-expand-formulas)) + (cons 'vec (mapcar (function (lambda (x) (calcFunc-polint data x))) + (cdr x))) + (or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp)) + (math-with-extra-prec 2 + (cons 'vec (math-poly-interp (cdr (nth 1 data)) (cdr (nth 2 data)) x + nil)))) +) +(put 'calcFunc-polint 'math-expandable t) + + +(defun calcFunc-ratint (data x) + (or (math-matrixp data) (math-reject-arg data 'matrixp)) + (or (= (length data) 3) + (math-reject-arg data "*Wrong number of data rows")) + (or (> (length (nth 1 data)) 2) + (math-reject-arg data "*Too few data points")) + (if (and (math-vectorp x) (or (math-constp x) math-expand-formulas)) + (cons 'vec (mapcar (function (lambda (x) (calcFunc-ratint data x))) + (cdr x))) + (or (math-objectp x) math-expand-formulas (math-reject-arg x 'objectp)) + (math-with-extra-prec 2 + (cons 'vec (math-poly-interp (cdr (nth 1 data)) (cdr (nth 2 data)) x + (cdr (cdr (cdr (nth 1 data)))))))) +) +(put 'calcFunc-ratint 'math-expandable t) + + +(defun math-poly-interp (xa ya x ratp) + (let ((n (length xa)) + (dif nil) + (ns nil) + (xax nil) + (c (copy-sequence ya)) + (d (copy-sequence ya)) + (i 0) + (m 0) + y dy (xp xa) xpm cp dp temp) + (while (<= (setq i (1+ i)) n) + (setq xax (cons (math-sub (car xp) x) xax) + xp (cdr xp) + temp (math-abs (car xax))) + (if (or (null dif) (math-lessp temp dif)) + (setq dif temp + ns i))) + (setq xax (nreverse xax) + ns (1- ns) + y (nth ns ya)) + (if (math-zerop dif) + (list y 0) + (while (< (setq m (1+ m)) n) + (setq i 0 + xp xax + xpm (nthcdr m xax) + cp c + dp d) + (while (<= (setq i (1+ i)) (- n m)) + (if ratp + (let ((t2 (math-div (math-mul (car xp) (car dp)) (car xpm)))) + (setq temp (math-div (math-sub (nth 1 cp) (car dp)) + (math-sub t2 (nth 1 cp)))) + (setcar dp (math-mul (nth 1 cp) temp)) + (setcar cp (math-mul t2 temp))) + (if (math-equal (car xp) (car xpm)) + (math-reject-arg (cons 'vec xa) "*Duplicate X values")) + (setq temp (math-div (math-sub (nth 1 cp) (car dp)) + (math-sub (car xp) (car xpm)))) + (setcar dp (math-mul (car xpm) temp)) + (setcar cp (math-mul (car xp) temp))) + (setq cp (cdr cp) + dp (cdr dp) + xp (cdr xp) + xpm (cdr xpm))) + (if (< (+ ns ns) (- n m)) + (setq dy (nth ns c)) + (setq ns (1- ns) + dy (nth ns d))) + (setq y (math-add y dy))) + (list y dy))) +) + + + +;;; The following algorithms come from Numerical Recipes, chapter 4. + +(defun calcFunc-ninteg (expr var lo hi) + (setq lo (math-evaluate-expr lo) + hi (math-evaluate-expr hi)) + (or (math-numberp lo) (math-infinitep lo) (math-reject-arg lo 'numberp)) + (or (math-numberp hi) (math-infinitep hi) (math-reject-arg hi 'numberp)) + (if (math-lessp hi lo) + (math-neg (calcFunc-ninteg expr var hi lo)) + (setq expr (math-expr-subst expr var '(var DUMMY var-DUMMY))) + (let ((var-DUMMY nil) + (calc-symbolic-mode nil) + (calc-prefer-frac nil) + (sum 0)) + (setq expr (math-evaluate-expr expr)) + (if (equal lo '(neg (var inf var-inf))) + (let ((thi (if (math-lessp hi '(float -2 0)) + hi '(float -2 0)))) + (setq sum (math-ninteg-romberg + 'math-ninteg-midpoint expr + (math-float lo) (math-float thi) 'inf) + lo thi))) + (if (equal hi '(var inf var-inf)) + (let ((tlo (if (math-lessp '(float 2 0) lo) + lo '(float 2 0)))) + (setq sum (math-add sum + (math-ninteg-romberg + 'math-ninteg-midpoint expr + (math-float tlo) (math-float hi) 'inf)) + hi tlo))) + (or (math-equal lo hi) + (setq sum (math-add sum + (math-ninteg-romberg + 'math-ninteg-midpoint expr + (math-float lo) (math-float hi) nil)))) + sum)) +) + + +;;; Open Romberg method; "qromo" in section 4.4. +(defun math-ninteg-romberg (func expr lo hi mode) + (let ((curh '(float 1 0)) + (h nil) + (s nil) + (j 0) + (ss nil) + (prec calc-internal-prec) + (integ-temp nil)) + (math-with-extra-prec 2 + ;; Limit on "j" loop must be 14 or less to keep "it" from overflowing. + (or (while (and (null ss) (<= (setq j (1+ j)) 8)) + (setq s (nconc s (list (funcall func expr lo hi mode))) + h (nconc h (list curh))) + (if (>= j 3) + (let ((res (math-poly-interp h s '(float 0 0) nil))) + (if (math-lessp (math-abs (nth 1 res)) + (calcFunc-scf (math-abs (car res)) + (- prec))) + (setq math-ninteg-convergence j + ss (car res))))) + (if (>= j 5) + (setq s (cdr s) + h (cdr h))) + (setq curh (math-div-float curh '(float 9 0)))) + ss + (math-reject-arg nil (format "*Integral failed to converge"))))) +) + + +(defun math-ninteg-evaluate (expr x mode) + (if (eq mode 'inf) + (setq x (math-div '(float 1 0) x))) + (let* ((var-DUMMY x) + (res (math-evaluate-expr expr))) + (or (Math-numberp res) + (math-reject-arg res "*Integrand does not evaluate to a number")) + (if (eq mode 'inf) + (setq res (math-mul res (math-sqr x)))) + res) +) + + +(defun math-ninteg-midpoint (expr lo hi mode) ; uses "integ-temp" + (if (eq mode 'inf) + (let ((math-infinite-mode t) temp) + (setq temp (math-div 1 lo) + lo (math-div 1 hi) + hi temp))) + (if integ-temp + (let* ((it3 (* 3 (car integ-temp))) + (math-working-step-2 (* 2 (car integ-temp))) + (math-working-step 0) + (range (math-sub hi lo)) + (del (math-div range (math-float it3))) + (del2 (math-add del del)) + (del3 (math-add del del2)) + (x (math-add lo (math-mul '(float 5 -1) del))) + (sum '(float 0 0)) + (j 0) temp) + (while (<= (setq j (1+ j)) (car integ-temp)) + (setq math-working-step (1+ math-working-step) + temp (math-ninteg-evaluate expr x mode) + math-working-step (1+ math-working-step) + sum (math-add sum (math-add temp (math-ninteg-evaluate + expr (math-add x del2) + mode))) + x (math-add x del3))) + (setq integ-temp (list it3 + (math-add (math-div (nth 1 integ-temp) + '(float 3 0)) + (math-mul sum del))))) + (setq integ-temp (list 1 (math-mul + (math-sub hi lo) + (math-ninteg-evaluate + expr + (math-mul (math-add lo hi) '(float 5 -1)) + mode))))) + (nth 1 integ-temp) +) + + + + + +;;; The following algorithms come from Numerical Recipes, chapter 14. + +(setq math-dummy-vars [(var DUMMY var-DUMMY)]) +(setq math-dummy-counter 0) + +(defun math-dummy-variable () + (if (= math-dummy-counter (length math-dummy-vars)) + (let ((symb (intern (format "math-dummy-%d" math-dummy-counter)))) + (setq math-dummy-vars (vconcat math-dummy-vars + (vector (list 'var symb symb)))))) + (set (nth 2 (aref math-dummy-vars math-dummy-counter)) nil) + (prog1 + (aref math-dummy-vars math-dummy-counter) + (setq math-dummy-counter (1+ math-dummy-counter))) +) + + + +(defun calcFunc-fit (expr vars &optional coefs data) + (let ((math-in-fit 10)) + (math-with-extra-prec 2 + (math-general-fit expr vars coefs data nil))) +) + +(defun calcFunc-efit (expr vars &optional coefs data) + (let ((math-in-fit 10)) + (math-with-extra-prec 2 + (math-general-fit expr vars coefs data 'sdev))) +) + +(defun calcFunc-xfit (expr vars &optional coefs data) + (let ((math-in-fit 10)) + (math-with-extra-prec 2 + (math-general-fit expr vars coefs data 'full))) +) + +(defun math-general-fit (expr vars coefs data mode) + (let ((calc-simplify-mode nil) + (math-dummy-counter math-dummy-counter) + (math-in-fit 1) + (extended (eq mode 'full)) + (first-coef math-dummy-counter) + first-var + (plain-expr expr) + orig-expr + have-sdevs need-chisq chisq + (x-funcs nil) + (y-filter nil) + y-dummy + (coef-filters nil) + new-coefs + (xy-values nil) + (weights nil) + (var-YVAL nil) (var-YVALX nil) + covar beta + n nn m mm v dummy p) + + ;; Validate and parse arguments. + (or data + (if coefs + (setq data coefs + coefs nil) + (if (math-vectorp expr) + (if (memq (length expr) '(3 4)) + (setq data vars + vars (nth 2 expr) + coefs (nth 3 expr) + expr (nth 1 expr)) + (math-dimension-error)) + (setq data vars + vars nil + coefs nil)))) + (or (math-matrixp data) (math-reject-arg data 'matrixp)) + (setq v (1- (length data)) + n (1- (length (nth 1 data)))) + (or (math-vectorp vars) (null vars) + (setq vars (list 'vec vars))) + (or (math-vectorp coefs) (null coefs) + (setq coefs (list 'vec coefs))) + (or coefs + (setq coefs (cons 'vec (math-all-vars-but expr vars)))) + (or vars + (if (<= (1- (length coefs)) v) + (math-reject-arg coefs "*Not enough variables in model") + (setq coefs (copy-sequence coefs)) + (let ((p (nthcdr (- (length coefs) v + (if (eq (car-safe expr) 'calcFunc-eq) 1 0)) + coefs))) + (setq vars (cons 'vec (cdr p))) + (setcdr p nil)))) + (or (= (1- (length vars)) v) + (= (length vars) v) + (math-reject-arg vars "*Number of variables does not match data")) + (setq m (1- (length coefs))) + (if (< m 1) + (math-reject-arg coefs "*Need at least one parameter")) + + ;; Rewrite expr in terms of fitparam and fitvar, make into an equation. + (setq p coefs) + (while (setq p (cdr p)) + (or (eq (car-safe (car p)) 'var) + (math-reject-arg (car p) "*Expected a variable")) + (setq dummy (math-dummy-variable) + expr (math-expr-subst expr (car p) + (list 'calcFunc-fitparam + (- math-dummy-counter first-coef))))) + (setq first-var math-dummy-counter + p vars) + (while (setq p (cdr p)) + (or (eq (car-safe (car p)) 'var) + (math-reject-arg (car p) "*Expected a variable")) + (setq dummy (math-dummy-variable) + expr (math-expr-subst expr (car p) + (list 'calcFunc-fitvar + (- math-dummy-counter first-var))))) + (if (< math-dummy-counter (+ first-var v)) + (setq dummy (math-dummy-variable))) ; dependent variable may be unnamed + (setq y-dummy dummy + orig-expr expr) + (or (eq (car-safe expr) 'calcFunc-eq) + (setq expr (list 'calcFunc-eq (list 'calcFunc-fitvar v) expr))) + + (let ((calc-symbolic-mode nil)) + + ;; Apply rewrites to put expr into a linear-like form. + (setq expr (math-evaluate-expr expr) + expr (math-rewrite (list 'calcFunc-fitmodel expr) + '(var FitRules var-FitRules)) + math-in-fit 2 + expr (math-evaluate-expr expr)) + (or (and (eq (car-safe expr) 'calcFunc-fitsystem) + (= (length expr) 4) + (math-vectorp (nth 2 expr)) + (math-vectorp (nth 3 expr)) + (> (length (nth 2 expr)) 1) + (= (length (nth 3 expr)) (1+ m))) + (math-reject-arg plain-expr "*Model expression is too complex")) + (setq y-filter (nth 1 expr) + x-funcs (vconcat (cdr (nth 2 expr))) + coef-filters (nth 3 expr) + mm (length x-funcs)) + (if (equal y-filter y-dummy) + (setq y-filter nil)) + + ;; Build the (square) system of linear equations to be solved. + (setq beta (cons 'vec (make-list mm 0)) + covar (cons 'vec (mapcar 'copy-sequence (make-list mm beta)))) + (let* ((ptrs (vconcat (cdr data))) + (isigsq 1) + (xvals (make-vector mm 0)) + (i 0) + j k xval yval sigmasqr wt covj covjk covk betaj lud) + (while (<= (setq i (1+ i)) n) + + ;; Assign various independent variables for this data point. + (setq j 0 + sigmasqr nil) + (while (< j v) + (aset ptrs j (cdr (aref ptrs j))) + (setq xval (car (aref ptrs j))) + (if (= j (1- v)) + (if sigmasqr + (progn + (if (eq (car-safe xval) 'sdev) + (setq sigmasqr (math-add (math-sqr (nth 2 xval)) + sigmasqr) + xval (nth 1 xval))) + (if y-filter + (setq xval (math-make-sdev xval + (math-sqrt sigmasqr)))))) + (if (eq (car-safe xval) 'sdev) + (setq sigmasqr (math-add (math-sqr (nth 2 xval)) + (or sigmasqr 0)) + xval (nth 1 xval)))) + (set (nth 2 (aref math-dummy-vars (+ first-var j))) xval) + (setq j (1+ j))) + + ;; Compute Y value for this data point. + (if y-filter + (setq yval (math-evaluate-expr y-filter)) + (setq yval (symbol-value (nth 2 y-dummy)))) + (if (eq (car-safe yval) 'sdev) + (setq sigmasqr (math-sqr (nth 2 yval)) + yval (nth 1 yval))) + (if (= i 1) + (setq have-sdevs sigmasqr + need-chisq (or extended + (and (eq mode 'sdev) (not have-sdevs))))) + (if have-sdevs + (if sigmasqr + (progn + (setq isigsq (math-div 1 sigmasqr)) + (if need-chisq + (setq weights (cons isigsq weights)))) + (math-reject-arg yval "*Mixed error forms and plain numbers")) + (if sigmasqr + (math-reject-arg yval "*Mixed error forms and plain numbers"))) + + ;; Compute X values for this data point and update covar and beta. + (if (eq (car-safe xval) 'sdev) + (set (nth 2 y-dummy) (nth 1 xval))) + (setq j 0 + covj covar + betaj beta) + (while (< j mm) + (setq wt (math-evaluate-expr (aref x-funcs j))) + (aset xvals j wt) + (setq wt (math-mul wt isigsq) + betaj (cdr betaj) + covjk (car (setq covj (cdr covj))) + k 0) + (while (<= k j) + (setq covjk (cdr covjk)) + (setcar covjk (math-add (car covjk) + (math-mul wt (aref xvals k)))) + (setq k (1+ k))) + (setcar betaj (math-add (car betaj) (math-mul wt yval))) + (setq j (1+ j))) + (if need-chisq + (setq xy-values (cons (append xvals (list yval)) xy-values)))) + + ;; Fill in symmetric half of covar matrix. + (setq j 0 + covj covar) + (while (< j (1- mm)) + (setq k j + j (1+ j) + covjk (nthcdr j (car (setq covj (cdr covj)))) + covk (nthcdr j covar)) + (while (< (setq k (1+ k)) mm) + (setq covjk (cdr covjk) + covk (cdr covk)) + (setcar covjk (nth j (car covk)))))) + + ;; Solve the linear system. + (if mode + (progn + (setq covar (math-matrix-inv-raw covar)) + (if covar + (setq beta (math-mul covar beta)) + (if (math-zerop (math-abs beta)) + (setq covar (calcFunc-diag 0 (1- (length beta)))) + (math-reject-arg orig-expr "*Singular matrix"))) + (or (math-vectorp covar) + (setq covar (list 'vec (list 'vec covar))))) + (setq beta (math-div beta covar))) + + ;; Compute chi-square statistic if necessary. + (if need-chisq + (let (bp xp sum) + (setq chisq 0) + (while xy-values + (setq bp beta + xp (car xy-values) + sum 0) + (while (setq bp (cdr bp)) + (setq sum (math-add sum (math-mul (car bp) (car xp))) + xp (cdr xp))) + (setq sum (math-sqr (math-sub (car xp) sum))) + (if weights (setq sum (math-mul sum (car weights)))) + (setq chisq (math-add chisq sum) + weights (cdr weights) + xy-values (cdr xy-values))))) + + ;; Convert coefficients back into original terms. + (setq new-coefs (copy-sequence beta)) + (let* ((bp new-coefs) + (cp covar) + (sigdat 1) + (math-in-fit 3) + (j 0)) + (and mode (not have-sdevs) + (setq sigdat (if (<= n mm) + 0 + (math-div chisq (- n mm))))) + (if mode + (while (setq bp (cdr bp)) + (setcar bp (math-make-sdev + (car bp) + (math-sqrt (math-mul (nth (setq j (1+ j)) + (car (setq cp (cdr cp)))) + sigdat)))))) + (setq new-coefs (math-evaluate-expr coef-filters)) + (if calc-fit-to-trail + (let ((bp new-coefs) + (cp coefs) + (vec nil)) + (while (setq bp (cdr bp) cp (cdr cp)) + (setq vec (cons (list 'calcFunc-eq (car cp) (car bp)) vec))) + (setq calc-fit-to-trail (cons 'vec (nreverse vec))))))) + + ;; Substitute best-fit coefficients back into original formula. + (setq expr (math-multi-subst + orig-expr + (let ((n v) + (vec nil)) + (while (>= n 1) + (setq vec (cons (list 'calcFunc-fitvar n) vec) + n (1- n))) + (setq n m) + (while (>= n 1) + (setq vec (cons (list 'calcFunc-fitparam n) vec) + n (1- n))) + vec) + (append (cdr new-coefs) (cdr vars)))) + + ;; Package the result. + (math-normalize + (if extended + (list 'vec expr beta covar + (let ((p coef-filters) + (n 0)) + (while (and (setq n (1+ n) p (cdr p)) + (eq (car-safe (car p)) 'calcFunc-fitdummy) + (eq (nth 1 (car p)) n))) + (if p + coef-filters + (list 'vec))) + chisq + (if (and have-sdevs (> n mm)) + (list 'calcFunc-utpc chisq (- n mm)) + '(var nan var-nan))) + expr))) +) + +(setq math-in-fit 0) +(setq calc-fit-to-trail nil) + +(defun calcFunc-fitvar (x) + (if (>= math-in-fit 2) + (progn + (setq x (aref math-dummy-vars (+ first-var x -1))) + (or (calc-var-value (nth 2 x)) x)) + (math-reject-arg x)) +) + +(defun calcFunc-fitparam (x) + (if (>= math-in-fit 2) + (progn + (setq x (aref math-dummy-vars (+ first-coef x -1))) + (or (calc-var-value (nth 2 x)) x)) + (math-reject-arg x)) +) + +(defun calcFunc-fitdummy (x) + (if (= math-in-fit 3) + (nth x new-coefs) + (math-reject-arg x)) +) + +(defun calcFunc-hasfitvars (expr) + (if (Math-primp expr) + 0 + (if (eq (car expr) 'calcFunc-fitvar) + (nth 1 expr) + (apply 'max (mapcar 'calcFunc-hasfitvars (cdr expr))))) +) + +(defun calcFunc-hasfitparams (expr) + (if (Math-primp expr) + 0 + (if (eq (car expr) 'calcFunc-fitparam) + (nth 1 expr) + (apply 'max (mapcar 'calcFunc-hasfitparams (cdr expr))))) +) + + +(defun math-all-vars-but (expr but) + (let* ((vars (math-all-vars-in expr)) + (p but)) + (while p + (setq vars (delq (assoc (car-safe p) vars) vars) + p (cdr p))) + (sort (mapcar 'car vars) + (function (lambda (x y) (string< (nth 1 x) (nth 1 y)))))) +) + +(defun math-all-vars-in (expr) + (let ((vars nil) + found) + (math-all-vars-rec expr) + vars) +) + +(defun math-all-vars-rec (expr) + (if (Math-primp expr) + (if (eq (car-safe expr) 'var) + (or (math-const-var expr) + (if (setq found (assoc expr vars)) + (setcdr found (1+ (cdr found))) + (setq vars (cons (cons expr 1) vars))))) + (while (setq expr (cdr expr)) + (math-all-vars-rec (car expr)))) +) + + + + diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el new file mode 100644 index 0000000000..7d24794c85 --- /dev/null +++ b/lisp/calc/calccomp.el @@ -0,0 +1,1755 @@ +;; Calculator for GNU Emacs, part II [calc-comp.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-comp () nil) + + +;;; A "composition" has one of the following forms: +;;; +;;; "string" A literal string +;;; +;;; (horiz C1 C2 ...) Horizontally abutted sub-compositions +;;; +;;; (set LEVEL OFF) Set left margin + offset for line-break level +;;; (break LEVEL) A potential line-break point +;;; +;;; (vleft N C1 C2 ...) Vertically stacked, left-justified sub-comps +;;; (vcent N C1 C2 ...) Vertically stacked, centered sub-comps +;;; (vright N C1 C2 ...) Vertically stacked, right-justified sub-comps +;;; N specifies baseline of the stack, 0=top line. +;;; +;;; (supscr C1 C2) Composition C1 with superscript C2 +;;; (subscr C1 C2) Composition C1 with subscript C2 +;;; (rule X) Horizontal line of X, full width of enclosing comp +;;; +;;; (tag X C) Composition C corresponds to sub-expression X + +(defun math-compose-expr (a prec) + (let ((math-compose-level (1+ math-compose-level))) + (cond + ((or (and (eq a math-comp-selected) a) + (and math-comp-tagged + (not (eq math-comp-tagged a)))) + (let ((math-comp-selected nil)) + (and math-comp-tagged (setq math-comp-tagged a)) + (list 'tag a (math-compose-expr a prec)))) + ((and (not (consp a)) (not (integerp a))) + (concat "'" (prin1-to-string a))) + ((math-scalarp a) + (if (or (eq (car-safe a) 'frac) + (and (nth 1 calc-frac-format) (Math-integerp a))) + (if (memq calc-language '(tex eqn math maple c fortran pascal)) + (let ((aa (math-adjust-fraction a)) + (calc-frac-format nil)) + (math-compose-expr (list '/ + (if (memq calc-language '(c fortran)) + (math-float (nth 1 aa)) + (nth 1 aa)) + (nth 2 aa)) prec)) + (if (and (eq calc-language 'big) + (= (length (car calc-frac-format)) 1)) + (let* ((aa (math-adjust-fraction a)) + (calc-frac-format nil) + (math-radix-explicit-format nil) + (c (list 'horiz + (if (math-negp (nth 1 aa)) + "- " "") + (list 'vcent 1 + (math-format-number + (math-abs (nth 1 aa))) + '(rule ?-) + (math-format-number (nth 2 aa)))))) + (if (= calc-number-radix 10) + c + (list 'horiz "(" c + (list 'subscr ")" + (int-to-string calc-number-radix))))) + (math-format-number a))) + (if (not (eq calc-language 'big)) + (math-format-number a prec) + (if (memq (car-safe a) '(cplx polar)) + (if (math-zerop (nth 2 a)) + (math-compose-expr (nth 1 a) prec) + (list 'horiz "(" + (math-compose-expr (nth 1 a) 0) + (if (eq (car a) 'cplx) ", " "; ") + (math-compose-expr (nth 2 a) 0) ")")) + (if (or (= calc-number-radix 10) + (not (Math-realp a)) + (and calc-group-digits + (not (assoc calc-group-char '((",") (" ")))))) + (math-format-number a prec) + (let ((s (math-format-number a prec)) + (c nil)) + (while (string-match (if (> calc-number-radix 14) + "\\([0-9]+\\)#\\([0-9a-zA-Z., ]+\\)" + "\\([0-9]+\\)#\\([0-9a-dA-D., ]+\\)") + s) + (setq c (nconc c (list (substring s 0 (match-beginning 0)) + (list 'subscr + (math-match-substring s 2) + (math-match-substring s 1)))) + s (substring s (match-end 0)))) + (if (string-match + "\\*\\([0-9.]+\\)\\^\\(-?[0-9]+\\)\\()?\\)\\'" s) + (setq s (list 'horiz + (substring s 0 (match-beginning 0)) " " + (list 'supscr + (math-match-substring s 1) + (math-match-substring s 2)) + (math-match-substring s 3)))) + (if c (cons 'horiz (nconc c (list s))) s))))))) + ((and (get (car a) 'math-compose-forms) + (not (eq calc-language 'unform)) + (let ((comps (get (car a) 'math-compose-forms)) + temp temp2) + (or (and (setq temp (assq calc-language comps)) + (or (and (setq temp2 (assq (1- (length a)) (cdr temp))) + (setq temp (apply (cdr temp2) (cdr a))) + (math-compose-expr temp prec)) + (and (setq temp2 (assq nil (cdr temp))) + (funcall (cdr temp2) a)))) + (and (setq temp (assq nil comps)) + (or (and (setq temp2 (assq (1- (length a)) (cdr temp))) + (setq temp (apply (cdr temp2) (cdr a))) + (math-compose-expr temp prec)) + (and (setq temp2 (assq nil (cdr temp))) + (funcall (cdr temp2) a)))))))) + ((eq (car a) 'vec) + (let* ((left-bracket (if calc-vector-brackets + (substring calc-vector-brackets 0 1) "")) + (right-bracket (if calc-vector-brackets + (substring calc-vector-brackets 1 2) "")) + (inner-brackets (memq 'R calc-matrix-brackets)) + (outer-brackets (memq 'O calc-matrix-brackets)) + (row-commas (memq 'C calc-matrix-brackets)) + (comma-spc (or calc-vector-commas " ")) + (comma (or calc-vector-commas "")) + (vector-prec (if (or (and calc-vector-commas + (math-vector-no-parens a)) + (memq 'P calc-matrix-brackets)) 0 1000)) + (just (cond ((eq calc-matrix-just 'right) 'vright) + ((eq calc-matrix-just 'center) 'vcent) + (t 'vleft))) + (break calc-break-vectors)) + (if (and (memq calc-language '(nil big)) + (not calc-break-vectors) + (math-matrixp a) (not (math-matrixp (nth 1 a))) + (or calc-full-vectors + (and (< (length a) 7) (< (length (nth 1 a)) 7)) + (progn (setq break t) nil))) + (if (progn + (setq vector-prec (if (or (and calc-vector-commas + (math-vector-no-parens + (nth 1 a))) + (memq 'P calc-matrix-brackets)) + 0 1000)) + (= (length a) 2)) + (list 'horiz + (concat left-bracket left-bracket " ") + (math-compose-vector (cdr (nth 1 a)) (concat comma " ") + vector-prec) + (concat " " right-bracket right-bracket)) + (let* ((rows (1- (length a))) + (cols (1- (length (nth 1 a)))) + (base (/ (1- rows) 2)) + (calc-language 'flat)) + (append '(horiz) + (list (append '(vleft) + (list base) + (list (concat (and outer-brackets + (concat left-bracket + " ")) + (and inner-brackets + (concat left-bracket + " ")))) + (make-list (1- rows) + (concat (and outer-brackets + " ") + (and inner-brackets + (concat + left-bracket + " ")))))) + (math-compose-matrix (cdr a) 1 cols base) + (list (append '(vleft) + (list base) + (make-list (1- rows) + (if inner-brackets + (concat " " + right-bracket + (and row-commas + comma)) + (if (and outer-brackets + row-commas) + ";" ""))) + (list (concat + (and inner-brackets + (concat " " + right-bracket)) + (and outer-brackets + (concat + " " + right-bracket))))))))) + (if (and calc-display-strings + (cdr a) + (math-vector-is-string a)) + (math-vector-to-string a t) + (if (and break (cdr a) + (not (eq calc-language 'flat))) + (let* ((full (or calc-full-vectors (< (length a) 7))) + (rows (if full (1- (length a)) 5)) + (base (/ (1- rows) 2)) + (just 'vleft) + (calc-break-vectors nil)) + (list 'horiz + (cons 'vleft (cons base + (math-compose-rows + (cdr a) + (if full rows 3) t))))) + (if (or calc-full-vectors (< (length a) 7)) + (if (and (eq calc-language 'tex) + (math-matrixp a)) + (append '(horiz "\\matrix{ ") + (math-compose-tex-matrix (cdr a)) + '(" }")) + (if (and (eq calc-language 'eqn) + (math-matrixp a)) + (append '(horiz "matrix { ") + (math-compose-eqn-matrix + (cdr (math-transpose a))) + '("}")) + (if (and (eq calc-language 'maple) + (math-matrixp a)) + (list 'horiz + "matrix(" + left-bracket + (math-compose-vector (cdr a) (concat comma " ") + vector-prec) + right-bracket + ")") + (list 'horiz + left-bracket + (math-compose-vector (cdr a) (concat comma " ") + vector-prec) + right-bracket)))) + (list 'horiz + left-bracket + (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a)) + (concat comma " ") vector-prec) + comma (if (eq calc-language 'tex) " \\ldots" " ...") + comma " " + (list 'break math-compose-level) + (math-compose-expr (nth (1- (length a)) a) + (if (equal comma "") 1000 0)) + right-bracket))))))) + ((eq (car a) 'incomplete) + (if (cdr (cdr a)) + (cond ((eq (nth 1 a) 'vec) + (list 'horiz "[" + (math-compose-vector (cdr (cdr a)) ", " 0) + " ...")) + ((eq (nth 1 a) 'cplx) + (list 'horiz "(" + (math-compose-vector (cdr (cdr a)) ", " 0) + ", ...")) + ((eq (nth 1 a) 'polar) + (list 'horiz "(" + (math-compose-vector (cdr (cdr a)) "; " 0) + "; ...")) + ((eq (nth 1 a) 'intv) + (list 'horiz + (if (memq (nth 2 a) '(0 1)) "(" "[") + (math-compose-vector (cdr (cdr (cdr a))) " .. " 0) + " .. ...")) + (t (format "%s" a))) + (cond ((eq (nth 1 a) 'vec) "[ ...") + ((eq (nth 1 a) 'intv) + (if (memq (nth 2 a) '(0 1)) "( ..." "[ ...")) + (t "( ...")))) + ((eq (car a) 'var) + (let ((v (rassq (nth 2 a) math-expr-variable-mapping))) + (if v + (symbol-name (car v)) + (if (and (eq calc-language 'tex) + calc-language-option + (not (= calc-language-option 0)) + (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" + (symbol-name (nth 1 a)))) + (format "\\hbox{%s}" (symbol-name (nth 1 a))) + (if (and math-compose-hash-args + (let ((p calc-arg-values)) + (setq v 1) + (while (and p (not (equal (car p) a))) + (setq p (and (eq math-compose-hash-args t) (cdr p)) + v (1+ v))) + p)) + (if (eq math-compose-hash-args 1) + "#" + (format "#%d" v)) + (if (memq calc-language '(c fortran pascal maple)) + (math-to-underscores (symbol-name (nth 1 a))) + (if (and (eq calc-language 'eqn) + (string-match ".'\\'" (symbol-name (nth 2 a)))) + (math-compose-expr + (list 'calcFunc-Prime + (list + 'var + (intern (substring (symbol-name (nth 1 a)) 0 -1)) + (intern (substring (symbol-name (nth 2 a)) 0 -1)))) + prec) + (symbol-name (nth 1 a))))))))) + ((eq (car a) 'intv) + (list 'horiz + (if (eq calc-language 'maple) "" + (if (memq (nth 1 a) '(0 1)) "(" "[")) + (math-compose-expr (nth 2 a) 0) + (if (eq calc-language 'tex) " \\ldots " + (if (eq calc-language 'eqn) " ... " " .. ")) + (math-compose-expr (nth 3 a) 0) + (if (eq calc-language 'maple) "" + (if (memq (nth 1 a) '(0 2)) ")" "]")))) + ((eq (car a) 'date) + (if (eq (car calc-date-format) 'X) + (math-format-date a) + (concat "<" (math-format-date a) ">"))) + ((and (eq (car a) 'calcFunc-subscr) (cdr (cdr a)) + (memq calc-language '(c pascal fortran maple))) + (let ((args (cdr (cdr a)))) + (while (and (memq calc-language '(pascal fortran)) + (eq (car-safe (nth 1 a)) 'calcFunc-subscr)) + (setq args (append (cdr (cdr (nth 1 a))) args) + a (nth 1 a))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + (if (eq calc-language 'fortran) "(" "[") + (math-compose-vector args ", " 0) + (if (eq calc-language 'fortran) ")" "]")))) + ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3) + (eq calc-language 'big)) + (let* ((a1 (math-compose-expr (nth 1 a) 1000)) + (calc-language 'flat) + (a2 (math-compose-expr (nth 2 a) 0))) + (if (or (eq (car-safe a1) 'subscr) + (and (eq (car-safe a1) 'tag) + (eq (car-safe (nth 2 a1)) 'subscr) + (setq a1 (nth 2 a1)))) + (list 'subscr + (nth 1 a1) + (list 'horiz + (nth 2 a1) + ", " + a2)) + (list 'subscr a1 a2)))) + ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3) + (eq calc-language 'math)) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[[" + (math-compose-expr (nth 2 a) 0) + "]]")) + ((and (eq (car a) 'calcFunc-sqrt) + (eq calc-language 'tex)) + (list 'horiz + "\\sqrt{" + (math-compose-expr (nth 1 a) 0) + "}")) + ((and nil (eq (car a) 'calcFunc-sqrt) + (eq calc-language 'eqn)) + (list 'horiz + "sqrt {" + (math-compose-expr (nth 1 a) -1) + "}")) + ((and (eq (car a) '^) + (eq calc-language 'big)) + (list 'supscr + (if (or (math-looks-negp (nth 1 a)) + (memq (car-safe (nth 1 a)) '(^ / frac calcFunc-sqrt)) + (and (eq (car-safe (nth 1 a)) 'cplx) + (math-negp (nth 1 (nth 1 a))) + (eq (nth 2 (nth 1 a)) 0))) + (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")") + (math-compose-expr (nth 1 a) 201)) + (let ((calc-language 'flat) + (calc-number-radix 10)) + (math-compose-expr (nth 2 a) 0)))) + ((and (eq (car a) '/) + (eq calc-language 'big)) + (let ((a1 (let ((calc-language (if (memq (car-safe (nth 1 a)) '(/ frac)) + 'flat 'big))) + (math-compose-expr (nth 1 a) 0))) + (a2 (let ((calc-language (if (memq (car-safe (nth 2 a)) '(/ frac)) + 'flat 'big))) + (math-compose-expr (nth 2 a) 0)))) + (list 'vcent + (math-comp-height a1) + a1 '(rule ?-) a2))) + ((and (memq (car a) '(calcFunc-sum calcFunc-prod)) + (eq calc-language 'tex) + (= (length a) 5)) + (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod") + "_{" (math-compose-expr (nth 2 a) 0) + "=" (math-compose-expr (nth 3 a) 0) + "}^{" (math-compose-expr (nth 4 a) 0) + "}{" (math-compose-expr (nth 1 a) 0) "}")) + ((and (eq (car a) 'calcFunc-lambda) + (> (length a) 2) + (memq calc-language '(nil flat big))) + (let ((p (cdr a)) + (ap calc-arg-values) + (math-compose-hash-args (if (= (length a) 3) 1 t))) + (while (and (cdr p) (equal (car p) (car ap))) + (setq p (cdr p) ap (cdr ap))) + (append '(horiz "<") + (if (cdr p) + (list (math-compose-vector + (nreverse (cdr (reverse (cdr a)))) ", " 0) + " : ") + nil) + (list (math-compose-expr (nth (1- (length a)) a) 0) + ">")))) + ((and (eq (car a) 'calcFunc-string) + (= (length a) 2) + (math-vectorp (nth 1 a)) + (math-vector-is-string (nth 1 a))) + (if (eq calc-language 'unform) + (concat "string(" (math-vector-to-string (nth 1 a) t) ")") + (math-vector-to-string (nth 1 a) nil))) + ((and (eq (car a) 'calcFunc-bstring) + (= (length a) 2) + (math-vectorp (nth 1 a)) + (math-vector-is-string (nth 1 a))) + (if (eq calc-language 'unform) + (concat "bstring(" (math-vector-to-string (nth 1 a) t) ")") + (let ((c nil) + (s (math-vector-to-string (nth 1 a) nil)) + p) + (while (string-match "[^ ] +[^ ]" s) + (setq p (1- (match-end 0)) + c (cons (list 'break math-compose-level) + (cons (substring s 0 p) + c)) + s (substring s p))) + (setq c (nreverse (cons s c))) + (or (= prec -123) + (setq c (cons (list 'set math-compose-level 2) c))) + (cons 'horiz c)))) + ((and (eq (car a) 'calcFunc-cprec) + (not (eq calc-language 'unform)) + (= (length a) 3) + (integerp (nth 2 a))) + (let ((c (math-compose-expr (nth 1 a) -1))) + (if (> prec (nth 2 a)) + (if (eq calc-language 'tex) + (list 'horiz "\\left( " c " \\right)") + (if (eq calc-language 'eqn) + (list 'horiz "{left ( " c " right )}") + (list 'horiz "(" c ")"))) + c))) + ((and (eq (car a) 'calcFunc-choriz) + (not (eq calc-language 'unform)) + (memq (length a) '(2 3 4)) + (math-vectorp (nth 1 a)) + (if (integerp (nth 2 a)) + (or (null (nth 3 a)) + (and (math-vectorp (nth 3 a)) + (math-vector-is-string (nth 3 a)))) + (or (null (nth 2 a)) + (and (math-vectorp (nth 2 a)) + (math-vector-is-string (nth 2 a)))))) + (let* ((cprec (and (integerp (nth 2 a)) (nth 2 a))) + (sep (nth (if cprec 3 2) a)) + (bprec nil)) + (if sep + (math-compose-vector (cdr (nth 1 a)) + (math-vector-to-string sep nil) + (or cprec prec)) + (cons 'horiz (mapcar (function + (lambda (x) + (if (eq (car-safe x) 'calcFunc-bstring) + (prog1 + (math-compose-expr + x (or bprec cprec prec)) + (setq bprec -123)) + (math-compose-expr x (or cprec prec))))) + (cdr (nth 1 a))))))) + ((and (memq (car a) '(calcFunc-cvert calcFunc-clvert calcFunc-crvert)) + (not (eq calc-language 'unform)) + (memq (length a) '(2 3)) + (math-vectorp (nth 1 a)) + (or (null (nth 2 a)) + (integerp (nth 2 a)))) + (let* ((base 0) + (v 0) + (prec (or (nth 2 a) prec)) + (c (mapcar (function + (lambda (x) + (let ((b nil) (cc nil) a d) + (if (and (memq (car-safe x) '(calcFunc-cbase + calcFunc-ctbase + calcFunc-cbbase)) + (memq (length x) '(1 2))) + (setq b (car x) + x (nth 1 x))) + (if (and (eq (car-safe x) 'calcFunc-crule) + (memq (length x) '(1 2)) + (or (null (nth 1 x)) + (and (math-vectorp (nth 1 x)) + (= (length (nth 1 x)) 2) + (math-vector-is-string + (nth 1 x))) + (and (natnump (nth 1 x)) + (<= (nth 1 x) 255)))) + (setq cc (list + 'rule + (if (math-vectorp (nth 1 x)) + (aref (math-vector-to-string + (nth 1 x) nil) 0) + (or (nth 1 x) ?-)))) + (or (and (memq (car-safe x) '(calcFunc-cvspace + calcFunc-ctspace + calcFunc-cbspace)) + (memq (length x) '(2 3)) + (eq (nth 1 x) 0)) + (null x) + (setq cc (math-compose-expr x prec)))) + (setq a (if cc (math-comp-ascent cc) 0) + d (if cc (math-comp-descent cc) 0)) + (if (eq b 'calcFunc-cbase) + (setq base (+ v a -1)) + (if (eq b 'calcFunc-ctbase) + (setq base v) + (if (eq b 'calcFunc-cbbase) + (setq base (+ v a d -1))))) + (setq v (+ v a d)) + cc))) + (cdr (nth 1 a))))) + (setq c (delq nil c)) + (if c + (cons (if (eq (car a) 'calcFunc-cvert) 'vcent + (if (eq (car a) 'calcFunc-clvert) 'vleft 'vright)) + (cons base c)) + " "))) + ((and (memq (car a) '(calcFunc-csup calcFunc-csub)) + (not (eq calc-language 'unform)) + (memq (length a) '(3 4)) + (or (null (nth 3 a)) + (integerp (nth 3 a)))) + (list (if (eq (car a) 'calcFunc-csup) 'supscr 'subscr) + (math-compose-expr (nth 1 a) (or (nth 3 a) 0)) + (math-compose-expr (nth 2 a) 0))) + ((and (eq (car a) 'calcFunc-cflat) + (not (eq calc-language 'unform)) + (memq (length a) '(2 3)) + (or (null (nth 2 a)) + (integerp (nth 2 a)))) + (let ((calc-language (if (memq calc-language '(nil big)) + 'flat calc-language))) + (math-compose-expr (nth 1 a) (or (nth 2 a) 0)))) + ((and (eq (car a) 'calcFunc-cspace) + (memq (length a) '(2 3)) + (natnump (nth 1 a))) + (if (nth 2 a) + (cons 'horiz (make-list (nth 1 a) + (if (and (math-vectorp (nth 2 a)) + (math-vector-is-string (nth 2 a))) + (math-vector-to-string (nth 2 a) nil) + (math-compose-expr (nth 2 a) 0)))) + (make-string (nth 1 a) ?\ ))) + ((and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace)) + (memq (length a) '(2 3)) + (natnump (nth 1 a))) + (if (= (nth 1 a) 0) + "" + (let* ((c (if (nth 2 a) + (if (and (math-vectorp (nth 2 a)) + (math-vector-is-string (nth 2 a))) + (math-vector-to-string (nth 2 a) nil) + (math-compose-expr (nth 2 a) 0)) + " ")) + (ca (math-comp-ascent c)) + (cd (math-comp-descent c))) + (cons 'vleft + (cons (if (eq (car a) 'calcFunc-ctspace) + (1- ca) + (if (eq (car a) 'calcFunc-cbspace) + (+ (* (1- (nth 1 a)) (+ ca cd)) (1- ca)) + (/ (1- (* (nth 1 a) (+ ca cd))) 2))) + (make-list (nth 1 a) c)))))) + ((and (eq (car a) 'calcFunc-evalto) + (setq calc-any-evaltos t) + (memq calc-language '(tex eqn)) + (= math-compose-level (if math-comp-tagged 2 1)) + (= (length a) 3)) + (list 'horiz + (if (eq calc-language 'tex) "\\evalto " "evalto ") + (math-compose-expr (nth 1 a) 0) + (if (eq calc-language 'tex) " \\to " " -> ") + (math-compose-expr (nth 2 a) 0))) + (t + (let ((op (and (not (eq calc-language 'unform)) + (if (and (eq (car a) 'calcFunc-if) (= (length a) 4)) + (assoc "?" math-expr-opers) + (math-assq2 (car a) math-expr-opers))))) + (cond ((and op + (or (= (length a) 3) (eq (car a) 'calcFunc-if)) + (/= (nth 3 op) -1)) + (cond + ((> prec (or (nth 4 op) (min (nth 2 op) (nth 3 op)))) + (if (and (eq calc-language 'tex) + (not (math-tex-expr-is-flat a))) + (if (eq (car-safe a) '/) + (list 'horiz "{" (math-compose-expr a -1) "}") + (list 'horiz "\\left( " + (math-compose-expr a -1) + " \\right)")) + (if (eq calc-language 'eqn) + (if (or (eq (car-safe a) '/) + (= (/ prec 100) 9)) + (list 'horiz "{" (math-compose-expr a -1) "}") + (if (math-tex-expr-is-flat a) + (list 'horiz "( " (math-compose-expr a -1) " )") + (list 'horiz "{left ( " + (math-compose-expr a -1) + " right )}"))) + (list 'horiz "(" (math-compose-expr a 0) ")")))) + ((and (eq calc-language 'tex) + (memq (car a) '(/ calcFunc-choose calcFunc-evalto)) + (>= prec 0)) + (list 'horiz "{" (math-compose-expr a -1) "}")) + ((eq (car a) 'calcFunc-if) + (list 'horiz + (math-compose-expr (nth 1 a) (nth 2 op)) + " ? " + (math-compose-expr (nth 2 a) 0) + " : " + (math-compose-expr (nth 3 a) (nth 3 op)))) + (t + (let* ((math-comp-tagged (and math-comp-tagged + (not (math-primp a)) + math-comp-tagged)) + (setlev (if (= prec (min (nth 2 op) (nth 3 op))) + (progn + (setq math-compose-level + (1- math-compose-level)) + nil) + math-compose-level)) + (lhs (math-compose-expr (nth 1 a) (nth 2 op))) + (rhs (math-compose-expr (nth 2 a) (nth 3 op)))) + (and (equal (car op) "^") + (eq (math-comp-first-char lhs) ?-) + (setq lhs (list 'horiz "(" lhs ")"))) + (and (eq calc-language 'tex) + (or (equal (car op) "^") (equal (car op) "_")) + (not (and (stringp rhs) (= (length rhs) 1))) + (setq rhs (list 'horiz "{" rhs "}"))) + (or (and (eq (car a) '*) + (or (null calc-language) + (assoc "2x" math-expr-opers)) + (let* ((prevt (math-prod-last-term (nth 1 a))) + (nextt (math-prod-first-term (nth 2 a))) + (prevc (or (math-comp-last-char lhs) + (and (memq (car-safe prevt) + '(^ calcFunc-subscr + calcFunc-sqrt + frac)) + (eq calc-language 'big) + ?0))) + (nextc (or (math-comp-first-char rhs) + (and (memq (car-safe nextt) + '(calcFunc-sqrt + calcFunc-sum + calcFunc-prod + calcFunc-integ)) + (eq calc-language 'big) + ?0)))) + (and prevc nextc + (or (and (>= nextc ?a) (<= nextc ?z)) + (and (>= nextc ?A) (<= nextc ?Z)) + (and (>= nextc ?0) (<= nextc ?9)) + (memq nextc '(?. ?_ ?# + ?\( ?\[ ?\{)) + (and (eq nextc ?\\) + (not (string-match + "\\`\\\\left(" + (math-comp-first-string + rhs))))) + (not (and (eq (car-safe prevt) 'var) + (eq nextc ?\())) + (list 'horiz + (list 'set setlev 1) + lhs + (list 'break math-compose-level) + " " + rhs)))) + (list 'horiz + (list 'set setlev 1) + lhs + (list 'break math-compose-level) + (if (or (equal (car op) "^") + (equal (car op) "_") + (equal (car op) "**") + (and (equal (car op) "*") + (math-comp-last-char lhs) + (math-comp-first-char rhs)) + (and (equal (car op) "/") + (math-num-integerp (nth 1 a)) + (math-integerp (nth 2 a)))) + (car op) + (if (and (eq calc-language 'big) + (equal (car op) "=>")) + " => " + (concat " " (car op) " "))) + rhs)))))) + ((and op (= (length a) 2) (= (nth 3 op) -1)) + (cond + ((or (> prec (or (nth 4 op) (nth 2 op))) + (and (not (eq (assoc (car op) math-expr-opers) op)) + (> prec 0))) ; don't write x% + y + (if (and (eq calc-language 'tex) + (not (math-tex-expr-is-flat a))) + (list 'horiz "\\left( " + (math-compose-expr a -1) + " \\right)") + (if (eq calc-language 'eqn) + (if (= (/ prec 100) 9) + (list 'horiz "{" (math-compose-expr a -1) "}") + (if (math-tex-expr-is-flat a) + (list 'horiz "{( " (math-compose-expr a -1) " )}") + (list 'horiz "{left ( " + (math-compose-expr a -1) + " right )}"))) + (list 'horiz "(" (math-compose-expr a 0) ")")))) + (t + (let ((lhs (math-compose-expr (nth 1 a) (nth 2 op)))) + (list 'horiz + lhs + (if (or (> (length (car op)) 1) + (not (math-comp-is-flat lhs))) + (concat " " (car op)) + (car op))))))) + ((and op (= (length a) 2) (= (nth 2 op) -1)) + (cond + ((eq (nth 3 op) 0) + (let ((lr (and (eq calc-language 'tex) + (not (math-tex-expr-is-flat (nth 1 a)))))) + (list 'horiz + (if lr "\\left" "") + (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" (car op)) + (substring (car op) 1) + (car op)) + (if (or lr (> (length (car op)) 2)) " " "") + (math-compose-expr (nth 1 a) -1) + (if (or lr (> (length (car op)) 2)) " " "") + (if lr "\\right" "") + (car (nth 1 (memq op math-expr-opers)))))) + ((> prec (or (nth 4 op) (nth 3 op))) + (if (and (eq calc-language 'tex) + (not (math-tex-expr-is-flat a))) + (list 'horiz "\\left( " + (math-compose-expr a -1) + " \\right)") + (if (eq calc-language 'eqn) + (if (= (/ prec 100) 9) + (list 'horiz "{" (math-compose-expr a -1) "}") + (if (math-tex-expr-is-flat a) + (list 'horiz "{( " (math-compose-expr a -1) " )}") + (list 'horiz "{left ( " + (math-compose-expr a -1) + " right )}"))) + (list 'horiz "(" (math-compose-expr a 0) ")")))) + (t + (let ((rhs (math-compose-expr (nth 1 a) (nth 3 op)))) + (list 'horiz + (let ((ops (if (string-match "\\`u\\([^a-zA-Z]\\)\\'" + (car op)) + (substring (car op) 1) + (car op)))) + (if (or (> (length ops) 1) + (not (math-comp-is-flat rhs))) + (concat ops " ") + ops)) + rhs))))) + ((and (eq calc-language 'big) + (setq op (get (car a) 'math-compose-big)) + (funcall op a prec))) + ((and (setq op (assq calc-language + '( ( nil . math-compose-normal ) + ( flat . math-compose-normal ) + ( big . math-compose-normal ) + ( c . math-compose-c ) + ( pascal . math-compose-pascal ) + ( fortran . math-compose-fortran ) + ( tex . math-compose-tex ) + ( eqn . math-compose-eqn ) + ( math . math-compose-math ) + ( maple . math-compose-maple )))) + (setq op (get (car a) (cdr op))) + (funcall op a prec))) + (t + (let* ((func (car a)) + (func2 (assq func '(( mod . calcFunc-makemod ) + ( sdev . calcFunc-sdev ) + ( + . calcFunc-add ) + ( - . calcFunc-sub ) + ( * . calcFunc-mul ) + ( / . calcFunc-div ) + ( % . calcFunc-mod ) + ( ^ . calcFunc-pow ) + ( neg . calcFunc-neg ) + ( | . calcFunc-vconcat )))) + left right args) + (if func2 + (setq func (cdr func2))) + (if (setq func2 (rassq func math-expr-function-mapping)) + (setq func (car func2))) + (setq func (math-remove-dashes + (if (string-match + "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'" + (symbol-name func)) + (math-match-substring (symbol-name func) 1) + (symbol-name func)))) + (if (memq calc-language '(c fortran pascal maple)) + (setq func (math-to-underscores func))) + (if (and (eq calc-language 'tex) + calc-language-option + (not (= calc-language-option 0)) + (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func)) + (if (< (prefix-numeric-value calc-language-option) 0) + (setq func (format "\\%s" func)) + (setq func (format "\\hbox{%s}" func)))) + (if (and (eq calc-language 'eqn) + (string-match "[^']'+\\'" func)) + (let ((n (- (length func) (match-beginning 0) 1))) + (setq func (substring func 0 (- n))) + (while (>= (setq n (1- n)) 0) + (setq func (concat func " prime"))))) + (cond ((and (eq calc-language 'tex) + (or (> (length a) 2) + (not (math-tex-expr-is-flat (nth 1 a))))) + (setq left "\\left( " + right " \\right)")) + ((and (eq calc-language 'eqn) + (or (> (length a) 2) + (not (math-tex-expr-is-flat (nth 1 a))))) + (setq left "{left ( " + right " right )}")) + ((and (or (and (eq calc-language 'tex) + (eq (aref func 0) ?\\)) + (and (eq calc-language 'eqn) + (memq (car a) math-eqn-special-funcs))) + (not (string-match "\\hbox{" func)) + (= (length a) 2) + (or (Math-realp (nth 1 a)) + (memq (car (nth 1 a)) '(var *)))) + (setq left (if (eq calc-language 'eqn) "~{" "{") + right "}")) + ((eq calc-language 'eqn) + (setq left " ( " + right " )")) + (t (setq left calc-function-open + right calc-function-close))) + (list 'horiz func left + (math-compose-vector (cdr a) + (if (eq calc-language 'eqn) + " , " ", ") + 0) + right)))))))) +) + +(defconst math-eqn-special-funcs + '( calcFunc-log + calcFunc-ln calcFunc-exp + calcFunc-sin calcFunc-cos calcFunc-tan + calcFunc-sinh calcFunc-cosh calcFunc-tanh + calcFunc-arcsin calcFunc-arccos calcFunc-arctan + calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh +)) + + +(defun math-prod-first-term (x) + (while (eq (car-safe x) '*) + (setq x (nth 1 x))) + x +) + +(defun math-prod-last-term (x) + (while (eq (car-safe x) '*) + (setq x (nth 2 x))) + x +) + +(defun math-compose-vector (a sep prec) + (if a + (cons 'horiz + (cons (list 'set math-compose-level) + (let ((c (list (math-compose-expr (car a) prec)))) + (while (setq a (cdr a)) + (setq c (cons (if (eq (car-safe (car a)) + 'calcFunc-bstring) + (let ((math-compose-level + (1- math-compose-level))) + (math-compose-expr (car a) -123)) + (math-compose-expr (car a) prec)) + (cons (list 'break math-compose-level) + (cons sep c))))) + (nreverse c)))) + "") +) + +(defun math-vector-no-parens (a) + (or (cdr (cdr a)) + (not (eq (car-safe (nth 1 a)) '*))) +) + +(defun math-compose-matrix (a col cols base) + (let ((col 0) + (res nil)) + (while (<= (setq col (1+ col)) cols) + (setq res (cons (cons just + (cons base + (mapcar (function + (lambda (r) + (list 'horiz + (math-compose-expr + (nth col r) + vector-prec) + (if (= col cols) + "" + (concat comma-spc " "))))) + a))) + res))) + (nreverse res)) +) + +(defun math-compose-rows (a count first) + (if (cdr a) + (if (<= count 0) + (if (< count 0) + (math-compose-rows (cdr a) -1 nil) + (cons (concat (if (eq calc-language 'tex) " \\ldots" " ...") + comma) + (math-compose-rows (cdr a) -1 nil))) + (cons (list 'horiz + (if first (concat left-bracket " ") " ") + (math-compose-expr (car a) vector-prec) + comma) + (math-compose-rows (cdr a) (1- count) nil))) + (list (list 'horiz + (if first (concat left-bracket " ") " ") + (math-compose-expr (car a) vector-prec) + (concat " " right-bracket)))) +) + +(defun math-compose-tex-matrix (a) + (if (cdr a) + (cons (math-compose-vector (cdr (car a)) " & " 0) + (cons " \\\\ " + (math-compose-tex-matrix (cdr a)))) + (list (math-compose-vector (cdr (car a)) " & " 0))) +) + +(defun math-compose-eqn-matrix (a) + (if a + (cons + (cond ((eq calc-matrix-just 'right) "rcol ") + ((eq calc-matrix-just 'center) "ccol ") + (t "lcol ")) + (cons + (list 'break math-compose-level) + (cons + "{ " + (cons + (let ((math-compose-level (1+ math-compose-level))) + (math-compose-vector (cdr (car a)) " above " 1000)) + (cons + " } " + (math-compose-eqn-matrix (cdr a))))))) + nil) +) + +(defun math-vector-is-string (a) + (while (and (setq a (cdr a)) + (or (and (natnump (car a)) + (<= (car a) 255)) + (and (eq (car-safe (car a)) 'cplx) + (natnump (nth 1 (car a))) + (eq (nth 2 (car a)) 0) + (<= (nth 1 (car a)) 255))))) + (null a) +) + +(defun math-vector-to-string (a &optional quoted) + (setq a (concat (mapcar (function (lambda (x) (if (consp x) (nth 1 x) x))) + (cdr a)))) + (if (string-match "[\000-\037\177\\\"]" a) + (let ((p 0) + (pat (if quoted "[\000-\037\177\\\"]" "[\000-\037\177]")) + (codes (if quoted math-vector-to-string-chars '((?\^? . "^?")))) + (fmt (if quoted "\\^%c" "^%c")) + new) + (while (setq p (string-match pat a p)) + (if (setq new (assq (aref a p) codes)) + (setq a (concat (substring a 0 p) + (cdr new) + (substring a (1+ p))) + p (+ p (length (cdr new)))) + (setq a (concat (substring a 0 p) + (format fmt (+ (aref a p) 64)) + (substring a (1+ p))) + p (+ p 2)))))) + (if quoted + (concat "\"" a "\"") + a) +) +(defconst math-vector-to-string-chars '( ( ?\" . "\\\"" ) + ( ?\\ . "\\\\" ) + ( ?\a . "\\a" ) + ( ?\b . "\\b" ) + ( ?\e . "\\e" ) + ( ?\f . "\\f" ) + ( ?\n . "\\n" ) + ( ?\r . "\\r" ) + ( ?\t . "\\t" ) + ( ?\^? . "\\^?" ) +)) + +(defun math-to-underscores (x) + (if (string-match "\\`\\(.*\\)#\\(.*\\)\\'" x) + (math-to-underscores + (concat (math-match-substring x 1) "_" (math-match-substring x 2))) + x) +) + +(defun math-tex-expr-is-flat (a) + (or (Math-integerp a) + (memq (car a) '(float var)) + (and (memq (car a) '(+ - * neg)) + (progn + (while (and (setq a (cdr a)) + (math-tex-expr-is-flat (car a)))) + (null a))) + (and (memq (car a) '(^ calcFunc-subscr)) + (math-tex-expr-is-flat (nth 1 a)))) +) + +(put 'calcFunc-log 'math-compose-big 'math-compose-log) +(defun math-compose-log (a prec) + (and (= (length a) 3) + (list 'horiz + (list 'subscr "log" + (let ((calc-language 'flat)) + (math-compose-expr (nth 2 a) 1000))) + "(" + (math-compose-expr (nth 1 a) 1000) + ")")) +) + +(put 'calcFunc-log10 'math-compose-big 'math-compose-log10) +(defun math-compose-log10 (a prec) + (and (= (length a) 2) + (list 'horiz + (list 'subscr "log" "10") + "(" + (math-compose-expr (nth 1 a) 1000) + ")")) +) + +(put 'calcFunc-deriv 'math-compose-big 'math-compose-deriv) +(put 'calcFunc-tderiv 'math-compose-big 'math-compose-deriv) +(defun math-compose-deriv (a prec) + (and (= (length a) 3) + (math-compose-expr (list '/ + (list 'calcFunc-choriz + (list 'vec + '(calcFunc-string (vec ?d)) + (nth 1 a))) + (list 'calcFunc-choriz + (list 'vec + '(calcFunc-string (vec ?d)) + (nth 2 a)))) + prec)) +) + +(put 'calcFunc-sqrt 'math-compose-big 'math-compose-sqrt) +(defun math-compose-sqrt (a prec) + (and (= (length a) 2) + (let* ((c (math-compose-expr (nth 1 a) 0)) + (a (math-comp-ascent c)) + (d (math-comp-descent c)) + (h (+ a d)) + (w (math-comp-width c))) + (list 'vleft + a + (concat (if (= h 1) " " " ") + (make-string (+ w 2) ?\_)) + (list 'horiz + (if (= h 1) + "V" + (append (list 'vleft (1- a)) + (make-list (1- h) " |") + '("\\|"))) + " " + c)))) +) + +(put 'calcFunc-choose 'math-compose-big 'math-compose-choose) +(defun math-compose-choose (a prec) + (let ((a1 (math-compose-expr (nth 1 a) 0)) + (a2 (math-compose-expr (nth 2 a) 0))) + (list 'horiz + "(" + (list 'vcent + (math-comp-height a1) + a1 " " a2) + ")")) +) + +(put 'calcFunc-integ 'math-compose-big 'math-compose-integ) +(defun math-compose-integ (a prec) + (and (memq (length a) '(3 5)) + (eq (car-safe (nth 2 a)) 'var) + (let* ((parens (and (>= prec 196) (/= prec 1000))) + (var (math-compose-expr (nth 2 a) 0)) + (over (and (eq (car-safe (nth 2 a)) 'var) + (or (and (eq (car-safe (nth 1 a)) '/) + (math-numberp (nth 1 (nth 1 a)))) + (and (eq (car-safe (nth 1 a)) '^) + (math-looks-negp (nth 2 (nth 1 a))))))) + (expr (math-compose-expr (if over + (math-mul (nth 1 a) + (math-build-var-name + (format + "d%s" + (nth 1 (nth 2 a))))) + (nth 1 a)) 185)) + (calc-language 'flat) + (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) + (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0)))) + (list 'horiz + (if parens "(" "") + (append (list 'vcent (if high 3 2)) + (and high (list (list 'horiz " " high))) + '(" /" + " | " + " | " + " | " + "/ ") + (and low (list (list 'horiz low " ")))) + expr + (if over + "" + (list 'horiz " d" var)) + (if parens ")" "")))) +) + +(put 'calcFunc-sum 'math-compose-big 'math-compose-sum) +(defun math-compose-sum (a prec) + (and (memq (length a) '(3 5 6)) + (let* ((expr (math-compose-expr (nth 1 a) 185)) + (calc-language 'flat) + (var (math-compose-expr (nth 2 a) 0)) + (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) + (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) + (list 'horiz + (if (memq prec '(180 201)) "(" "") + (append (list 'vcent (if high 3 2)) + (and high (list high)) + '("---- " + "\\ " + " > " + "/ " + "---- ") + (if low + (list (list 'horiz var " = " low)) + (list var))) + (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) + " " "") + expr + (if (memq prec '(180 201)) ")" "")))) +) + +(put 'calcFunc-prod 'math-compose-big 'math-compose-prod) +(defun math-compose-prod (a prec) + (and (memq (length a) '(3 5 6)) + (let* ((expr (math-compose-expr (nth 1 a) 198)) + (calc-language 'flat) + (var (math-compose-expr (nth 2 a) 0)) + (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0))) + (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0)))) + (list 'horiz + (if (memq prec '(196 201)) "(" "") + (append (list 'vcent (if high 3 2)) + (and high (list high)) + '("----- " + " | | " + " | | " + " | | ") + (if low + (list (list 'horiz var " = " low)) + (list var))) + (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod)) + " " "") + expr + (if (memq prec '(196 201)) ")" "")))) +) + + +(defun math-stack-value-offset-fancy () + (let ((cwid (+ (math-comp-width c)))) + (cond ((eq calc-display-just 'right) + (if calc-display-origin + (setq wid (max calc-display-origin 5)) + (if (integerp calc-line-breaking) + (setq wid calc-line-breaking))) + (setq off (- wid cwid + (max (- (length calc-right-label) + (if (and (integerp calc-line-breaking) + calc-display-origin) + (max (- calc-line-breaking + calc-display-origin) + 0) + 0)) + 0)))) + (t + (if calc-display-origin + (progn + (setq off (- calc-display-origin (/ cwid 2))) + (if (integerp calc-line-breaking) + (setq off (min off (- calc-line-breaking cwid + (length calc-right-label))))) + (if (>= off 0) + (setq wid (max wid (+ off cwid))))) + (if (integerp calc-line-breaking) + (setq wid calc-line-breaking)) + (setq off (/ (- wid cwid) 2))))) + (and (integerp calc-line-breaking) + (or (< off 0) + (and calc-display-origin + (> calc-line-breaking calc-display-origin))) + (setq wid calc-line-breaking))) +) + + + +;;; Convert a composition to string form, with embedded \n's if necessary. + +(defun math-composition-to-string (c &optional width) + (or width (setq width (calc-window-width))) + (if calc-display-raw + (math-comp-to-string-raw c 0) + (if (math-comp-is-flat c) + (math-comp-to-string-flat c width) + (math-vert-comp-to-string + (math-comp-simplify c width)))) +) + +(defun math-comp-is-flat (c) ; check if c's height is 1. + (cond ((not (consp c)) t) + ((memq (car c) '(set break)) t) + ((eq (car c) 'horiz) + (while (and (setq c (cdr c)) + (math-comp-is-flat (car c)))) + (null c)) + ((memq (car c) '(vleft vcent vright)) + (and (= (length c) 3) + (= (nth 1 c) 0) + (math-comp-is-flat (nth 2 c)))) + ((eq (car c) 'tag) + (math-comp-is-flat (nth 2 c))) + (t nil)) +) + + +;;; Convert a one-line composition to a string. Break into multiple +;;; lines if necessary, choosing break points according to the structure +;;; of the formula. + +(defun math-comp-to-string-flat (c full-width) + (if math-comp-sel-hpos + (let ((comp-pos 0)) + (math-comp-sel-flat-term c)) + (let ((comp-buf "") + (comp-word "") + (comp-pos 0) + (comp-margin 0) + (comp-highlight (and math-comp-selected calc-show-selections)) + (comp-level -1)) + (math-comp-to-string-flat-term '(set -1 0)) + (math-comp-to-string-flat-term c) + (math-comp-to-string-flat-term '(break -1)) + (let ((str (aref math-comp-buf-string 0)) + (prefix "")) + (and (> (length str) 0) (= (aref str 0) ? ) + (> (length comp-buf) 0) + (let ((k (length comp-buf))) + (while (not (= (aref comp-buf (setq k (1- k))) ?\n))) + (aset comp-buf k ? ) + (if (and (< (1+ k) (length comp-buf)) + (= (aref comp-buf (1+ k)) ? )) + (progn + (aset comp-buf (1+ k) ?\n) + (setq prefix " ")) + (setq prefix "\n")))) + (concat comp-buf prefix str)))) +) +(setq math-comp-buf-string (make-vector 10 "")) +(setq math-comp-buf-margin (make-vector 10 0)) +(setq math-comp-buf-level (make-vector 10 0)) + +(defun math-comp-to-string-flat-term (c) + (cond ((not (consp c)) + (if comp-highlight + (setq c (math-comp-highlight-string c))) + (setq comp-word (if (= (length comp-word) 0) c (concat comp-word c)) + comp-pos (+ comp-pos (length c)))) + + ((eq (car c) 'horiz) + (while (setq c (cdr c)) + (math-comp-to-string-flat-term (car c)))) + + ((eq (car c) 'set) + (if (nth 1 c) + (progn + (setq comp-level (1+ comp-level)) + (if (>= comp-level (length math-comp-buf-string)) + (setq math-comp-buf-string (vconcat math-comp-buf-string + math-comp-buf-string) + math-comp-buf-margin (vconcat math-comp-buf-margin + math-comp-buf-margin) + math-comp-buf-level (vconcat math-comp-buf-level + math-comp-buf-level))) + (aset math-comp-buf-string comp-level "") + (aset math-comp-buf-margin comp-level (+ comp-pos + (or (nth 2 c) 0))) + (aset math-comp-buf-level comp-level (nth 1 c))))) + + ((eq (car c) 'break) + (if (not calc-line-breaking) + (setq comp-buf (concat comp-buf comp-word) + comp-word "") + (let ((i 0) str) + (if (and (> comp-pos full-width) + (progn + (while (progn + (setq str (aref math-comp-buf-string i)) + (and (= (length str) 0) (< i comp-level))) + (setq i (1+ i))) + (or (> (length str) 0) (> (length comp-buf) 0)))) + (let ((prefix "") mrg wid) + (setq mrg (aref math-comp-buf-margin i)) + (if (> mrg 12) ; indenting too far, go back to far left + (let ((j i) (new (if calc-line-numbering 5 1))) + '(while (<= j comp-level) + (aset math-comp-buf-margin j + (+ (aref math-comp-buf-margin j) (- new mrg))) + (setq j (1+ j))) + (setq mrg new))) + (setq wid (+ (length str) comp-margin)) + (and (> (length str) 0) (= (aref str 0) ? ) + (> (length comp-buf) 0) + (let ((k (length comp-buf))) + (while (not (= (aref comp-buf (setq k (1- k))) ?\n))) + (aset comp-buf k ? ) + (if (and (< (1+ k) (length comp-buf)) + (= (aref comp-buf (1+ k)) ? )) + (progn + (aset comp-buf (1+ k) ?\n) + (setq prefix " ")) + (setq prefix "\n")))) + (setq comp-buf (concat comp-buf prefix str "\n" + (make-string mrg ? )) + comp-pos (+ comp-pos (- mrg wid)) + comp-margin mrg) + (aset math-comp-buf-string i "") + (while (<= (setq i (1+ i)) comp-level) + (if (> (aref math-comp-buf-margin i) wid) + (aset math-comp-buf-margin i + (+ (aref math-comp-buf-margin i) + (- mrg wid)))))))) + (if (and (= (nth 1 c) (aref math-comp-buf-level comp-level)) + (< comp-pos (+ (aref math-comp-buf-margin comp-level) 2))) + () ; avoid stupid breaks, e.g., "1 +\n really_long_expr" + (let ((str (aref math-comp-buf-string comp-level))) + (setq str (if (= (length str) 0) + comp-word + (concat str comp-word)) + comp-word "") + (while (< (nth 1 c) (aref math-comp-buf-level comp-level)) + (setq comp-level (1- comp-level)) + (or (= (length (aref math-comp-buf-string comp-level)) 0) + (setq str (concat (aref math-comp-buf-string comp-level) + str)))) + (aset math-comp-buf-string comp-level str))))) + + ((eq (car c) 'tag) + (cond ((eq (nth 1 c) math-comp-selected) + (let ((comp-highlight (not calc-show-selections))) + (math-comp-to-string-flat-term (nth 2 c)))) + ((eq (nth 1 c) t) + (let ((comp-highlight nil)) + (math-comp-to-string-flat-term (nth 2 c)))) + (t (math-comp-to-string-flat-term (nth 2 c))))) + + (t (math-comp-to-string-flat-term (nth 2 c)))) +) + +(defun math-comp-highlight-string (s) + (setq s (copy-sequence s)) + (let ((i (length s))) + (while (>= (setq i (1- i)) 0) + (or (memq (aref s i) '(32 ?\n)) + (aset s i (if calc-show-selections ?\. ?\#))))) + s +) + +(defun math-comp-sel-flat-term (c) + (cond ((not (consp c)) + (setq comp-pos (+ comp-pos (length c)))) + ((memq (car c) '(set break))) + ((eq (car c) 'horiz) + (while (and (setq c (cdr c)) (< math-comp-sel-cpos 1000000)) + (math-comp-sel-flat-term (car c)))) + ((eq (car c) 'tag) + (if (<= comp-pos math-comp-sel-cpos) + (progn + (math-comp-sel-flat-term (nth 2 c)) + (if (> comp-pos math-comp-sel-cpos) + (setq math-comp-sel-tag c + math-comp-sel-cpos 1000000))) + (math-comp-sel-flat-term (nth 2 c)))) + (t (math-comp-sel-flat-term (nth 2 c)))) +) + + +;;; Simplify a composition to a canonical form consisting of +;;; (vleft n "string" "string" "string" ...) +;;; where 0 <= n < number-of-strings. + +(defun math-comp-simplify (c full-width) + (let ((comp-buf (list "")) + (comp-base 0) + (comp-height 1) + (comp-hpos 0) + (comp-vpos 0) + (comp-highlight (and math-comp-selected calc-show-selections)) + (comp-tag nil)) + (math-comp-simplify-term c) + (cons 'vleft (cons comp-base comp-buf))) +) + +(defun math-comp-add-string (s h v) + (and (> (length s) 0) + (let ((vv (+ v comp-base))) + (if math-comp-sel-hpos + (math-comp-add-string-sel h vv (length s) 1) + (if (< vv 0) + (setq comp-buf (nconc (make-list (- vv) "") comp-buf) + comp-base (- v) + comp-height (- comp-height vv) + vv 0) + (if (>= vv comp-height) + (setq comp-buf (nconc comp-buf + (make-list (1+ (- vv comp-height)) "")) + comp-height (1+ vv)))) + (let ((str (nthcdr vv comp-buf))) + (setcar str (concat (car str) + (make-string (- h (length (car str))) 32) + (if comp-highlight + (math-comp-highlight-string s) + s))))))) +) + +(defun math-comp-add-string-sel (x y w h) + (if (and (<= y math-comp-sel-vpos) + (> (+ y h) math-comp-sel-vpos) + (<= x math-comp-sel-hpos) + (> (+ x w) math-comp-sel-hpos)) + (setq math-comp-sel-tag comp-tag + math-comp-sel-vpos 10000)) +) + +(defun math-comp-simplify-term (c) + (cond ((stringp c) + (math-comp-add-string c comp-hpos comp-vpos) + (setq comp-hpos (+ comp-hpos (length c)))) + ((memq (car c) '(set break)) + nil) + ((eq (car c) 'horiz) + (while (setq c (cdr c)) + (math-comp-simplify-term (car c)))) + ((memq (car c) '(vleft vcent vright)) + (let* ((comp-vpos (+ (- comp-vpos (nth 1 c)) + (1- (math-comp-ascent (nth 2 c))))) + (widths (mapcar 'math-comp-width (cdr (cdr c)))) + (maxwid (apply 'max widths)) + (bias (cond ((eq (car c) 'vleft) 0) + ((eq (car c) 'vcent) 1) + (t 2)))) + (setq c (cdr c)) + (while (setq c (cdr c)) + (if (eq (car-safe (car c)) 'rule) + (math-comp-add-string (make-string maxwid (nth 1 (car c))) + comp-hpos comp-vpos) + (let ((comp-hpos (+ comp-hpos (/ (* bias (- maxwid + (car widths))) + 2)))) + (math-comp-simplify-term (car c)))) + (and (cdr c) + (setq comp-vpos (+ comp-vpos + (+ (math-comp-descent (car c)) + (math-comp-ascent (nth 1 c)))) + widths (cdr widths)))) + (setq comp-hpos (+ comp-hpos maxwid)))) + ((eq (car c) 'supscr) + (let* ((asc (or 1 (math-comp-ascent (nth 1 c)))) + (desc (math-comp-descent (nth 2 c))) + (oldh (prog1 + comp-hpos + (math-comp-simplify-term (nth 1 c)))) + (comp-vpos (- comp-vpos (+ asc desc)))) + (math-comp-simplify-term (nth 2 c)) + (if math-comp-sel-hpos + (math-comp-add-string-sel oldh + (- comp-vpos + -1 + (math-comp-ascent (nth 2 c))) + (- comp-hpos oldh) + (math-comp-height c))))) + ((eq (car c) 'subscr) + (let* ((asc (math-comp-ascent (nth 2 c))) + (desc (math-comp-descent (nth 1 c))) + (oldv comp-vpos) + (oldh (prog1 + comp-hpos + (math-comp-simplify-term (nth 1 c)))) + (comp-vpos (+ comp-vpos (+ asc desc)))) + (math-comp-simplify-term (nth 2 c)) + (if math-comp-sel-hpos + (math-comp-add-string-sel oldh oldv + (- comp-hpos oldh) + (math-comp-height c))))) + ((eq (car c) 'tag) + (cond ((eq (nth 1 c) math-comp-selected) + (let ((comp-highlight (not calc-show-selections))) + (math-comp-simplify-term (nth 2 c)))) + ((eq (nth 1 c) t) + (let ((comp-highlight nil)) + (math-comp-simplify-term (nth 2 c)))) + (t (let ((comp-tag c)) + (math-comp-simplify-term (nth 2 c))))))) +) + + +;;; Measuring a composition. + +(defun math-comp-first-char (c) + (cond ((stringp c) + (and (> (length c) 0) + (elt c 0))) + ((memq (car c) '(horiz subscr supscr)) + (while (and (setq c (cdr c)) + (math-comp-is-null (car c)))) + (and c (math-comp-first-char (car c)))) + ((eq (car c) 'tag) + (math-comp-first-char (nth 2 c)))) +) + +(defun math-comp-first-string (c) + (cond ((stringp c) + (and (> (length c) 0) + c)) + ((eq (car c) 'horiz) + (while (and (setq c (cdr c)) + (math-comp-is-null (car c)))) + (and c (math-comp-first-string (car c)))) + ((eq (car c) 'tag) + (math-comp-first-string (nth 2 c)))) +) + +(defun math-comp-last-char (c) + (cond ((stringp c) + (and (> (length c) 0) + (elt c (1- (length c))))) + ((eq (car c) 'horiz) + (let ((c (reverse (cdr c)))) + (while (and c (math-comp-is-null (car c))) + (setq c (cdr c))) + (and c (math-comp-last-char (car c))))) + ((eq (car c) 'tag) + (math-comp-last-char (nth 2 c)))) +) + +(defun math-comp-is-null (c) + (cond ((stringp c) (= (length c) 0)) + ((memq (car c) '(horiz subscr supscr)) + (while (and (setq c (cdr c)) + (math-comp-is-null (car c)))) + (null c)) + ((eq (car c) 'tag) + (math-comp-is-null (nth 2 c))) + ((memq (car c) '(set break)) t)) +) + +(defun math-comp-width (c) + (cond ((not (consp c)) (length c)) + ((memq (car c) '(horiz subscr supscr)) + (let ((accum 0)) + (while (setq c (cdr c)) + (setq accum (+ accum (math-comp-width (car c))))) + accum)) + ((memq (car c) '(vcent vleft vright)) + (setq c (cdr c)) + (let ((accum 0)) + (while (setq c (cdr c)) + (setq accum (max accum (math-comp-width (car c))))) + accum)) + ((eq (car c) 'tag) + (math-comp-width (nth 2 c))) + (t 0)) +) + +(defun math-comp-height (c) + (if (stringp c) + 1 + (+ (math-comp-ascent c) (math-comp-descent c))) +) + +(defun math-comp-ascent (c) + (cond ((not (consp c)) 1) + ((eq (car c) 'horiz) + (let ((accum 0)) + (while (setq c (cdr c)) + (setq accum (max accum (math-comp-ascent (car c))))) + accum)) + ((memq (car c) '(vcent vleft vright)) + (if (> (nth 1 c) 0) (1+ (nth 1 c)) 1)) + ((eq (car c) 'supscr) + (max (math-comp-ascent (nth 1 c)) (1+ (math-comp-height (nth 2 c))))) + ((eq (car c) 'subscr) + (math-comp-ascent (nth 1 c))) + ((eq (car c) 'tag) + (math-comp-ascent (nth 2 c))) + (t 1)) +) + +(defun math-comp-descent (c) + (cond ((not (consp c)) 0) + ((eq (car c) 'horiz) + (let ((accum 0)) + (while (setq c (cdr c)) + (setq accum (max accum (math-comp-descent (car c))))) + accum)) + ((memq (car c) '(vcent vleft vright)) + (let ((accum (- (nth 1 c)))) + (setq c (cdr c)) + (while (setq c (cdr c)) + (setq accum (+ accum (math-comp-height (car c))))) + (max (1- accum) 0))) + ((eq (car c) 'supscr) + (math-comp-descent (nth 1 c))) + ((eq (car c) 'subscr) + (+ (math-comp-descent (nth 1 c)) (math-comp-height (nth 2 c)))) + ((eq (car c) 'tag) + (math-comp-descent (nth 2 c))) + (t 0)) +) + +(defun calcFunc-cwidth (a &optional prec) + (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump)) + (math-comp-width (math-compose-expr a (or prec 0))) +) + +(defun calcFunc-cheight (a &optional prec) + (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump)) + (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace)) + (memq (length a) '(2 3)) + (eq (nth 1 a) 0)) + 0 + (math-comp-height (math-compose-expr a (or prec 0)))) +) + +(defun calcFunc-cascent (a &optional prec) + (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump)) + (if (and (memq (car a) '(calcFunc-cvspace calcFunc-ctspace calcFunc-cbspace)) + (memq (length a) '(2 3)) + (eq (nth 1 a) 0)) + 0 + (math-comp-ascent (math-compose-expr a (or prec 0)))) +) + +(defun calcFunc-cdescent (a &optional prec) + (if (and prec (not (integerp prec))) (math-reject-arg prec 'fixnump)) + (math-comp-descent (math-compose-expr a (or prec 0))) +) + + +;;; Convert a simplified composition into string form. + +(defun math-vert-comp-to-string (c) + (if (stringp c) + c + (math-vert-comp-to-string-step (cdr (cdr c)))) +) + +(defun math-vert-comp-to-string-step (c) + (if (cdr c) + (concat (car c) "\n" (math-vert-comp-to-string-step (cdr c))) + (car c)) +) + + +;;; Convert a composition to a string in "raw" form (for debugging). + +(defun math-comp-to-string-raw (c indent) + (cond ((or (not (consp c)) (eq (car c) 'set)) + (prin1-to-string c)) + ((null (cdr c)) + (concat "(" (symbol-name (car c)) ")")) + (t + (let ((next-indent (+ indent 2 (length (symbol-name (car c)))))) + (concat "(" + (symbol-name (car c)) + " " + (math-comp-to-string-raw (nth 1 c) next-indent) + (math-comp-to-string-raw-step (cdr (cdr c)) + next-indent) + ")")))) +) + +(defun math-comp-to-string-raw-step (cl indent) + (if cl + (concat "\n" + (make-string indent 32) + (math-comp-to-string-raw (car cl) indent) + (math-comp-to-string-raw-step (cdr cl) indent)) + "") +) + + + + diff --git a/lisp/calc/calcsel2.el b/lisp/calc/calcsel2.el new file mode 100644 index 0000000000..d1e92ab680 --- /dev/null +++ b/lisp/calc/calcsel2.el @@ -0,0 +1,303 @@ +;; Calculator for GNU Emacs, part II [calc-sel-2.el] +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + + + +;; This file is autoloaded from calc-ext.el. +(require 'calc-ext) + +(require 'calc-macs) + +(defun calc-Need-calc-sel-2 () nil) + + +(defun calc-commute-left (arg) + (interactive "p") + (if (< arg 0) + (calc-commute-right (- arg)) + (calc-wrapper + (calc-preserve-point) + (let ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection)) + (if (= arg 0) (setq arg nil)) + (while (or (null arg) (>= (setq arg (1- arg)) 0)) + (let* ((entry (calc-top num 'entry)) + (expr (car entry)) + (sel (calc-auto-selection entry)) + parent new) + (or (and sel + (consp (setq parent (calc-find-assoc-parent-formula + expr sel)))) + (error "No term is selected")) + (if (and calc-assoc-selections + (assq (car parent) calc-assoc-ops)) + (let ((outer (calc-find-parent-formula parent sel))) + (if (eq sel (nth 2 outer)) + (setq new (calc-replace-sub-formula + parent outer + (cond + ((memq (car outer) + (nth 1 (assq (car-safe (nth 1 outer)) + calc-assoc-ops))) + (let* ((other (nth 2 (nth 1 outer))) + (new (calc-build-assoc-term + (car (nth 1 outer)) + (calc-build-assoc-term + (car outer) + (nth 1 (nth 1 outer)) + sel) + other))) + (setq sel (nth 2 (nth 1 new))) + new)) + ((eq (car outer) '-) + (calc-build-assoc-term + '+ + (setq sel (math-neg sel)) + (nth 1 outer))) + ((eq (car outer) '/) + (calc-build-assoc-term + '* + (setq sel (calcFunc-div 1 sel)) + (nth 1 outer))) + (t (calc-build-assoc-term + (car outer) sel (nth 1 outer)))))) + (let ((next (calc-find-parent-formula parent outer))) + (if (not (and (consp next) + (eq outer (nth 2 next)) + (eq (car next) (car outer)))) + (setq new nil) + (setq new (calc-build-assoc-term + (car next) + sel + (calc-build-assoc-term + (car next) (nth 1 next) (nth 2 outer))) + sel (nth 1 new) + new (calc-replace-sub-formula + parent next new)))))) + (if (eq (nth 1 parent) sel) + (setq new nil) + (let ((p (nthcdr (1- (calc-find-sub-formula parent sel)) + (setq new (copy-sequence parent))))) + (setcar (cdr p) (car p)) + (setcar p sel)))) + (if (null new) + (if arg + (error "Term is already leftmost") + (or reselect + (calc-pop-push-list 1 (list expr) num '(nil))) + (setq arg 0)) + (calc-pop-push-record-list + 1 "left" + (list (calc-replace-sub-formula expr parent new)) + num + (list (and (or (not (eq arg 0)) reselect) + sel))))))))) +) + +(defun calc-commute-right (arg) + (interactive "p") + (if (< arg 0) + (calc-commute-left (- arg)) + (calc-wrapper + (calc-preserve-point) + (let ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection)) + (if (= arg 0) (setq arg nil)) + (while (or (null arg) (>= (setq arg (1- arg)) 0)) + (let* ((entry (calc-top num 'entry)) + (expr (car entry)) + (sel (calc-auto-selection entry)) + parent new) + (or (and sel + (consp (setq parent (calc-find-assoc-parent-formula + expr sel)))) + (error "No term is selected")) + (if (and calc-assoc-selections + (assq (car parent) calc-assoc-ops)) + (let ((outer (calc-find-parent-formula parent sel))) + (if (eq sel (nth 1 outer)) + (setq new (calc-replace-sub-formula + parent outer + (if (memq (car outer) + (nth 2 (assq (car-safe (nth 2 outer)) + calc-assoc-ops))) + (let ((other (nth 1 (nth 2 outer)))) + (calc-build-assoc-term + (car outer) + other + (calc-build-assoc-term + (car (nth 2 outer)) + sel + (nth 2 (nth 2 outer))))) + (let ((new (cond + ((eq (car outer) '-) + (calc-build-assoc-term + '+ + (math-neg (nth 2 outer)) + sel)) + ((eq (car outer) '/) + (calc-build-assoc-term + '* + (calcFunc-div 1 (nth 2 outer)) + sel)) + (t (calc-build-assoc-term + (car outer) + (nth 2 outer) + sel))))) + (setq sel (nth 2 new)) + new)))) + (let ((next (calc-find-parent-formula parent outer))) + (if (not (and (consp next) + (eq outer (nth 1 next)))) + (setq new nil) + (setq new (calc-build-assoc-term + (car outer) + (calc-build-assoc-term + (car next) (nth 1 outer) (nth 2 next)) + sel) + sel (nth 2 new) + new (calc-replace-sub-formula + parent next new)))))) + (if (eq (nth (1- (length parent)) parent) sel) + (setq new nil) + (let ((p (nthcdr (calc-find-sub-formula parent sel) + (setq new (copy-sequence parent))))) + (setcar p (nth 1 p)) + (setcar (cdr p) sel)))) + (if (null new) + (if arg + (error "Term is already rightmost") + (or reselect + (calc-pop-push-list 1 (list expr) num '(nil))) + (setq arg 0)) + (calc-pop-push-record-list + 1 "rght" + (list (calc-replace-sub-formula expr parent new)) + num + (list (and (or (not (eq arg 0)) reselect) + sel))))))))) +) + +(defun calc-build-assoc-term (op lhs rhs) + (cond ((and (eq op '+) (or (math-looks-negp rhs) + (and (eq (car-safe rhs) 'cplx) + (math-negp (nth 1 rhs)) + (eq (nth 2 rhs) 0)))) + (list '- lhs (math-neg rhs))) + ((and (eq op '-) (or (math-looks-negp rhs) + (and (eq (car-safe rhs) 'cplx) + (math-negp (nth 1 rhs)) + (eq (nth 2 rhs) 0)))) + (list '+ lhs (math-neg rhs))) + ((and (eq op '*) (and (eq (car-safe rhs) '/) + (or (math-equal-int (nth 1 rhs) 1) + (equal (nth 1 rhs) '(cplx 1 0))))) + (list '/ lhs (nth 2 rhs))) + ((and (eq op '/) (and (eq (car-safe rhs) '/) + (or (math-equal-int (nth 1 rhs) 1) + (equal (nth 1 rhs) '(cplx 1 0))))) + (list '/ lhs (nth 2 rhs))) + (t (list op lhs rhs))) +) + +(defun calc-sel-unpack () + (interactive) + (calc-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (expr (car entry)) + (sel (or (calc-auto-selection entry) expr))) + (or (and (not (math-primp sel)) + (= (length sel) 2)) + (error "Selection must be a function of one argument")) + (calc-pop-push-record-list 1 "unpk" + (list (calc-replace-sub-formula + expr sel (nth 1 sel))) + num + (list (and reselect (nth 1 sel)))))) +) + +(defun calc-sel-isolate () + (interactive) + (calc-slow-wrapper + (calc-preserve-point) + (let* ((num (max 1 (calc-locate-cursor-element (point)))) + (reselect calc-keep-selection) + (entry (calc-top num 'entry)) + (expr (car entry)) + (sel (or (calc-auto-selection entry) (error "No selection"))) + (eqn sel) + soln) + (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn))) + (error "Selection must be a member of an equation")) + (not (assq (car eqn) calc-tweak-eqn-table)))) + (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag)) + (or soln + (error "No solution found")) + (setq soln (calc-encase-atoms + (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel)) + (eq (nth 1 soln) sel)) + soln + (list (nth 1 (assq (car soln) calc-tweak-eqn-table)) + (nth 2 soln) + (nth 1 soln))))) + (calc-pop-push-record-list 1 "isol" + (list (calc-replace-sub-formula + expr eqn soln)) + num + (list (and reselect sel))) + (calc-handle-whys))) +) + +(defun calc-sel-commute (many) + (interactive "P") + (let ((calc-assoc-selections nil)) + (calc-rewrite-selection "CommuteRules" many "cmut")) + (calc-set-mode-line) +) + +(defun calc-sel-jump-equals (many) + (interactive "P") + (calc-rewrite-selection "JumpRules" many "jump") +) + +(defun calc-sel-distribute (many) + (interactive "P") + (calc-rewrite-selection "DistribRules" many "dist") +) + +(defun calc-sel-merge (many) + (interactive "P") + (calc-rewrite-selection "MergeRules" many "merg") +) + +(defun calc-sel-negate (many) + (interactive "P") + (calc-rewrite-selection "NegateRules" many "jneg") +) + +(defun calc-sel-invert (many) + (interactive "P") + (calc-rewrite-selection "InvertRules" many "jinv") +) + diff --git a/lisp/calc/macedit.el b/lisp/calc/macedit.el new file mode 100644 index 0000000000..33465d4d85 --- /dev/null +++ b/lisp/calc/macedit.el @@ -0,0 +1,716 @@ +;; Keyboard macro editor for GNU Emacs. Version 1.05. +;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc. +;; Written by Dave Gillespie, [email protected]. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +;; Installation: +;; (autoload 'edit-kbd-macro "macedit" "Edit a named keyboard macro" t) +;; (autoload 'edit-last-kbd-macro "macedit" "Edit a keyboard macro" t) +;; (autoload 'read-kbd-macro "macedit" "Parse region as keyboard macro" t) + + + +;; To use, type `M-x edit-last-kbd-macro' to edit the most recently +;; defined keyboard macro. If you have used `M-x name-last-kbd-macro' +;; to give a keyboard macro a name, type `M-x edit-kbd-macro' to edit +;; the macro by name. When you are done editing, type `C-c C-c' to +;; record your changes back into the original keyboard macro. + + + + +;;; The user-level commands for editing macros. + +;;;###autoload +(defun edit-last-kbd-macro (&optional prefix buffer hook) + "Edit the most recently defined keyboard macro." + (interactive "P") + (MacEdit-edit-macro last-kbd-macro + (function (lambda (x arg) (setq last-kbd-macro x))) + prefix buffer hook) +) + +;;;###autoload +(defun edit-kbd-macro (cmd &optional prefix buffer hook in-hook out-hook) + "Edit a keyboard macro which has been assigned a name by name-last-kbd-macro. +\(See also edit-last-kbd-macro.)" + (interactive "CCommand name: \nP") + (and cmd + (MacEdit-edit-macro (if in-hook + (funcall in-hook cmd) + (symbol-function cmd)) + (or out-hook + (list 'lambda '(x arg) + (list 'fset + (list 'quote cmd) + 'x))) + prefix buffer hook cmd)) +) + +;;;###autoload +(defun read-kbd-macro (start &optional end) + "Read the region as a keyboard macro definition. +The region is interpreted as spelled-out keystrokes, e.g., `M-x abc RET'. +The resulting macro is installed as the \"current\" keyboard macro. + +Symbols: RET, SPC, TAB, DEL, LFD, NUL; C-key; M-key. (Must be uppercase.) + REM marks the rest of a line as a comment. + Whitespace is ignored; other characters are copied into the macro." + (interactive "r") + (if (stringp start) + (setq last-kbd-macro (MacEdit-parse-keys start)) + (setq last-kbd-macro (MacEdit-parse-keys (buffer-substring start end))) + (if (and (string-match "\\`\C-x(" last-kbd-macro) + (string-match "\C-x)\\'" last-kbd-macro)) + (setq last-kbd-macro (substring last-kbd-macro 2 -2)))) +) + + + + +;;; Formatting a keyboard macro as human-readable text. + +(defun MacEdit-print-macro (macro-str local-map) + (let ((save-map (current-local-map)) + (print-escape-newlines t) + key-symbol key-str key-last prefix-arg this-prefix) + (unwind-protect + (progn + (use-local-map local-map) + (while (MacEdit-peek-char) + (MacEdit-read-key) + (setq this-prefix prefix-arg) + (or (memq key-symbol '(digit-argument + negative-argument + universal-argument)) + (null prefix-arg) + (progn + (cond ((consp prefix-arg) + (insert (format "prefix-arg (%d)\n" + (car prefix-arg)))) + ((eq prefix-arg '-) + (insert "prefix-arg -\n")) + ((numberp prefix-arg) + (insert (format "prefix-arg %d\n" prefix-arg)))) + (setq prefix-arg nil))) + (cond ((null key-symbol) + (insert "type \"") + (MacEdit-insert-string macro-str) + (insert "\"\n") + (setq macro-str "")) + ((stringp key-symbol) ; key defined by another kbd macro + (insert "type \"") + (MacEdit-insert-string key-symbol) + (insert "\"\n")) + ((eq key-symbol 'digit-argument) + (MacEdit-prefix-arg key-last nil prefix-arg)) + ((eq key-symbol 'negative-argument) + (MacEdit-prefix-arg ?- nil prefix-arg)) + ((eq key-symbol 'universal-argument) + (let* ((c-u 4) (argstartchar key-last) + (char (MacEdit-read-char))) + (while (= char argstartchar) + (setq c-u (* 4 c-u) + char (MacEdit-read-char))) + (MacEdit-prefix-arg char c-u nil))) + ((eq key-symbol 'self-insert-command) + (insert "insert ") + (if (and (>= key-last 32) (<= key-last 126)) + (let ((str "")) + (while (or (and (eq key-symbol + 'self-insert-command) + (< (length str) 60) + (>= key-last 32) + (<= key-last 126)) + (and (memq key-symbol + '(backward-delete-char + delete-backward-char + backward-delete-char-untabify)) + (> (length str) 0))) + (if (eq key-symbol 'self-insert-command) + (setq str (concat str + (char-to-string key-last))) + (setq str (substring str 0 -1))) + (MacEdit-read-key)) + (insert "\"" str "\"\n") + (MacEdit-unread-chars key-str)) + (insert "\"") + (MacEdit-insert-string (char-to-string key-last)) + (insert "\"\n"))) + ((and (eq key-symbol 'quoted-insert) + (MacEdit-peek-char)) + (insert "quoted-insert\n") + (let ((ch (MacEdit-read-char)) + ch2) + (if (and (>= ch ?0) (<= ch ?7)) + (progn + (setq ch (- ch ?0) + ch2 (MacEdit-read-char)) + (if ch2 + (if (and (>= ch2 ?0) (<= ch2 ?7)) + (progn + (setq ch (+ (* ch 8) (- ch2 ?0)) + ch2 (MacEdit-read-char)) + (if ch2 + (if (and (>= ch2 ?0) (<= ch2 ?7)) + (setq ch (+ (* ch 8) (- ch2 ?0))) + (MacEdit-unread-chars ch2)))) + (MacEdit-unread-chars ch2))))) + (if (or (and (>= ch ?0) (<= ch ?7)) + (< ch 32) (> ch 126)) + (insert (format "type \"\\%03o\"\n" ch)) + (insert "type \"" (char-to-string ch) "\"\n")))) + ((memq key-symbol '(isearch-forward + isearch-backward + isearch-forward-regexp + isearch-backward-regexp)) + (insert (symbol-name key-symbol) "\n") + (MacEdit-isearch-argument)) + ((eq key-symbol 'execute-extended-command) + (MacEdit-read-argument obarray 'commandp)) + (t + (let ((cust (get key-symbol 'MacEdit-print))) + (if cust + (funcall cust) + (insert (symbol-name key-symbol)) + (indent-to 30) + (insert " # ") + (MacEdit-insert-string key-str) + (insert "\n") + (let ((int (MacEdit-get-interactive key-symbol))) + (if (string-match "\\`\\*" int) + (setq int (substring int 1))) + (while (> (length int) 0) + (cond ((= (aref int 0) ?a) + (MacEdit-read-argument + obarray nil)) + ((memq (aref int 0) '(?b ?B ?D ?f ?F ?n + ?s ?S ?x ?X)) + (MacEdit-read-argument)) + ((and (= (aref int 0) ?c) + (MacEdit-peek-char)) + (insert "type \"") + (MacEdit-insert-string + (char-to-string + (MacEdit-read-char))) + (insert "\"\n")) + ((= (aref int 0) ?C) + (MacEdit-read-argument + obarray 'commandp)) + ((= (aref int 0) ?k) + (MacEdit-read-key) + (if key-symbol + (progn + (insert "type \"") + (MacEdit-insert-string key-str) + (insert "\"\n")) + (MacEdit-unread-chars key-str))) + ((= (aref int 0) ?N) + (or this-prefix + (MacEdit-read-argument))) + ((= (aref int 0) ?v) + (MacEdit-read-argument + obarray 'user-variable-p))) + (let ((nl (string-match "\n" int))) + (setq int (if nl + (substring int (1+ nl)) + ""))))))))))) + (use-local-map save-map))) +) + +(defun MacEdit-prefix-arg (char c-u value) + (let ((sign 1)) + (if (and (numberp value) (< value 0)) + (setq sign -1 value (- value))) + (if (eq value '-) + (setq sign -1 value nil)) + (while (and char (= ?- char)) + (setq sign (- sign) c-u nil) + (setq char (MacEdit-read-char))) + (while (and char (>= char ?0) (<= char ?9)) + (setq value (+ (* (if (numberp value) value 0) 10) (- char ?0)) c-u nil) + (setq char (MacEdit-read-char))) + (setq prefix-arg + (cond (c-u (list c-u)) + ((numberp value) (* value sign)) + ((= sign -1) '-))) + (MacEdit-unread-chars char)) +) + +(defun MacEdit-insert-string (str) + (let ((i 0) j ch) + (while (< i (length str)) + (if (and (> (setq ch (aref str i)) 127) + (< ch 160)) + (progn + (setq ch (- ch 128)) + (insert "\\M-"))) + (if (< ch 32) + (cond ((= ch 8) (insert "\\b")) + ((= ch 9) (insert "\\t")) + ((= ch 10) (insert "\\n")) + ((= ch 13) (insert "\\r")) + ((= ch 27) (insert "\\e")) + (t (insert "\\C-" (char-to-string (downcase (+ ch 64)))))) + (if (< ch 127) + (if (or (= ch 34) (= ch 92)) + (insert "\\" (char-to-string ch)) + (setq j i) + (while (and (< (setq i (1+ i)) (length str)) + (>= (setq ch (aref str i)) 32) + (/= ch 34) (/= ch 92) + (< ch 127))) + (insert (substring str j i)) + (setq i (1- i))) + (if (memq ch '(127 255)) + (insert (format "\\%03o" ch)) + (insert "\\M-" (char-to-string (- ch 128)))))) + (setq i (1+ i)))) +) + +(defun MacEdit-lookup-key (map) + (let ((loc (and map (lookup-key map macro-str))) + (glob (lookup-key (current-global-map) macro-str)) + (loc-str macro-str) + (glob-str macro-str)) + (and (integerp loc) + (setq loc-str (substring macro-str 0 loc) + loc (lookup-key map loc-str))) + (and (consp loc) + (setq loc nil)) + (or loc + (setq loc-str "")) + (and (integerp glob) + (setq glob-str (substring macro-str 0 glob) + glob (lookup-key (current-global-map) glob-str))) + (and (consp glob) + (setq glob nil)) + (or glob + (setq glob-str "")) + (if (> (length glob-str) (length loc-str)) + (setq key-symbol glob + key-str glob-str) + (setq key-symbol loc + key-str loc-str)) + (setq key-last (and (> (length key-str) 0) + (logand (aref key-str (1- (length key-str))) 127))) + key-symbol) +) + +(defun MacEdit-read-argument (&optional obarray pred) ;; currently ignored + (let ((str "") + (min-bsp 0) + (exec (eq key-symbol 'execute-extended-command)) + str-base) + (while (progn + (MacEdit-lookup-key (current-global-map)) + (or (and (eq key-symbol 'self-insert-command) + (< (length str) 60)) + (memq key-symbol + '(backward-delete-char + delete-backward-char + backward-delete-char-untabify)) + (eq key-last 9))) + (setq macro-str (substring macro-str (length key-str))) + (or (and (eq key-last 9) + obarray + (let ((comp (try-completion str obarray pred))) + (and (stringp comp) + (> (length comp) (length str)) + (setq str comp)))) + (if (or (eq key-symbol 'self-insert-command) + (and (or (eq key-last 9) + (<= (length str) min-bsp)) + (setq min-bsp (+ (length str) (length key-str))))) + (setq str (concat str key-str)) + (setq str (substring str 0 -1))))) + (setq str-base str + str (concat str key-str) + macro-str (substring macro-str (length key-str))) + (if exec + (let ((comp (try-completion str-base obarray pred))) + (if (if (stringp comp) + (and (commandp (intern comp)) + (setq str-base comp)) + (commandp (intern str-base))) + (insert str-base "\n") + (insert "execute-extended-command\n") + (insert "type \"") + (MacEdit-insert-string str) + (insert "\"\n"))) + (if (> (length str) 0) + (progn + (insert "type \"") + (MacEdit-insert-string str) + (insert "\"\n"))))) +) + +(defun MacEdit-isearch-argument () + (let ((str "") + (min-bsp 0) + ch) + (while (and (setq ch (MacEdit-read-char)) + (or (<= ch 127) (not search-exit-option)) + (not (eq ch search-exit-char)) + (or (eq ch search-repeat-char) + (eq ch search-reverse-char) + (eq ch search-delete-char) + (eq ch search-yank-word-char) + (eq ch search-yank-line-char) + (eq ch search-quote-char) + (eq ch ?\r) + (eq ch ?\t) + (not search-exit-option) + (and (/= ch 127) (>= ch 32)))) + (if (and (eq ch search-quote-char) + (MacEdit-peek-char)) + (setq str (concat str (char-to-string ch) + (char-to-string (MacEdit-read-char))) + min-bsp (length str)) + (if (or (and (< ch 127) (>= ch 32)) + (eq ch search-yank-word-char) + (eq ch search-yank-line-char) + (and (or (not (eq ch search-delete-char)) + (<= (length str) min-bsp)) + (setq min-bsp (1+ (length str))))) + (setq str (concat str (char-to-string ch))) + (setq str (substring str 0 -1))))) + (if (eq ch search-exit-char) + (if (= (length str) 0) ;; non-incremental search + (progn + (setq str (concat str (char-to-string ch))) + (and (eq (MacEdit-peek-char) ?\C-w) + (progn + (setq str (concat str "\C-w")) + (MacEdit-read-char))) + (if (> (length str) 0) + (progn + (insert "type \"") + (MacEdit-insert-string str) + (insert "\"\n"))) + (MacEdit-read-argument) + (setq str ""))) + (MacEdit-unread-chars ch)) + (if (> (length str) 0) + (progn + (insert "type \"") + (MacEdit-insert-string str) + (insert "\\e\"\n")))) +) + +;;; Get the next keystroke-sequence from the input stream. +;;; Sets key-symbol, key-str, and key-last as a side effect. +(defun MacEdit-read-key () + (MacEdit-lookup-key (current-local-map)) + (and key-symbol + (setq macro-str (substring macro-str (length key-str)))) +) + +(defun MacEdit-peek-char () + (and (> (length macro-str) 0) + (aref macro-str 0)) +) + +(defun MacEdit-read-char () + (and (> (length macro-str) 0) + (prog1 + (aref macro-str 0) + (setq macro-str (substring macro-str 1)))) +) + +(defun MacEdit-unread-chars (chars) + (and (integerp chars) + (setq chars (char-to-string chars))) + (and chars + (setq macro-str (concat chars macro-str))) +) + +(defun MacEdit-dump (mac) + (set-mark-command nil) + (insert "\n\n") + (MacEdit-print-macro mac (current-local-map)) +) + + + +;;; Parse a string of spelled-out keystrokes, as produced by key-description. + +(defun MacEdit-parse-keys (str) + (let ((pos 0) + (mac "") + part) + (while (and (< pos (length str)) + (string-match "[^ \t\n]+" str pos)) + (setq pos (match-end 0) + part (substring str (match-beginning 0) (match-end 0)) + mac (concat mac + (if (and (> (length part) 2) + (= (aref part 1) ?-) + (= (aref part 0) ?M)) + (progn + (setq part (substring part 2)) + "\e") + (if (and (> (length part) 4) + (= (aref part 0) ?C) + (= (aref part 1) ?-) + (= (aref part 2) ?M) + (= (aref part 3) ?-)) + (progn + (setq part (concat "C-" (substring part 4))) + "\e") + "")) + (or (cdr (assoc part '( ( "NUL" . "\0" ) + ( "RET" . "\r" ) + ( "LFD" . "\n" ) + ( "TAB" . "\t" ) + ( "ESC" . "\e" ) + ( "SPC" . " " ) + ( "DEL" . "\177" ) + ( "C-?" . "\177" ) + ( "C-2" . "\0" ) + ( "C-SPC" . "\0") ))) + (and (equal part "REM") + (setq pos (or (string-match "\n" str pos) + (length str))) + "") + (and (= (length part) 3) + (= (aref part 0) ?C) + (= (aref part 1) ?-) + (char-to-string (logand (aref part 2) 31))) + part)))) + mac) +) + + + + +;;; Parse a keyboard macro description in MacEdit-print-macro's format. + +(defun MacEdit-read-macro (&optional map) + (or map (setq map (current-local-map))) + (let ((macro-str "")) + (while (not (progn + (skip-chars-forward " \t\n") + (eobp))) + (cond ((looking-at "#")) ;; comment + ((looking-at "prefix-arg[ \t]*-[ \t]*\n") + (MacEdit-append-chars "\C-u-")) + ((looking-at "prefix-arg[ \t]*\\(-?[0-9]+\\)[ \t]*\n") + (MacEdit-append-chars (concat "\C-u" (MacEdit-match-string 1)))) + ((looking-at "prefix-arg[ \t]*(\\([0-9]+\\))[ \t]*\n") + (let ((val (string-to-int (MacEdit-match-string 1)))) + (while (> val 1) + (or (= (% val 4) 0) + (error "Bad prefix argument value")) + (MacEdit-append-chars "\C-u") + (setq val (/ val 4))))) + ((looking-at "prefix-arg") + (error "Bad prefix argument syntax")) + ((looking-at "insert ") + (forward-char 7) + (MacEdit-append-chars (read (current-buffer))) + (if (< (current-column) 7) + (forward-line -1))) + ((looking-at "type ") + (forward-char 5) + (MacEdit-append-chars (read (current-buffer))) + (if (< (current-column) 5) + (forward-line -1))) + ((looking-at "keys \\(.*\\)\n") + (goto-char (1- (match-end 0))) + (MacEdit-append-chars (MacEdit-parse-keys + (buffer-substring (match-beginning 1) + (match-end 1))))) + ((looking-at "\\([-a-zA-z0-9_]+\\)[ \t]*\\(.*\\)\n") + (let* ((func (intern (MacEdit-match-string 1))) + (arg (MacEdit-match-string 2)) + (cust (get func 'MacEdit-read))) + (if cust + (funcall cust arg) + (or (commandp func) + (error "Not an Emacs command")) + (or (equal arg "") + (string-match "\\`#" arg) + (error "Unexpected argument to command")) + (let ((keys + (or (where-is-internal func map t) + (where-is-internal func (current-global-map) t)))) + (if keys + (MacEdit-append-chars keys) + (MacEdit-append-chars (concat "\ex" + (symbol-name func) + "\n"))))))) + (t (error "Syntax error"))) + (forward-line 1)) + macro-str) +) + +(defun MacEdit-append-chars (chars) + (setq macro-str (concat macro-str chars)) +) + +(defun MacEdit-match-string (n) + (if (match-beginning n) + (buffer-substring (match-beginning n) (match-end n)) + "") +) + + + +(defun MacEdit-get-interactive (func) + (if (symbolp func) + (let ((cust (get func 'MacEdit-interactive))) + (if cust + cust + (MacEdit-get-interactive (symbol-function func)))) + (or (and (eq (car-safe func) 'lambda) + (let ((int (if (consp (nth 2 func)) + (nth 2 func) + (nth 3 func)))) + (and (eq (car-safe int) 'interactive) + (stringp (nth 1 int)) + (nth 1 int)))) + "")) +) + +(put 'search-forward 'MacEdit-interactive "s") +(put 'search-backward 'MacEdit-interactive "s") +(put 'word-search-forward 'MacEdit-interactive "s") +(put 'word-search-backward 'MacEdit-interactive "s") +(put 're-search-forward 'MacEdit-interactive "s") +(put 're-search-backward 'MacEdit-interactive "s") +(put 'switch-to-buffer 'MacEdit-interactive "B") +(put 'kill-buffer 'MacEdit-interactive "B") +(put 'rename-buffer 'MacEdit-interactive "B\nB") +(put 'goto-char 'MacEdit-interactive "N") +(put 'global-set-key 'MacEdit-interactive "k\nC") +(put 'global-unset-key 'MacEdit-interactive "k") +(put 'local-set-key 'MacEdit-interactive "k\nC") +(put 'local-unset-key 'MacEdit-interactive "k") + +;;; Think about kbd-macro-query + + + +;;; Edit a keyboard macro in another buffer. +;;; (Prefix argument is currently ignored.) + +(defun MacEdit-edit-macro (mac repl &optional prefix buffer hook arg) + (or (stringp mac) + (error "Not a keyboard macro")) + (let ((oldbuf (current-buffer)) + (from-calc (and (get-buffer-window "*Calculator*") + (eq (lookup-key (current-global-map) "\e#") + 'calc-dispatch))) + (local (current-local-map)) + (buf (get-buffer-create (or buffer "*Edit Macro*")))) + (set-buffer buf) + (kill-all-local-variables) + (use-local-map MacEdit-mode-map) + (setq buffer-read-only nil) + (setq major-mode 'MacEdit-mode) + (setq mode-name "Edit Macro") + (make-local-variable 'MacEdit-original-buffer) + (setq MacEdit-original-buffer oldbuf) + (make-local-variable 'MacEdit-replace-function) + (setq MacEdit-replace-function repl) + (make-local-variable 'MacEdit-replace-argument) + (setq MacEdit-replace-argument arg) + (make-local-variable 'MacEdit-finish-hook) + (setq MacEdit-finish-hook hook) + (erase-buffer) + (insert "# Keyboard Macro Editor. Press " + (if from-calc "M-# M-#" "C-c C-c") + " to finish; press " + (if from-calc "M-# x" "C-x k RET") + " to cancel.\n") + (insert "# Original keys: " (key-description mac) "\n\n") + (message "Formatting keyboard macro...") + (MacEdit-print-macro mac local) + (switch-to-buffer buf) + (goto-char (point-min)) + (forward-line 3) + (recenter '(4)) + (set-buffer-modified-p nil) + (message "Formatting keyboard macro...done") + (run-hooks 'MacEdit-format-hook)) +) + +(defun MacEdit-finish-edit () + (interactive) + (or (and (boundp 'MacEdit-original-buffer) + (boundp 'MacEdit-replace-function) + (boundp 'MacEdit-replace-argument) + (boundp 'MacEdit-finish-hook) + (eq major-mode 'MacEdit-mode)) + (error "This command is valid only in buffers created by edit-kbd-macro.")) + (let ((buf (current-buffer)) + (str (buffer-string)) + (func MacEdit-replace-function) + (arg MacEdit-replace-argument) + (hook MacEdit-finish-hook)) + (goto-char (point-min)) + (and (buffer-modified-p) + func + (progn + (message "Compiling keyboard macro...") + (run-hooks 'MacEdit-compile-hook) + (let ((mac (MacEdit-read-macro + (and (buffer-name MacEdit-original-buffer) + (save-excursion + (set-buffer MacEdit-original-buffer) + (current-local-map)))))) + (and (buffer-name MacEdit-original-buffer) + (switch-to-buffer MacEdit-original-buffer)) + (funcall func mac arg)) + (message "Compiling keyboard macro...done"))) + (kill-buffer buf) + (if hook + (funcall hook arg))) +) + +(defun MacEdit-cancel-edit () + (interactive) + (if (eq major-mode 'MacEdit-mode) + (set-buffer-modified-p nil)) + (MacEdit-finish-edit) + (message "(Cancelled)") +) + +(defun MacEdit-mode () + "Keyboard Macro Editing mode. Press C-c C-c to save and exit. +To abort the edit, just kill this buffer with C-x k RET. + +The keyboard macro is represented as a series of M-x style command names. +Keystrokes which do not correspond to simple M-x commands are written as +\"type\" commands. When you press C-c C-c, MacEdit converts each command +back into a suitable keystroke sequence; \"type\" commands are converted +directly back into keystrokes." + (interactive) + (error "This mode can be enabled only by edit-kbd-macro or edit-last-kbd-macro.") +) +(put 'MacEdit-mode 'mode-class 'special) + +(defvar MacEdit-mode-map nil) +(if MacEdit-mode-map + () + (setq MacEdit-mode-map (make-sparse-keymap)) + (define-key MacEdit-mode-map "\C-c\C-c" 'MacEdit-finish-edit) +) + |