procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial import of Calc 2.02f.

Browse source
This commit is contained in:
Eli Zaretskii 2001-11-06 18:59:06 +00:00
parent 0ffbbdeb44
commit 136211a997
47 changed files with 52458 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

413
lisp/calc/INSTALL Normal file
View file

@ -0,0 +1,413 @@
Installation
************
Calc 2.02 comes as a set of GNU Emacs Lisp files, with names like
`calc.el' and `calc-ext.el', and also as a `calc.texinfo' file which
can be used to generate both on-line and printed documentation.
To install Calc, just follow these simple steps. If you want more
information, each step is discussed at length in the sections below.
1. Change (`cd') to the Calc "home" directory. This directory was
created when you unbundled the Calc `.tar' or `.shar' file.
2. Type `make' to install Calc privately for your own use, or type
`make install' to install Calc system-wide. This will compile all
the Calc component files, modify your `.emacs' or the system-wide
`lisp/default' file to install Calc as appropriate, and format
the on-line Calc manual.
Both variants are shorthand for the following three steps:
* `make compile' to run the byte-compiler.
* `make private' or `make public', corresponding to `make' and
`make install', respectively. (If `make public' fails
because your system doesn't already have a `default' or
`default.el' file, use Emacs or the Unix `touch' command to
create a zero-sized one first.)
* `make info' to format the on-line Calc manual. This first
tries to use the `makeinfo' program; if that program is not
present, it uses the Emacs `texinfo-format-buffer' command
instead.
The Unix `make' utility looks in the file `Makefile' in the
current directory to see what Unix commands correspond to the
various "targets" like `install' or `public'. If your system
doesn't have `make', you will have to examine the `Makefile' and
type in the corresponding commands by hand.
3. If you ever move Calc to a new home directory, just give the
`make private' or `make public' command again in the new
directory.
4. Test your installation as described at the end of these
instructions.
5. (Optional.) To print a hardcopy of the Calc manual (over 500
pages) or just the Calc Summary (about 20 pages), follow the
instructions under "Printed Documentation" below.
Calc is now installed and ready to go!
Upgrading from Calc 1.07
=========================
If you have Calc version 1.07 or earlier, you will find that Calc 2.00
is organized quite differently. For one, Calc 2.00 is now distributed
already split into many parts; formerly this was done as part of the
installation procedure. Also, some new functions must be autoloaded
and the `M-#' key must be bound to `calc-dispatch' instead of to
`calc'.
The easiest way to upgrade is to delete your old Calc files and then
install Calc 2.00 from scratch using the above instructions. You
should then go into your `.emacs' or `default' file and remove the old
`autoload' and `global-set-key' commands for Calc, since `make
public'/`make private' has added new, better ones.
See the `README' and `README.prev' files in the Calc distribution
for more information about what has changed since version 1.07.
(`README.prev' describes changes before 2.00, and is present only in
the FTP and tape versions of the distribution.)
The `make public' Command
==========================
If you are not the regular Emacs administrator on your system, your
account may not be allowed to execute the `make public' command, since
the system-wide `default' file may be write-protected. If this is the
case, you will have to ask your Emacs installer to execute this
command. (Just `cd' to the Calc home directory and type `make
public'.)
The `make private' command adds exactly the same set of commands to
your `.emacs' file as `make public' adds to `default'. If your Emacs
installer is concerned about typing this command out of the blue, you
can ask her/him instead to copy the necessary text from your `.emacs'
file. (It will be marked by a comment that says "Commands added by
`calc-private-autoloads' on (date and time).")
Compilation
============
Calc is written in a way that maximizes performance when its code has
been byte-compiled; a side effect is that performance is seriously
degraded if it *isn't* compiled. Thus, it is essential to compile the
Calculator before trying to use it. The function `calc-compile' in
the file `calc-maint.el' runs the Emacs byte-compiler on all the Calc
source files. (Specifically, it runs `M-x byte-compile-file' on all
files in the current directory with names of the form `calc*.el', and
also on the file `macedit.el'.)
If `calc-compile' finds that certain files have already been
compiled and have not been changed since, then it will not bother to
recompile those files.
The `calc-compile' command also pre-builds certain tables, such as
the units table (see "The Units Table") and the built-in rewrite
rules (see "Rearranging with Selections") which Calc would otherwise
need to rebuild every time those features were used.
The `make compile' shell command is simply a convenient way to
start an Emacs and give it a `calc-compile' command.
Auto-loading
=============
To teach Emacs how to load in Calc when you type `M-#' for the first
time, add these lines to your `.emacs' file (if you are installing
Calc just for your own use), or the system's `lisp/default' file (if
you are installing Calc publicly). The `make private' and `make
public' commands, respectively, take care of this. (Note that `make'
runs `make private', and `make install' runs `make public'.)
(autoload 'calc-dispatch "calc" "Calculator Options" t)
(autoload 'full-calc "calc" "Full-screen Calculator" t)
(autoload 'full-calc-keypad "calc" "Full-screen X Calculator" t)
(autoload 'calc-eval "calc" "Use Calculator from Lisp")
(autoload 'defmath "calc" nil t t)
(autoload 'calc "calc" "Calculator Mode" t)
(autoload 'quick-calc "calc" "Quick Calculator" t)
(autoload 'calc-keypad "calc" "X windows Calculator" t)
(autoload 'calc-embedded "calc" "Use Calc from any buffer" t)
(autoload 'calc-embedded-activate "calc" "Activate =>'s in buffer" t)
(autoload 'calc-grab-region "calc" "Grab region of Calc data" t)
(autoload 'calc-grab-rectangle "calc" "Grab rectangle of data" t)
Unless you have installed the Calc files in Emacs' main `lisp/'
directory, you will also have to add a command that looks like the
following to tell Emacs where to find them. In this example, we have
put the files in directory `/usr/gnu/src/calc-2.00'.
(setq load-path (append load-path (list "/usr/gnu/src/calc-2.00")))
The `make public' and `make private' commands also do this (they use
the then-current directory as the name to add to the path). If you
move Calc to a new location, just repeat the `make public' or `make
private' command to have this new location added to the `load-path'.
The `autoload' command for `calc-dispatch' is what loads `calc.elc'
when you type `M-#'. It is the only `autoload' that is absolutely
necessary for Calc to work. The others are for commands and features
that you may wish to use before typing `M-#' for the first time. In
particular, `full-calc' and `full-calc-keypad' are autoloaded to
support "standalone" operation (see "Standalone Operation"),
`calc-eval' and `defmath' are autoloaded to allow other Emacs Lisp
programs to use Calc facilities (see "Calling Calc from Your
Programs"), and `calc-embedded-activate' is autoloaded because some
Embedded Mode files may call it as soon as they are read into Emacs
(see "Assignments in Embedded Mode").
Finding Component Files
========================
There is no need to write `autoload' commands that point to all the
various Calc component files like `calc-misc.elc' and `calc-alg.elc'.
The main file, `calc.elc', contains all the necessary `autoload'
commands for these files.
(Actually, to conserve space `calc.elc' only autoloads a few of the
component files, plus `calc-ext.elc', which in turn autoloads the rest
of the components. This allows Calc to load a little faster in the
beginning, but the net effect is the same.)
This autoloading mechanism assumes that all the component files can
be found on the `load-path'. The `make public' and `make private'
commands take care of this, but Calc has a few other strategies in
case you have installed it in an unusual way.
If, when Calc is loaded, it is unable to find its components on the
`load-path' it is given, it checks the file name in the original
`autoload' command for `calc-dispatch'. If that name included
directory information, Calc adds that directory to the `load-path':
(autoload 'calc-dispatch "calc-2.00/calc" "Calculator" t)
Suppose the directory `/usr/gnu/src/emacs/lisp' is on the path, and
the above `autoload' allows Emacs to find Calc under the name
`/usr/gnu/src/emacs/lisp/calc-2.00/calc.elc'. Then when Calc starts
up it will add `/usr/gnu/src/emacs/lisp/calc-2.00' to the path so that
it will later be able to find its component files.
If the above strategy does not locate the component files, Calc
examines the variable `calc-autoload-directory'. This is initially
`nil', but you can store the name of Calc's home directory in it as a
sure-fire way of getting Calc to find its components.
Merging Source Files
=====================
If the `autoload' mechanism is not managing to load each part of Calc
when it is needed, you can concatenate all the `.el' files into one
big file. The order should be `calc.el', then `calc-ext.el', then all
the other files in any order. Byte-compile the resulting big file.
This merged Calculator ought to work just like Calc normally does,
though it will be *substantially* slower to load.
Key Bindings
=============
Calc is normally bound to the `M-#' key. To set up this key binding,
include the following command in your `.emacs' or `lisp/default' file.
(This is done automatically by `make private' or `make public',
respectively.)
(global-set-key "\e#" 'calc-dispatch)
Note that `calc-dispatch' actually works as a prefix for various
two-key sequences. If you have a convenient unused function key on
your keyboard, you may wish to bind `calc-dispatch' to that as well.
You may even wish to bind other specific Calc functions like `calc' or
`quick-calc' to other handy function keys.
Even if you bind `calc-dispatch' to other keys, it is best to bind
it to `M-#' as well if you possibly can: There are references to
`M-#' all throughout the Calc manual which would confuse novice users
if they didn't work as advertised.
Another key binding issue is the DEL key. Some installations use a
different key (such as backspace) for this purpose. Calc normally
scans the entire keymap and maps all keys defined like DEL to the
`calc-pop' command. However, this may be slow. You can set the
variable `calc-scan-for-dels' to `nil' to cause only the actual DEL
key to be mapped to `calc-pop'; this will speed loading of Calc.
The `macedit' Package
======================
The file `macedit.el' contains another useful Emacs extension called
`edit-kbd-macro'. It allows you to edit a keyboard macro in
human-readable form. The `Z E' command in Calc knows how to use it to
edit user commands that have been defined by keyboard macros. To
autoload it, you will want to include the commands,
(autoload 'edit-kbd-macro "macedit" "Edit Keyboard Macro" t)
(autoload 'edit-last-kbd-macro "macedit" "Edit Keyboard Macro" t)
(autoload 'read-kbd-macro "macedit" "Read Keyboard Macro" t)
The `make public' and `make private' commands do this.
The GNUPLOT Program
====================
Calc's graphing commands use the GNUPLOT program. If you have GNUPLOT
but you must type some command other than `gnuplot' to get it, you
should add a command to set the Lisp variable `calc-gnuplot-name' to
the appropriate file name. You may also need to change the variables
`calc-gnuplot-plot-command' and `calc-gnuplot-print-command' in order
to get correct displays and hardcopies, respectively, of your plots.
On-Line Documentation
======================
The documentation for Calc (this manual) comes in a file called
`calc.texinfo'. To format this for use as an on-line manual, type
`make info' (to use the `makeinfo' program), or `make texinfo' (to use
the `texinfmt.el' program which runs inside of Emacs). The former
command is recommended if it works on your system; it is faster and
produces nicer-looking output.
The `makeinfo' program will report inconsistencies involving the
nodes "Copying" and "Interactive Tutorial"; these messages should be
ignored.
The result will be a collection of files whose names begin with
`calc.info'. You may wish to add a reference to the first of these,
`calc.info' itself, to your Info system's `dir' file. (This is
optional since the `M-# i' command can access `calc.info' whether or
not it appears in the `dir' file.)
There is a Lisp variable called `calc-info-filename' which holds
the name of the Info file containing Calc's on-line documentation.
Its default value is `"calc.info"', which will work correctly if the
Info files are stored in Emacs' main `info/' directory, or if they are
in any of the directories listed in the `load-path'. If you keep them
elsewhere, you will want to put a command of the form,
(setq calc-info-filename ".../calc.info")
in your `.emacs' or `lisp/default' file, where `...' represents the
directory containing the Info files. This will not be necessary if
you follow the normal installation procedures.
The `make info' and `make texinfo' commands compare the dates on
the files `calc.texinfo' and `calc.info', and run the appropriate
program only if the latter file is older or does not exist.
Printed Documentation
======================
Because the Calc manual is so large, you should only make a printed
copy if you really need it. To print the manual, you will need the
TeX typesetting program (this is a free program by Donald Knuth at
Stanford University) as well as the `texindex' program and
`texinfo.tex' file, both of which can be obtained from the FSF as part
of the `texinfo2' package.
To print the Calc manual in one huge 550 page tome, type `make tex'.
This will take care of running the manual through TeX twice so that
references to later parts of the manual will have correct page numbers.
(Don't worry if you get some "overfull box" warnings.)
The result will be a device-independent output file called
`calc.dvi', which you must print in whatever way is right for your
system. On many systems, the command is
lpr -d calc.dvi
Marginal notes for each function and key sequence normally alternate
between the left and right sides of the page, which is correct if the
manual is going to be bound as double-sided pages. Near the top of
the file `calc.texinfo' you will find alternate definitions of the
`\bumpoddpages' macro that put the marginal notes always on the same
side, best if you plan to be binding single-sided pages.
Some people find the Calc manual to be too large to handle easily.
In fact, some versions of TeX have too little memory to print it. So
Calc includes a `calc-split-manual' command that splits `calc.texinfo'
into two volumes, the Calc Tutorial and the Calc Reference. The
easiest way to use it is to type `make tex2' instead of `make tex'.
The result will be two smaller files, `calctut.dvi' and `calcref.dvi'.
The former contains the tutorial part of the manual; the latter
contains the reference part. Both volumes include copies of the
"Getting Started" chapter and licensing information.
To save disk space, you may wish to delete `calctut.*' and
`calcref.*' after you're done. Don't delete `calc.texinfo', because
you will need it to install future patches to Calc. The `make tex2'
command takes care of all of this for you.
The `make textut' command formats only the Calc Tutorial volume,
producing `calctut.dvi' but not `calcref.dvi'. Likewise, `make
texref' formats only the Calc Reference volume.
Finally, there is a `calc-split-summary' command that splits off
just the Calc Summary appendix suitable for printing by itself. Type
`make summary' instead of `make tex'. The resulting `calcsum.dvi'
file will print in less than 20 pages. If the Key Index file
`calc.ky' is present, left over from a previous `make tex' command,
then `make summary' will insert a column of page numbers into the
summary using that information.
The `make isummary' command is like `make summary', but it prints a
summary that is designed to be substituted into the regular manual.
(The two summaries will be identical except for the additional column
of page numbers.) To make a complete manual, run `make tex' and `make
isummary', print the two resulting `.dvi' files, then discard the
Summary pages that came from `calc.dvi' and insert the ones from
`calcsum.dvi' in their place. Also, remember that the table of
contents prints at the end of the manual but should generally be moved
to the front (after the title and copyright pages).
If you don't have TeX, you can print the summary as a plain text
file by going to the "Summary" node in Calc's Info file, then typing
`M-x print-buffer' (see "Summary").
Settings File
==============
Another variable you might want to set is `calc-settings-file', which
holds the file name in which commands like `m m' and `Z P' store
"permanent" definitions. The default value for this variable is
`"~/.emacs"'. If `calc-settings-file' does not contain `".emacs"' as
a substring, and if the variable `calc-loaded-settings-file' is `nil',
then Calc will automatically load your settings file (if it exists)
the first time Calc is invoked.
Testing the Installation
=========================
To test your installation of Calc, start a new Emacs and type `M-# c'
to make sure the autoloads and key bindings work. Type `M-# i' to
make sure Calc can find its Info documentation. Press `q' to exit the
Info system and `M-# c' to re-enter the Calculator. Type `20 S' to
compute the sine of 20 degrees; this will test the autoloading of the
extensions modules. The result should be 0.342020143326. Finally,
press `M-# c' again to make sure the Calculator can exit.
You may also wish to test the GNUPLOT interface; to plot a sine
wave, type `' [0 .. 360], sin(x) RET g f'. Type `g q' when you are
done viewing the plot.
Calc is now ready to use. If you wish to go through the Calc
Tutorial, press `M-# t' to begin.
(The above text is included in both the Calc documentation and the
file INSTALL in the Calc distribution directory.)

186
lisp/calc/Makefile Normal file
View file

@ -0,0 +1,186 @@
# Makefile for "Calc", the GNU Emacs Calculator.
# Copyright (C) 1991, 1992, 1993 Free Software Foundation.
# Author: Dave Gillespie.
# Author's address: 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.*

235
lisp/calc/README Normal file
View file

@ -0,0 +1,235 @@
This directory contains version 2.02c of Calc, an advanced desk
calculator for GNU Emacs.
"Calc" Copyright 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
Written and maintained by: Dave Gillespie
c/o Synaptics, Inc.
2698 Orchard Parkway
San Jose CA 95134
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.
Version 2.02e:
* Fixed an installation bug caused by recent changes to `write-region'.
Version 2.02d:
* Fixed a minor installation problem with a Emacs 19.29 byte-compiler bug.
* Removed archaic "macedit" package (superseded by "edmacro").
Version 2.02c:
* Patch to port Calc to Lucid Emacs 19; still works with GNU 18 and GNU 19.
* Fixed a bug that broke `C-x C-c' after Calc graphics had been used.
Version 2.02b:
* Minor patch to port Calc to GNU Emacs 19. Will be superseded by Calc 3.00.
Version 2.02:
* Revamped the manual a bit; rearranged some sections.
* Added marginal notes for Key/Function Index refs in printed manual.
* Changed `M-# r' to deal more gracefully with blank lines.
* Made reductions like `V R +' and `M-# :' considerably faster.
* Improved parsing and display of cases like "[a + b]".
* Added `t +' and `t -' for doing business date arithmetic.
* Added "syntax tables," the opposite of compositions.
* Added another Rewrites Tutorial exercise.
* Added the "vmatches" function.
* Added the `Modes' variable and `m g' command.
* Improved `u s' to cancel, e.g., "11 mph hr / yd" to get a number.
* Added "quick units" commands "u 0" through "u 9".
* Moved `M-%' to calc.el to avoid autoloading problems.
* Added `M-=' during algebraic entry, acts like `RET ='.
* Made `LFD' prevent evaluation when finishing a calc-edit command.
* Changed calc-store commands to use `t .' mode for trail display.
* Improved integrator to understand forms involving "erf".
* Fixed parser to make sense of "[1....1e2]" input.
* Fixed FORTRAN parser to treat a(i,j) as a_i_j if a is declared matrix.
* Got rid of some version number stamps to reduce size of patches.
* Fixed a bug in defmath treating "<=" and ">=" predicates.
* Fixed a bug in which Calc crashed multiplying two date forms.
* Fixed a bug in line breaker that crashed for large, nested formulas.
* Fixed a bug using ` to edit string("foo").
* Fixed a bug where `M-# y' in Big mode copied stack level number.
* Fixed a bug where `g O' used wrong default directory, no completion.
* Fixed a bug where "foo_bar(i)" parsed in C mode but showed as foo#bar.
* Fixed several bugs where large calculations got "computation too long."
Version 2.01:
* Added percentage commands `M-%', `b %', and `c %'.
* Changed Big mode to force radix-10 in superscripts.
* Improved display of fractions in various language modes.
* Changed `a n' to work properly with equations and inequalities.
* The problem with cross references to Index nodes in TeX has been fixed.
* Fixed a bug where recursive esc-maps make calc-ext/-aent unloadable.
* Fixed a bug in `M-# k', then `OFF' right away, with fresh Emacs.
* Fixed a bug in which "S_i_j" was formatted wrong after `j s'.
* Fixed a bug in which `h k u c' positioned cursor on wrong line.
* Fixed a bug where `z ?' crashed if `z %' was defined.
* Fixed a bug in `j O' (calc-select-once-maybe).
* Fixed "make private" not to ask "Delete excess versions" and crash.
Version 2.00:
* First complete posting of Calc since 1.01.
* Most parts of Calc have seen changes since version 1.07. See
section "New for Calc 2.00" in the manual for a summary. In
the FTP version of the Calc distribution, the file README.prev
contains a detailed change history from 1.00 up to 2.00.

981
lisp/calc/README.prev Normal file
View file

@ -0,0 +1,981 @@
Summary of changes to "Calc" Preceding 2.00
------- -- ------- -- ---- --------- ----
Version 2.00:
* Changed to compile calc-macs/-maint, to allow "cp *.elc new-dir".
* Improved calc-describe-bindings to avoid showing redundant ESC maps.
Version 2.00 beta 3:
* Removed version numbers from most .el files to reduce size of patches.
* Added a "calc-version" command.
* Changed `M-# ? ?' to allow for modified describe-function.
* Changed date parser to accept "Sept" as an alternative for "Sep".
* Inhibited answers to exercise from showing up in table of contents.
* Changed Makefile to say "texindex calc.[cfkptv]?" to avoid "calc.el".
* Fixed up the Makefile in various other ways.
* Rearranged banner at top of `h h' command's output.
* Changed "make summary" to print "Calc Summary" on the title page.
* Added "IntegSimpRules".
* Added `M-# :', `M-# _', and `M-# Z' options.
* Changed `^' to evaluate "[-3..-1]^-2" properly.
* Improved `f g' to give symbolic answers for, e.g., 101:2 and -3:2.
* Fixed a bug where `h k RET' didn't find the right place on the page.
* Fixed a bug that formatted "x*(y ? a : b)" as "x y ? a : b".
* Fixed a bug where defmath translated (< x 0) as (math-posp x)!
* Fixed a bug that prevented quick-calc from working sometimes.
* Fixed the `z ?' bug again (maybe this time for good?).
* Fixed a bug in which `V ^' (vint) was just plain wrong, wrong, wrong!
* Scanned for and fixed remaining bugs relating to autoloading.
Version 2.00 beta 2:
* Changed "make info" to try "make texinfo" if "makeinfo" not found.
* Changed to "New for Calc 2.00"; texinfo.tex chokes on apostrophes.
* Added List Tutorial Exercise 14 (just in case there weren't enough!).
* Added a discussion of the `Z F' command to the Programming Tutorial.
* Improved `H a f' not to lose info if input is partially pre-factored.
* Improved simplification of expressions like sqrt(3) + 3^3:2.
* Changed Big mode to omit "*" in expressions like 2 sqrt(3) 5^3:4.
* Replaced European date format D/M/Y with D.M.Y.
* Changed `a N' and `a X' to consider the endpoints of the interval.
* Fixed a bug where TeX mode made c*(1+a/b) look like a function call.
* Fixed a bug formatting top-level evalto's while using selections.
* Fixed a bug that caused `z ?' to crash.
* Fixed a bug where `Z F' broke for argument names "t" and "nil".
* Fixed several bugs relating to autoloading.
Version 2.00 beta 1:
* Added "What's new in Calc 2.00" to the manual (summary of info below).
* Added support for many GNUPLOT 3.0 features.
* Tweaked the Makefile and calc-compile a bit more.
* Modified to work with Zawinski's/Furuseth's optimizing byte compiler.
* Modified Calc to garbage-collect less often (raised gc-cons-threshold).
* Changed quick-calc to avoid autoloading so many parts of Calc.
* Changed Calc subfiles to work properly if not byte-compiled.
* Renamed `M-# s' to `M-# j', made `M-# s' be equivalent to `h s'.
* Changed calc-quit to avoid reapportioning space among other windows.
* Added `M-DEL' (calc-pop-above) key, to DEL as LFD is to RET.
* Added `{' and `}' to scroll vertically, analogous to `<' and `>'.
* Added `m t' for "total" algebraic mode.
* Added `d , \' option to group digits with "\,".
* Improved support of "prime" accent in "eqn" language mode.
* Changed macedit's read-kbd-macro to accept a string argument in Lisp.
* Changed calc-check-defines to use a more concise run-hooks linkage.
* Changed auto-why mode not to say [w=more] if next msg is not urgent.
* Made `a d' able to differentiate "a?b:c" and "a_i" formulas.
* Changed probability dist. functions to work with `a f' and `a d'.
* Added special constants "phi" and "gamma".
* Added "poly" function, simpler cousin of "gpoly".
* Added "pdeg", "plead", "pcont", "pprim"; cleaned up "pdiv" and "pgcd".
* Added `a p' command for polynomial interpolation.
* Added `a I' command for numerical integration; made IntegLimit variable.
* Added `a f' to factor polynomials; moved old `a f' to `a "'.
* Added `a a' to do partial fraction decompositions.
* Improved `a i' to integrate many more kinds of formulas.
* Modified `a P' to find numerical roots of high-degree polynomials.
* Modified `c 0' through `c 9' to convert int-valued floats to integers.
* Made sinh, arctanh, etc., expandable into exps/logs by `a f'.
* Added more algebraic simplifications having to do with logs and exps.
* Changed `s s', `s t', `s x', `s l' to accept an equation at prompt.
* Changed `s i' not to store Decls if its value is the default, [].
* Changed `s i' to store in `d O' language mode if in Normal or Big mode.
* Rearranged `V M'/`V R' matrix mapping modes.
* Added <#1+#2> notation for lambda expressions.
* Extended `b l' and other binary shifts to have a 2-argument version.
* Changed `u c' and `u t' to give unitless result for unitless input.
* Changed sqrt(1-cos(x)^2)-to-sin(x) to be an unsafe simplification.
* Improved simplification of sqrts, e.g., sqrt(a^2 x + a^2 y).
* Changed solver to treat (x-a)(x-b)(x-c) more intelligently.
* Changed Pascal language mode to use "$FFFF" for hexadecimal numbers.
* Added support for non-decimal display of floats.
* Changed `p' to refresh stack display if current float format uses it.
* Changed Big mode to use subscript notation for log10(x), log(x,b), r#nnn.
* Changed Big mode to format deriv(u,x) and tderiv(u,x) as du/dx.
* Changed Big mode to format integ(1/x,x) as "dx/x" instead of "1/x dx".
* Added "tty" output type for graphics commands.
* Documented Calc's random number generation algorithm in the manual.
* Fixed a bug involving having "(setq calc-timing t)" in .emacs.
* Fixed a bug that incorrectly parsed "|x| - 1" in TeX mode.
* Fixed bugs and made improvements in `a R' when widening the guess.
* Fixed a bug that where `a S' didn't solve (x - a)^2 = (x - b)^2.
* Fixed a bug that sometimes crashed `a P' on systems of equations.
* Fixed a bug that prevented `b p' (calc-pack-bits) from working.
* Fixed some bugs in which certain functions didn't get autoloaded.
* Fixed a bug in which the date <1/1/13> was incorrectly parsed.
* Fixed a bug which prevented `j D' from expanding (a+b)/c.
* Fixed a bug in solver: bad inverses for sinh and cosh.
* Fixed a bug in math-possible-signs that failed for x*0.
* Fixed a bug where sqrt(-a) was rewritten sqrt(a)*i even if a<0.
* Fixed a bug in line breaker when first "word" of line was too long.
* Worked around a makeinfo bug that handled @end group/@group badly.
Version 2.00 alpha 3:
* Changed logic for locating component .elc files to be even smarter.
* Changed "make install" to "make compile"; added different "make install".
* Improved "make compile" to check file dates and compile only when needed.
* Made output of "make compile" in batch mode more compact and readable.
* Replaced "Quick Overview" in manual with "Demonstration of Calc".
* Changed to use keymaps for dispatching M-# and h prefix keys.
* Added TAGS target to the Calc Makefile.
* Removed most doc strings from functions; new help commands are better.
* Got rid of some crufty "fset" calls that were cluttering the code.
* Split calc-grab-region into two functions, calc-grab-region/-rectangle.
* Swapped positions of stack and trail in full-calc-keypad display.
* Improved line-breaking algorithm for displaying long formulas.
* Improved display of control characters in vectors shown as strings.
* Changed `d o' to allow fraction format to specify desired denominator.
* Changed `M-# y' to respect overwrite mode in target buffer.
* Added `H' prefix to display-mode commands to suppress stack refresh.
* Changed "calc-why" mechanism to display urgent messages automatically.
* Handled taking derivatives of symbolic integrals and vice-versa.
* Handled integrating vectors of formulas.
* Incorporated Ewerlid's polynomial division and GCD functions into Calc.
* Improved algebraic operations on "mod" forms, esp. polynomials.
* Added some more financial functions (sln, syd, ddb).
* Added nest, anest, fixp, and afixp (`H V R' and `H V U') functions.
* Added `a .' (calc-remove-equal) command to take apart equations.
* Generalized dfact to work for negative odd integers; added !! syntax.
* Changed `k f' to factor 1, 0, and negative integers.
* Changed `u M', etc., to accept +/- and [ .. ] forms as distributions.
* Changed `g q' to remove *Gnuplot Commands/Trail* window if present.
* Added support for Francois Pinard's "dumb terminal" driver for GNUPLOT.
* Added ":: remember" feature for rewrite rules.
* Changed rewrites to let pattern "a*b" match "x/2" with a=x, b=1/2.
* Added ability to put function names like "simplify" in rewrite schedule.
* Added "Rewrites Tutorial" to the manual.
* Changed ` to bind RET as newline instead of finish if editing a vector.
* Added some new exercises to the List Tutorial.
* Changed `Z F', `V M', etc. not to remove stored vars from def arg list.
* Added parsing for /1, 2, 3/ notation for Fortran mode vectors.
* Added a "%%" syntax for comments in formulas being read.
* Fixed a bug in which failing `h k' removed an existing Info window.
* Fixed a bug in `j /' operating on subformulas like "a + b".
* Fixed a bug in which "inf = inf" undesirably evaluated to 1.
* Fixed a bug that simplified "0 = 1 + a + 2" to "0 = a".
* Fixed a bug that failed for rewrite patterns like "fib(1 ||| 2)".
* Fixed a bug that arose because rewrite programs are non-reentrant.
Version 2.00 alpha 2:
* Changed LFD terminating algebraic entry to push in no-simplify mode.
* Changed so that `K -' interprets `-' as calc-minus, not neg prefix arg.
* Improved `h c' command to understand all Calc key sequences.
* Fixed problems with DistribRules, NegateRules, and FitRules.
* Fixed several bad node pointers in the manual.
* Fixed a bug in `h C-w' when used with makeinfo-formatted manuals.
* Fixed a bug in sqrt(-1) when Polar and HMS modes are enabled.
* Fixed/improved dscalar and deven functions; added dodd.
* Fixed a bug in polynomial handling that also affected sum(sin(k),k,1,n).
* Fixed various other glitches in the manual.
Version 2.00 alpha 1:
* Calc's tar file now creates a calc-(version) directory to unpack into.
* Calc now comes with a Makefile; install with "make install".
* Calc now comes already split into many files; installation is much simpler.
* Changed base file name of the manual from "calc-info" to "calc.info".
* Key binding for `M-# w' was documented but not implemented.
* Bound M-# ' to be synonymous with `M-# f' (used to be `M-# q').
* Changed M-# M-# to use last interface of C or K; E no longer counts.
* Changed `i' (and `M-# i') not to return to Top node unnecessarily.
* Changed `h' to be a prefix key with various help commands.
* Changed `s' to be a prefix key with various store and recall commands.
* Keys `i', `r', and `l' are obsolete (moved to `h' and `s' prefixes).
* Rearranged `K', `X', and `M-RET' keys; `K' is now calc-keep-args.
* Changed quick-calc to display input formula as well as output if room.
* Changed quick-calc to interact with the editing buffer and kill ring.
* Created pack, unpack, unpackt function equivalents of `v p', `v u'.
* Changed to expand (a/b)^x to a^x/b^x only if b > 0 (not if a > 0).
* Changed math-possible-signs to understand sqrt function.
* Changed Z [, rewrites to consider any provably non-zero value as true.
* Changed normal language modes to accept ** as a synonym for ^.
* Added "maple" language mode.
* Changed, e.g., Mathematica "(2 + 3 I)^(1.23*10^20)" to include parens.
* Generalized math-compose-big properties for all language modes.
* Introduced "string" and other function for composing expressions.
* Changed many recursive vector routines to use loops instead.
* Added evalv, evalvn function equivalents to `=', `N'.
* Changed "expr =>" not to evaluate at all if in no-simplify mode.
* Redesigned user interface of `a F' (calc-curve-fit) command.
* Added "phase" feature to the rewrite rule system.
* Added "&&&", "|||", "!!!" to the rewrite rule system.
* Introduced a new notation for rewrites: LHS := RHS :: COND.
* Changed `a r' (but not `j r') to repeat 100 times by default.
* Integrated EvalRules more cleanly into the default simplifications.
* Added `H v l' [mdims] to measure the dimensions of a matrix.
* Changed `u c' to interpret "/units" as "1/units".
* Added `u a' to adjust unit prefix letters automatically.
* Changed `u s' to enable scalar mode while simplifying.
* Changed `c f' [pfloat] not to float integer powers or subscripts.
* Added a three-argument form for the "hms" function.
* Changed, e.g., sin(90) degrees to produce 1 instead of 1.0.
* Changed symbolic mode to prefer sqrt(int): abs([1 2 3]) => sqrt(14).
* Enhanced solver to handle, e.g., x + 1/x = a; exp(x) + exp(-x) = a.
* Enhanced simplifier to handle, e.g., exp(a+2) / e^a => e^2.
* Enhanced `a s' to simplify sqrt(x) - x^1:2 and exp(x) - e^x to 0.
* Added -(a + b) to -a - b as a default simplification.
* Added rules for differentiating sum() and prod() functions.
* Added a few more energy units (due to Przemek Klosowski).
* Added overflow/underflow checking for all floating-point arithmetic.
* Extended error forms to work with complex numbers.
* Generalized GCD to handle fractional arguments.
* Changed graphics routines to evaluate "x" values, e.g., [-pi .. pi].
* Added `g q', like `g K' but without viewing the Gnuplot Trail.
* Changed `g p' and `V M' to display better "Working..." messages.
* Modified `M-# g' to be more robust about grabbing formulas.
* Added `Y' prefix key reserved for user-written extensions.
* Added calc-load-hook and calc-ext-load-hook.
* Prevented calc-install from leaving large ~ files behind.
* Changed @bullet to @bullet{} in manual to conform to texinfo spec.
* Rearranged some chapters in the manual to be a bit more logical.
* Added calc-split-summary command.
* Fixed several bugs in embedded mode.
* Fixed a bug in calc-vector-covariance that required a prefix arg.
* Fixed a bug that prevented parsing "a=>" with no right-hand side.
* Fixed a bug which allowed incorrectly dividing a vector by a vector.
* Fixed a bug formatting sum(...)^2 in Big mode.
* Fixed a bug that prevented Calc from deleting old graphics temp files.
* Fixed some typos calling calc-inverse-func instead of calc-invert-func.
* Fixed bugs in the derivatives of conj, deg, and rad; added re, im.
* Fixed a bug where (r;theta) parsed as r exp(theta i) even in Deg mode.
* Fixed a bug which gave wrong answer for exp of a polar complex number.
* Fixed a bug in `Z F' that failed if formula used non-arg variables.
* Fixed a bad pointer to Info node "Assignments in Embedded Mode".
* Fixed several errors in the Calc Summary.
Version 1.08 beta 1:
* Calc's copyright has been assigned to FSF, for inclusion in Emacs 19!
* Changed M-# to be a two-key sequence; use M-# M-# to start Calc now.
* Rewrote and expanded the introductory chapter of the manual.
* Added a key and function summary to the manual.
* Changed the manual to take better advantage of TeX's math formatting.
* Changed manual to be printable in @smallbook format.
* Added "calc-embedded" mode.
* Added "=>" [evalto] operator.
* Added facilities for date and date/time arithmetic.
* Added a set of financial functions (pv, fv, etc.).
* Added infinite quantities inf, uinf, and nan (plus infinite intervals).
* Added "EvalRules", "SimpRules", and "ExtSimpRules" variables.
* Added sum and product commands `a +', `a -', `a *', `a T'.
* Enhanced `a S' and `a P' to solve systems of equations.
* Enhanced solver to handle eqns like sin(x) = cos(2 x), sqrt(x) + x = 1.
* Added `a M' (calc-map-equation) command.
* Added new statistical functions: mean, standard deviation, etc.
* Added line, polynomial, and curve fitting commands (`a L' and `a F').
* Added support for composite units, e.g., "mi+ft+in".
* Enhanced "Big" mode to format square roots, choose, and powers better.
* Enhanced "Big" mode to display fractions in large notation.
* Added several alternate formats for matrix display.
* Changed TeX mode to write "(1 + x^2)" instead of "\left(1 + x^2\right)".
* Added support for relational operators in TeX and FORTRAN modes.
* Added recognition of accents like \dot, \tilde, \underline in TeX mode.
* Added "eqn" language mode.
* Added extra control over display justification with `d <', `d =', `d >'.
* Added calc-left-label and calc-right-label (`d {', `d }').
* Added "nn%" syntax for algebraic formulas; equivalent to "nn * .01".
* Added input syntaxes like a = b = c, a != b != c, a <= b < c.
* Changed "_" to mean subscripts; old use of "_" in vars is now "#".
* Introduced "matrix mode" and "scalar mode" (`m v').
* Introduced generic identity matrices (idn(1)).
* Added a method for declaring variables to be real, integer, > 0, etc.
* Added `Z S' command for editing stored value of a variable.
* Added "subst" algebraic function equivalent to the `a b' command.
* Added `a f' command, changed deriv/integ/solve-for to use it.
* Improved `a s' to simplify (x + y) (y + x) to (x + y)^2.
* Improved `a s' to simplify i^2 to -1.
* Improved `a s' to simplify, e.g., sin(pi/3) in Symbolic mode.
* Improved `a s' to simplify sqrt(8) to 2 sqrt(2), 1/sqrt(2) to sqrt(2)/2.
* Moved sin(arccos(x)) from `a e' to `a s'; not unsafe after all!
* Changed (x y)^z => x^z y^z to be a usually-unsafe simplification.
* Added thorough documentation of `a s' and `a e' to the manual.
* Improved `a c' to collect "f(a)" even if "a" also appears elsewhere.
* Introduced lin, linnt, islin, islinnt functions for linearity testing.
* Improved `a x' to use binomial theorem to give simpler answers.
* Improved `j D' to distribute powers of sums: (a + b)^n.
* Improved `j M' to merge products of powers (may need no-simplify mode).
* Changed to use defvar for DistribRules etc. so `Z V' works with them.
* Improved `j *' and `j /' to work properly in a few more cases.
* Improved `V R' to use identity value when reducing empty vectors.
* Improved `v p' and `v u' to support more complex packing operations.
* Disabled automatic simplification of sqrt(2)/2 to 1/sqrt(2).
* Bound SPC and RET to press, TAB to next-menu in *Calc Keypad* buffer.
* Added C-u ' to do algebraic entry with language mode forced to normal.
* Added "$1", "$2", etc. input notation for algebraic entry.
* Changed unary operators like `n', `&' to treat neg prefix args like RET.
* Changed ` (calc-edit) to show full precision regardless of float format.
* Enhanced quick-calc to display integers in several formats.
* Documented `g H' (calc-graph-hide) command (had been left from manual).
* Enhanced floor/ceil/trunc/round in several ways.
* Added rounde and roundu functions.
* Changed `c 1' through `c 9' to change small floats to 0.0; added `c 0'.
* Enhanced set operations to work on sets of intervals.
* Fixed erf(0), utpn(x,x,y), and arccosh(-1) to work properly.
* Changed complex arctan and arctanh to follow Steele 2nd edition.
* Expanded "Branch Cuts" section of the manual with some useful tables.
* Rearranged order of words in mode line to be a bit more logical.
* Changed `m N' (num-simplify) mode to evaluate constant vectors, too.
* Changed `a r'/`j r' to prompt twice for separate LHS/RHS if necessary.
* Enhanced `let(v,x)' in rewrites by allowing arbitrary patterns for v.
* Changed cursor positioning in second prompt for `a b' (calc-substitute).
* Changed `y' to omit line numbers more consistently.
* Changed `o' (calc-realign) to reset horizontal scrolling to zero, also.
* Added "pred" mode for calc-eval.
* Added "calc-report-bug" as an alias for "report-calc-bug".
* Added `Z T' and "calc-pass-errors" to aid debugging Calc-related code.
* Added "calc-load-everything" (`m X' or `M-# L') command.
* Enhanced calc-install to pre-build units table, CommuteRules, etc.
* Changed Calc to interact more gracefully with load-path.
* Changed Lisp Variable Index in manual to include user variables, too.
* Fixed a bug that prevented calc-install from working under VMS.
* Fixed a bug that sometimes crashed rewrites dealing with subtractions.
* Fixed a bug that prevented `a S' from solving "3 - x = 1 + x"!
* Fixed a bug in solver that crashed for certain cubics and quartics.
* Fixed a bug in calc-simplify that crashed for equations and ineqs.
* Fixed a bug which placed the "[" oddly in `d B' + `v /' mode.
* Fixed a bug where finishing calc-edit improperly obeyed language mode.
* Fixed a bug formatting (-1)^n in Big mode after selection commands.
* Fixed a bug that got ">=" and "<=" backwards in rewrite conditions.
* Fixed a bug that broke the `"x"' key in calc-keypad mode.
* Fixed a bug in which `MAP$' in calc-keypad didn't display "Working...".
* Fixed a bug where matrix division gave bad result for singular matrix.
* Fixed a bug which closed Calc window if calc-grab-region got an error.
* Fixed a bug where `a s' failed on formulas containing dimension errors.
* Fixed a bug that caused `m F' to hang.
* Fixed a bug in complex arithmetic that caused problems with solver.
* Fixed a bug which raised intervals to interval powers incorrectly.
* Fixed a bug in utpp/ltpp (order of arguments did not match the manual).
* Fixed a bug in which `t y' rounded yanked data with old precision.
* Fixed a bug in which "in(3, [3 .. 3))" returned true.
* Fixed a bug which simplified abs(abs(x)) incorrectly.
* Fixed a bug in which (a^2)^1:3 was unsafely simplified to a^2:3.
* Fixed a bug in rewrite system which missed pattern "2 sin(x) cos(x)".
* Fixed a bug in rewrite system which missed pattern "a - a cos(x)^2".
* Fixed obsolete trail tags gsmp, gneg, ginv to jsmp, jneg, jinv.
* Fixed some errors and made improvements in units table [Ulrich Mueller].
Version 1.07:
* Added `m F' (calc-settings-file-name) command.
* Added calc-autoload-directory variable.
* Extended Z ` to accept a prefix argument.
* Added keystrokes (v h, v k) for head, tail, cons.
* Extended `v e' to accept a vector as the filler.
* Changed `V M', `V R' to accept mapping-mode keys in uppercase, too.
* Changed V M ' etc. to accept $, $$, ... as argument indicators.
* Changed `t y' to accept a prefix argument.
* Put in a cleaner and safer random number generator for `k r' et al.
* Fixed a bug which completely broke `a r' command!
* Fixed "0 * matrix" to generate a zero matrix instead of 0.
* Fixed a bug in `a R' which sometimes caused it to crash.
* Fixed a fatal typo in the TeX version of the manual.
* Fixed a bug that prevented C-k, C-w, M-w from working in Trail buffer.
* Fixed another bug in `Z P' command.
* Fixed a bug in `u s' which incorrectly simplified subtractions.
* Fixed an argument-name aliasing bug evaluating lambda( ) formulas.
* Fixed overfull hboxes in the manual.
* Fixed various other bugs in the manual.
Version 1.06:
* Added "calc-keypad" mode for X window system users (try it!).
* Improved "calc-eval" for calling/operating Calc from user-written Lisp.
* Moved vector accumulate command to `V U' (old `H V R' still supported).
* Added right-to-left reductions: `I V R' and `I V U'.
* Added set operations on vectors: intersect, union, diff, xor.
* Added `I v s' to remove a subvector from a vector.
* Introduced `H |' to append two vectors with no magical special cases.
* Introduced rhead, rtail, and rcons for isolating last vector element.
* Changed `g p' to keep temp files around until data actually change.
* Improved `a S' to solve many higher-order polynomial equations.
* Added `a P' to produce a vector of all solutions to an equation.
* Enhanced `a v' and `j v' to allow top-level-only evaluation.
* Changed `j DEL' to delete a side of an eqn or ineq, leaving other side.
* Fixed binding for keys `j 1' through `j 9'.
* Introduced "let" marker in rewrite rules.
* Enhanced the "sign" function to provide a two-argument version.
* Changed "max-specpdl-size exceeded" error message to be user-friendly.
* Put "<Aborted>" in the trail in above case and when user presses C-g.
* Changed TeX mode to generate \ldots instead of \dots, recognize both.
* Changed "sin(0)" etc. (for integer 0) to generate "0" instead of "0.".
* Enhanced Programming Tutorial exercise 2.
* Fixed an error in the answer to Types Tutorial exercise 3.
* Fixed several bugs relating to head, tail, and cons functions.
* Fixed some other minor typos in the manual.
* Fixed several bugs in `Z P' (calc-user-define-permanent).
* Fixed several bugs that broke the `g P' command.
Version 1.05:
* Created a calc-install command to ease installation.
* Added lots of exercises to the Tutorial section of the manual.
* Added ability to select and operate on sub-formulas.
* Substantially improved the algebraic rewrite-rule system.
* Added a set of graphing commands that use GNUPLOT.
* Added a command (`a R') for finding numerical roots to equations.
* Added several new math functions, such as erf and Bessel functions.
* Added key bindings for miscellaneous commands using the "f" prefix key.
* Added lots of new vector operations, many of them in the spirit of APL.
* Added more control over vector display, including an abbreviated mode.
* Improved keyboard macro editing; added read-kbd-macro to macedit.el.
* Introduced the `m S' (calc-shift-prefix) command.
* Enhanced the calc-edit command in several ways.
* Made it possible to hit ` (calc-edit) during numeric/algebraic entry.
* Enhanced the calc-solve-for command to handle inequalities.
* Enhanced calc-simplify to handle equations and inequalities.
* Taught log10 and log to look for exact integer or rational results.
* Added ability to take Nth roots directly.
* Added "increment" and "decrement" commands for integers and floats.
* Added "full-help" command, changed "h" key to invoke it.
* Added special help for Inverse and Hyperbolic prefixes.
* Added an optional prefix argument to `o' (calc-realign).
* Changed `t s' and `t r' to use RET as the search exit key.
* Made handling of operator keys for V M, V R, etc. more regular.
* Improved TeX mode; added support for \matrix format.
* Added a variant of `m a' mode that only affects ( and [ keys.
* Fixed "Mismatch" message for algebraic entry of semi-open intervals.
* Trimmed fat from calc.el to speed loading, moved more to calc-ext.el.
* Fixed a bug in which minibuffer entry rounded to out-of-date precision.
* Fixed a bug which crashed Calc 1.04 under Epoch.
* Fixed a bug which messed up Calc Trail's mode line, among other things.
* Fixed a bug which caused trail ">" to show only when in Trail buffer.
* Fixed a bug in which "calc" called "calc-grab-region" with too few args.
* Fixed bugs in both implementation and documentation of calc-perm.
* Fixed a bug in which calc-simplify-extended always used radians.
* Fixed a bug where calc-comma failed to override "polar" mode.
* Fixed a bug doing mixed arithmetic on rectangular+polar complex numbers.
* Fixed several bugs in transcendental functions with complex arguments.
* Fixed a bug in which `a s' simplified "x / .5" to ".5 x".
* Fixed numerous other bugs in various parts of Calc.
* Completed the "Hooks" section of the "Internals" chapter of the manual.
Version 1.04:
* Included a copy of revision history (from README) in calc.el.
* Added the "calc-split" feature to split calc-ext.el into smaller bits.
* Changed calc-unpack to unpack floats and fractions, too.
* Added "mant", "xpon", and "scf" functions for decomposing floats.
* Fixed a bug in the "y" command with positive prefix arguments.
* Rearranged binary shift/rotate command keys to be a bit more convenient.
* Fixed a bug in which simplifying "(0/0) * 2" crashed with a Lisp error.
* Made `H F' [ffloor] and friends faster for very large arguments.
* Made calc-define-del more robust.
* Handled pasting of data into the Calculator using the mouse under X.
* Made overlay-arrow variables buffer-local to avoid interference.
* Fixed a problem in which Calc Trail buffer got stuck after a C-x C-w.
Version 1.03:
* Changed math-choose to compute n-choose-m faster when m is large.
* Fixed some problems with TeX mode.
* Fixed a bug that prevented `b s' from working without a prefix argument.
* Added "calc-eval" function.
* Improved calc-grab-region.
Version 1.02:
* Fixed a bug in Tutorial: telephone pole height/distance were switched!
* Fixed a few other things in the manual.
* Added "full-calc" command.
* Added "calc-insert-variables" (`Z I') command.
* Quick Calc now works even if you are already in the minibuffer.
* Fixed a bug in math-mul-bignum-digit which affected math-and, etc.
* Definition of "Hectares" was wrong in units table.
* Fixed a bug in calc-execute-kbd-macro concerning undo and refresh.
* Bound "calc-undo" to `C-x u' as well as `C-_' and `U'.
Version 1.01:
* Added a tutorial section to the manual.
* Next and Prev for node Strings in the manual were reversed; fixed.
* Changed "'bignum" in calc-isqrt-bignum-iter to "'bigpos".
* Fixed a bug that prevented "$" from working during algebraic entry.
* Fixed a bug caused by an X (last-X) command following a K (macro) cmd.
* Fixed a bug in which K command incorrectly formatted stack in Big mode.
* Added space between unary operators and non-flat compositions.
(Otherwise, "-(a/b)" in Big mode blended the minus sign into the rule!)
* Fixed formatting of (-1)^n in Big mode.
* Fixed some problems relating to "not" operator in Pascal language mode.
* Fixed several bugs relating to V M ' and V M $ sequences.
* Fixed matrix-vector multiplication to produce a vector.
* Introduced Z ` ... Z ' commands; renamed old Z ' to Z #.
* Fixed various other bugs.
* Added calc-settings-file variable suggested by C. Witty.
Version 1.00:
* First official release of Calc.
* If you used the Beta test version (0.01), you will find that this
version of Calc is over 50% larger than the original release.
General areas of improvement include much better algebra features;
operations on units; language modes; simplification modes; interval
arithmetic; vector mapping and reduction. Other new commands include
calc-fraction and calc-grab-region. The program has been split into
two parts for faster loading, and the manual is more complete.

1163
lisp/calc/calc-aent.el Normal file
View file

File diff suppressed because it is too large Load diff

1699
lisp/calc/calc-alg.el Normal file
View file

File diff suppressed because it is too large Load diff

2924
lisp/calc/calc-arith.el Normal file
View file

File diff suppressed because it is too large Load diff

847
lisp/calc/calc-bin.el Normal file
View file

@ -0,0 +1,847 @@
;; Calculator for GNU Emacs, part II [calc-bin.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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)

1056
lisp/calc/calc-comb.el Normal file
View file

File diff suppressed because it is too large Load diff

377
lisp/calc/calc-cplx.el Normal file
View file

@ -0,0 +1,377 @@
;; Calculator for GNU Emacs, part II [calc-cplx.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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))))
)

1256
lisp/calc/calc-embed.el Normal file
View file

File diff suppressed because it is too large Load diff

3439
lisp/calc/calc-ext.el Normal file
View file

File diff suppressed because it is too large Load diff

452
lisp/calc/calc-fin.el Normal file
View file

@ -0,0 +1,452 @@
;; Calculator for GNU Emacs, part II [calc-fin.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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))
)

1914
lisp/calc/calc-forms.el Normal file
View file

File diff suppressed because it is too large Load diff

235
lisp/calc/calc-frac.el Normal file
View file

@ -0,0 +1,235 @@
;; Calculator for GNU Emacs, part II [calc-frac.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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))
)

1034
lisp/calc/calc-funcs.el Normal file
View file

File diff suppressed because it is too large Load diff

1496
lisp/calc/calc-graph.el Normal file
View file

File diff suppressed because it is too large Load diff

686
lisp/calc/calc-help.el Normal file
View file

@ -0,0 +1,686 @@
;; Calculator for GNU Emacs, part II [calc-help.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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)
)

234
lisp/calc/calc-incom.el Normal file
View file

@ -0,0 +1,234 @@
;; Calculator for GNU Emacs, part II [calc-incom.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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")))
)

682
lisp/calc/calc-keypd.el Normal file
View file

@ -0,0 +1,682 @@
;; Calculator for GNU Emacs, part II [calc-keypd.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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 ) ) )
)

1151
lisp/calc/calc-lang.el Normal file
View file

File diff suppressed because it is too large Load diff

262
lisp/calc/calc-macs.el Normal file
View file

@ -0,0 +1,262 @@
;; Calculator for GNU Emacs, part I [calc-macs.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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)))
)

466
lisp/calc/calc-maint.el Normal file
View file

@ -0,0 +1,466 @@
;; 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.

1305
lisp/calc/calc-map.el Normal file
View file

File diff suppressed because it is too large Load diff

1783
lisp/calc/calc-math.el Normal file
View file

File diff suppressed because it is too large Load diff

877
lisp/calc/calc-misc.el Normal file
View file

@ -0,0 +1,877 @@
;; Calculator for GNU Emacs, part I [calc-misc.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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))

714
lisp/calc/calc-mode.el Normal file
View file

@ -0,0 +1,714 @@
;; Calculator for GNU Emacs, part II [calc-mode.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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)))
)

