--- /dev/null
+
+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.)
--- /dev/null
+# Makefile for "Calc", the GNU Emacs Calculator.
+# Copyright (C) 1991, 1992, 1993 Free Software Foundation.
+# Author: Dave Gillespie.
+# Author's address: daveg@synaptics.com.
+
+# 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.*
+
+
--- /dev/null
+
+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
+ daveg@synaptics.com, 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
+"daveg@synaptics.com". 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.
+
+\f
+Version 2.02e:
+
+ * Fixed an installation bug caused by recent changes to `write-region'.
+
+\f
+Version 2.02d:
+
+ * Fixed a minor installation problem with a Emacs 19.29 byte-compiler bug.
+
+ * Removed archaic "macedit" package (superseded by "edmacro").
+
+\f
+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.
+
+\f
+Version 2.02b:
+
+ * Minor patch to port Calc to GNU Emacs 19. Will be superseded by Calc 3.00.
+
+\f
+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."
+
+\f
+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.
+
+\f
+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.
+
--- /dev/null
+
+
+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.
+
+\f
+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.
+
+\f
+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.
+
+\f
+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.
+
+\f
+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.
+
+\f
+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.
+
+\f
+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.
+
+\f
+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].
+
+\f
+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.
+
+\f
+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.
+
+\f
+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.
+
+\f
+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.
+
+\f
+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.
+
+\f
+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'.
+\f
+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.
+
+\f
+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.
+
--- /dev/null
+;; Calculator for GNU Emacs, part I [calc-aent.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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"))))
+)
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-alg.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-arith.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))))
+)
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-bin.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-comb.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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])
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-cplx.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))))
+)
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-embed.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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 ""))))
+)
+
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-fin.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))
+)
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-forms.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-frac.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-funcs.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-graph.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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")))))
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-help.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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, daveg@synaptics.com.\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)
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-incom.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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")))
+)
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-keypd.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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 ) ) )
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-lang.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)
+)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part I [calc-macs.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)))
+)
+
+
--- /dev/null
+;; Calculator for GNU Emacs, maintenance routines
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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.
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-map.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)))
+)
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-math.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part I [calc-misc.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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, daveg@synaptics.com"
+ 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))
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-mode.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)))
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-mat.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-poly.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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 (ewerlid@mizar.DoCS.UU.SE).
+;;; 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))
+)
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-prog.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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")))))
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-rewr.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))))))
+)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-rules.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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 ]")
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-sel.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-stat.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))))))))
+)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-store.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-stuff.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)))))
+)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-trail.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))
+)
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-undo.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))))
+)
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-units.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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 (ulm@vsnhd1.cern.ch)
+;;; with some additions by Przemek Klosowski (przemek@rrdstrad.nist.gov)
+
+(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*"))))
+)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-vec.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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
+)
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-yank.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)))))))))
+)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part I
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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, daveg@synaptics.com, uunet!synaptx!daveg.
+;;; Synaptics, Inc., 2698 Orchard Parkway, San Jose, CA 95134.
+;;;
+;;; The old address daveg@csvax.cs.caltech.edu 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 "daveg@synaptics.com")
+
+
+;; 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)
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-alg-2.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)))
+)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-alg-3.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))))
+)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-comp.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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))
+ "")
+)
+
+
+
+
--- /dev/null
+;; Calculator for GNU Emacs, part II [calc-sel-2.el]
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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")
+)
+
--- /dev/null
+;; Keyboard macro editor for GNU Emacs. Version 1.05.
+;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
+;; Written by Dave Gillespie, daveg@synaptics.com.
+
+;; 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)
+)
+
projects / emacs.git / commitdiff