378
lisp/calc/calc-mtx.el Normal file
View file

@ -0,0 +1,378 @@
;; Calculator for GNU Emacs, part II [calc-mat.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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))
)

1195
lisp/calc/calc-poly.el Normal file
View file

File diff suppressed because it is too large Load diff

2364
lisp/calc/calc-prog.el Normal file
View file

File diff suppressed because it is too large Load diff

2097
lisp/calc/calc-rewr.el Normal file
View file

File diff suppressed because it is too large Load diff

444
lisp/calc/calc-rules.el Normal file
View file

@ -0,0 +1,444 @@
;; Calculator for GNU Emacs, part II [calc-rules.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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 ]")
)

867
lisp/calc/calc-sel.el Normal file
View file

@ -0,0 +1,867 @@
;; Calculator for GNU Emacs, part II [calc-sel.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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)
)

629
lisp/calc/calc-stat.el Normal file
View file

@ -0,0 +1,629 @@
;; Calculator for GNU Emacs, part II [calc-stat.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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))))))))
)

663
lisp/calc/calc-store.el Normal file
View file

@ -0,0 +1,663 @@
;; Calculator for GNU Emacs, part II [calc-store.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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))
)

300
lisp/calc/calc-stuff.el Normal file
View file

@ -0,0 +1,300 @@
;; Calculator for GNU Emacs, part II [calc-stuff.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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)))))
)

190
lisp/calc/calc-trail.el Normal file
View file

@ -0,0 +1,190 @@
;; Calculator for GNU Emacs, part II [calc-trail.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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))
)

159
lisp/calc/calc-undo.el Normal file
View file

@ -0,0 +1,159 @@
;; Calculator for GNU Emacs, part II [calc-undo.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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))))
)

1352
lisp/calc/calc-units.el Normal file
View file

File diff suppressed because it is too large Load diff

1698
lisp/calc/calc-vec.el Normal file
View file

File diff suppressed because it is too large Load diff

593
lisp/calc/calc-yank.el Normal file
View file

@ -0,0 +1,593 @@
;; Calculator for GNU Emacs, part II [calc-yank.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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)))))))))
)

3557
lisp/calc/calc.el Normal file
View file

File diff suppressed because it is too large Load diff

3507
lisp/calc/calcalg2.el Normal file
View file

File diff suppressed because it is too large Load diff

1824
lisp/calc/calcalg3.el Normal file
View file

File diff suppressed because it is too large Load diff

1755
lisp/calc/calccomp.el Normal file
View file

File diff suppressed because it is too large Load diff

303
lisp/calc/calcsel2.el Normal file
View file

@ -0,0 +1,303 @@
;; Calculator for GNU Emacs, part II [calc-sel-2.el]
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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")
)

716
lisp/calc/macedit.el Normal file
View file

@ -0,0 +1,716 @@
;; Keyboard macro editor for GNU Emacs. Version 1.05.
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
;; Written by Dave Gillespie, 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)
)