Overview
Comment:Some historical releases purely for archival purposes

git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360

Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | descendants | master | trunk
Files: files | file ages | folders
SHA3-256: f2fda60abd183e6ea7adfc3fb2cba581b162e2b92b309e641819cbc1aa8db684
User & Date: arthurcnorman@users.sourceforge.net on 2011-09-02 18:13:33
Other Links: manifest | tags
Context
2011-09-02
18:41:44
discard some files that are probably not especially useful

git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1376 2bfe0521-f11c-4a00-b80e-6202646ff360 check-in: 2bf132ecc3 user: arthurcnorman@users.sourceforge.net tags: master, trunk

18:13:33
Some historical releases purely for archival purposes

git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 check-in: f2fda60abd user: arthurcnorman@users.sourceforge.net tags: master, trunk

Changes

Added LICENSE version [fe78eb7312].







>
>
>
1
2
3
The files here have a variety of license and are NOT to be considered
to fall under the BSD license used with the main distribution.

Added README version [4de28ae9c1].











































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
These are informal and not-guaranteed-complete smapshots of some
previous releases of Reduce. There should not be any binaries or
serious build scripts here and these are all to be viewed as OUT
OF DATE and NOT SUPPORTED AT ALL. However some people may enjoy seeing
how the code-base has grown and getting a bit of insight into the
world of the past. And developers tracking a newly uncovered bug may
sometimes find it useful to look back into these archives in case
that gives insight.

PLEASE do not ask the main developers about building or installing
from these old files. ALL current support will be focussed on the
main version.

The files here typically have old restrictive copyright notices and
sometimes restrictive license terms. They are included here by virtue
of the permission that their originators granted to Tony Hearn and
his distributors to use them, but you should not modify and redistribute
anything from this directory without careful thought.


              Arthur Norman. August 2011

Added r33/alg1.red version [cb09116124].



























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
module alg!-parse;  % Particular infix operators for algebraic mode.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

newtok '((!. !+) add);

newtok '((!. !*) mult);

newtok '((!. !^) to);

newtok '((!. !* !*) to);

newtok '((!. !/) over);

infix .^,.*,.+,./;

endmodule;


module alg!-form;   % Some particular algebraic mode analysis functions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

global '(inputbuflis!* resultbuflis!* ws);

symbolic procedure forminput(u,vars,mode);
   begin scalar x;
      u := cadr u;
      if x := assoc(u,inputbuflis!*) then return cadr x
       else rederr list("Entry",u,"not found")
   end;

put('input,'formfn,'forminput);

symbolic procedure formws(u,vars,mode);
   begin scalar x;
      if x := assoc(cadr u,resultbuflis!*) then return mkquote cdr x
       else rederr list("Entry",cadr u,"not found")
   end;

put('ws,'formfn,'formws);

endmodule;


module intro;  % Introductory material for algebraic mode.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*cref !*exp !*intstr !*lcm !*mcd !*mode !*precise !*rationalize
        !*sub2);

global '(!*factor
         !*fort
         !*ifactor
         !*msg
         !*nat
         !*nero
         !*period
         !*pri
         !*reduced
         !*resubs
         !*val
         !*xdn
         erfg!*
         exlist!*
         initl!*
         nat!*!*
         ofl!*
         posn!*
         simpcount!*
         simplimit!*
         subfg!*
         tstack!*);

% Non-local variables needing top level initialization.

!*exp := t;             %expansion control flag;
!*lcm := t;             %least common multiple computation flag;
!*mcd := t;             %common denominator control flag;
!*mode := 'symbolic;    %current evaluation mode;
!*msg := t;             %flag controlling message printing;
!*nat := t;             %specifies natural printing mode;
!*period := t;          %prints a period after a fixed coefficient
                        %when FORT is on;
!*resubs := t;          %external flag controlling resubstitution;
!*val := t;             %controls operator argument evaluation;
!*xdn := t;             %flag indicating that denominators should be
                        %expanded;
exlist!* := '((!*));    %property list for standard forms used as
                        % kernels;
initl!* := append('(subfg!* !*sub2 tstack!*),initl!*);
simpcount!* := 0;       %depth of recursion within simplifier;
simplimit!* := 2000;    %allowed recursion limit within simplifier;
subfg!* := t;           %flag to indicate whether substitution
                        %is required during evaluation;
tstack!* := 0;          %stack counter in SIMPTIMES;

% Initial values of some global variables in BEGIN1 loops.

put('subfg!*,'initl,t);

put('tstack!*,'initl,0);


% Description of some non-local variables used in algebraic mode.

% alglist!* := nil;     %association list for previously simplified
                        %expressions;
% asymplis!* := nil;    %association list of asymptotic replacements;
% cursym!*              current symbol (i. e. identifier, parenthesis,
%                       delimiter, e.t.c,) in input line;
% dmode!* := nil;       %name of current polynomial domain mode if not
                        %integer;
% domainlist!* := nil;  %list of currently supported poly domain modes;
% dsubl!* := nil;       %list of previously calculated derivatives of
                        % expressions;
% exptl!* := nil;       %list of exprs with non-integer exponents;
% frlis!* := nil;       %list of renamed free variables to be found in
                        %substitutions;
% kord!* := nil;        %kernel order in standard forms;
% kprops!* := nil;      %list of active non-atomic kernel plists;
% mchfg!* := nil;       %indicates that a pattern match occurred during
                        %a cycle of the matching routines;
% mul!* := nil;         %list of additional evaluations needed in a
                        %given multiplication;
% nat!*!* := nil;       %temporary variable used in algebraic mode;
% ncmp!* := nil;        %flag indicating non-commutative multiplication
                        %mode;
% ofl!* := nil;         %current output file name;
% posn!* := nil;        %used to store output character position in
                        %printing functions;
% powlis!* := nil;      %association list of replacements for powers;
% powlis1!* := nil;     %association list of conditional replacements
                        %for powers;
% subl!* := nil;        %list of previously evaluated expressions;
% wtl!* := nil;         %tells that a WEIGHT assignment has been made;
% !*ezgcd := nil;       %ezgcd calculation flag;
% !*float := nil;       %floating arithmetic mode flag;
% !*fort := nil;        %specifies FORTRAN output;
% !*gcd := nil;         %greatest common divisor mode flag;
% !*group := nil;       %causes expressions to be grouped when EXP off;
% !*intstr := nil;      %makes expression arguments structured;
% !*int                 indicates interactive system use;
% !*match := nil;       %list of pattern matching rules;
% !*nero := nil;        %flag to suppress printing of zeros;
% !*nosubs := nil;      %internal flag controlling substitution;
% !*numval := nil;      %used to indicate that numerical expressions
                        %should be converted to a real value;
% !*outp := nil;        %holds prefix output form for extended output
                        %package;
% !*pri := nil;         %indicates that fancy output is required;
% !*reduced := nil;     %causes arguments of radicals to be factored.
                        %E.g., sqrt(-x) --> i*sqrt(x);
% !*sub2 := nil;        %indicates need for call of RESIMP;


% ***** UTILITY FUNCTIONS *****.

symbolic procedure mkid(x,y);
  % creates the ID XY from identifier X and (evaluated) object Y.
  if not idp x then typerr(x,"MKID root")
   else if atom y and (idp y or fixp y and not minusp y)
    then intern compress nconc(explode x,explode y)
   else typerr(y,"MKID index");

flag('(mkid),'opfn);

symbolic procedure multiple!-result(z,w);
   % Z is a list of items (n . prefix-form), in ordering in descending
   % order wrt n, which must be non-negative.  W is either an array
   % name, another id, a template for a multi-dimensional array or NIL.
   % Elements of Z are accordingly stored in W if it is non-NIL, or
   % returned as a list otherwise.
   begin scalar x,y;
        if null w then return 'list . reversip!* fillin z;
        x := getrtype w;
        if x and not x eq 'array then typerr(w,"array or id");
        lpriw("*****",
              list(if x eq 'array then "ARRAY" else "ID",
                   "fill no longer supported --- use lists instead"));
        if atom w then (if not arrayp w
           then (if numberp(w := reval w) then typerr(w,'id)))
         else if not arrayp car w then typerr(car w,'array)
         else w := car w . for each x in cdr w
                            collect if x eq 'times then x else reval x;
        x := length z-1;  % don't count zeroth element;
        if not((not atom w and atom car w
                         and (y := dimension car w))
             or ((y := dimension w) and null cdr y))
         then <<y := explode w;
                w := nil;
                for each j in z do
                   <<w := intern compress append(y,explode car j) . w;
                     setk1(car w,cdr j,t)>>;
                lprim if length w=1 then list(car w,"is non zero")
                       else aconc!*(reversip!* w,"are non zero");
                return x>>
         else if atom w
          then <<if caar z neq (car y-1)
                   then <<y := list(caar z+1);
                          put(w,'array,mkarray(y,'algebraic));
                          put(w,'dimension,y)>>;
                 w := list(w,'times)>>;
        y := pair(cdr w,y);
        while y and not smemq('times,caar y) do y := cdr y;
        if null y then errach "MULTIPLE-RESULT";
        y := cdar y-reval subst(0,'times,caar y)-1;
           %-1 needed since DIMENSION gives length, not highest index;
        if caar z>y then rederr list("Index",caar z,"out of range");
        repeat
           if null z or y neq caar z
             then setelv(subst(y,'times,w),0)
            else <<setelv(subst(y,'times,w),cdar z); z := cdr z>>
          until (y := y-1) < 0;
        return x
   end;

symbolic procedure fillin u;
   % fills in missing terms in multiple result argument list u
   % and returns list of coefficients.
   if null u then nil else fillin1(u,caar u);

symbolic procedure fillin1(u,n);
   if n<0 then nil
    else if u and caar u=n then cdar u . fillin1(cdr u,n-1)
    else 0 . fillin1(u,n-1);


% ***** FUNCTIONS FOR PRINTING DIAGNOSTIC AND ERROR MESSAGES *****

symbolic procedure msgpri(u,v,w,x,y);
   begin scalar nat1,z;
        if null y and null !*msg then return;
        nat1 := !*nat;
        !*nat := nil;
        if ofl!* and (!*fort or not nat1) then go to c;
    a:  terpri();
        lpri ((if null y then "***" else "*****")
                 . if u and atom u then list u else u);
        posn!* := posn();
        maprin v;
        prin2 " ";
        lpri if w and atom w then list w else w;
        posn!* := posn();
        maprin x;
        terpri!*(t); % IF NOT Y OR Y EQ 'HOLD THEN TERPRI();
        if null z then go to b;
        wrs cdr z;
        go to d;
    b:  if null ofl!* then go to d;
    c:  z := ofl!*;
        wrs nil;
        go to a;
    d:  !*nat := nat1;
        if y then if y eq 'hold then erfg!* := y else error1()
   end;

symbolic procedure errach u;
   begin
        terpri!* t;
        lprie "CATASTROPHIC ERROR *****";
        printty u;
        lpriw(" ",nil);
        rederr "Please send output and input listing to A. C. Hearn"
   end;

symbolic procedure errpri1 u;
   msgpri("Substitution for",u,"not allowed",nil,t);  % was 'HOLD

symbolic procedure errpri2(u,v);
   msgpri("Syntax error:",u,"invalid",nil,v);

symbolic procedure redmsg(u,v);
   if null !*msg or v neq "operator" then nil
    else if terminalp() then yesp list("Declare",u,v,"?") or error1()
    else lprim list(u,"declared",v);

symbolic procedure typerr(u,v);
   <<terpri!* t;
     prin2!* "***** ";
     if not atom u and atom car u and cdr u and atom cadr u 
        and null cddr u
       then <<prin2!* car u; prin2!* " "; prin2!* cadr u>>
      else maprin u;
     prin2!* " invalid as "; prin2!* v;
     terpri!* nil; erfg!* := t; error1()>>;


%                 ***** ALGEBRAIC MODE DECLARATIONS *****

flag ('(aeval arrayfn cond getel go prog progn prog2 return
        reval setq setk setel varpri !*s2i),'nochange);

flag ('(or and not member memq equal neq eq geq greaterp leq
        fixp lessp numberp ordp),'boolean);

flag ('(or and not),'boolargs);

deflist ('((exp ((nil (rmsubs)) (t (rmsubs))))
        (factor ((nil (setq !*exp t) (rmsubs))
                 (t (setq !*exp nil) (rmsubs))))
        (fort ((nil (setq !*nat nat!*!*)) (t (setq !*nat nil))))
        (gcd ((t (rmsubs))))
        (intstr ((nil (rmsubs)) (t (rmsubs))))
        (mcd ((nil (rmsubs)) (t (rmsubs))))
        (nat ((nil (setq nat!*!* nil)) (t (setq nat!*!* t))))
        (numval ((t (rmsubs))))
        (rationalize ((t (rmsubs))))
        (reduced ((t (rmsubs))))
        (val ((t (rmsubs))))),'simpfg);

switch exp,cref,factor,fort,gcd,ifactor,intstr,lcm,mcd,nat,nero,numval,
       period,precise,pri,rationalize,reduced;   % resubs, val.

endmodule;


module general;   % General functions for the support of REDUCE.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

global '(!!arbint);

!!arbint := 0; % Index for arbitrary constants.

symbolic procedure atomlis u;
   null u or (atom car u and atomlis cdr u);

symbolic procedure carx(u,v);
   if null cdr u then car u
    else rederr list("Wrong number of arguments to",v);

symbolic procedure delasc(u,v);
   if null v then nil
    else if atom car v or u neq caar v then car v . delasc(u,cdr v)
    else cdr v;

symbolic procedure eqexpr u;
   % Returns true if U is an equation.
   not atom u
      and car u memq '(eq equal) and cddr u and null cdddr u;

symbolic procedure evenp x; remainder(x,2)=0;

flag('(evenp),'opfn);  % Make a symbolic operator.

symbolic procedure get!*(u,v);
   if numberp u then nil else get(u,v);

symbolic procedure lengthc u;
   %gives character length of U excluding string and escape chars;
   begin integer n; scalar x;
      n := 0;
      x := explode u;
      if car x eq '!" then return length x-2;
      while x do
        <<if car x eq '!! then x := cdr x;
          n := n+1;
          x := cdr x>>;
      return n
   end;

symbolic procedure lhs u;
   % Returns the left-hand-side of an equation.
   if not eqexpr u then typerr(u,"equation") else cadr u;

symbolic procedure rhs u;
   % Returns the right-hand-side of an equation.
   if not eqexpr u then typerr(u,"equation") else caddr u;

flag('(lhs rhs),'opfn);  % Make symbolic operators.

symbolic procedure makearbcomplex;
   begin scalar ans;
      !!arbint := !!arbint+1;
      ans := car(simp!*(list('arbcomplex, !!arbint)));
      % This CAR is NUMR, which is not yet defined.
      return ans
   end;

symbolic procedure mapcons(u,v);
   for each j in u collect v . j;

symbolic procedure mappend(u,v);
   for each j in u collect append(v,j);

symbolic procedure nlist(u,n);
   if n=0 then nil else u . nlist(u,n-1);

symbolic procedure nth(u,n);
   car pnth(u,n);

symbolic procedure pnth(u,n);
   if null u then rederr "Index out of range"
    else if n=1 then u
    else pnth(cdr u,n-1);

symbolic procedure permp(u,v);
   if null u then t
    else if car u eq car v then permp(cdr u,cdr v)
    else not permp(cdr u,subst(car v,car u,cdr v));

symbolic procedure posintegerp u;
   % True if U is a positive (non-zero) integer.
   numberp u and fixp u and u>0;

symbolic procedure remove(x,n);
   %Returns X with Nth element removed;
   if null x then nil
    else if n=1 then cdr x
    else car x . remove(cdr x,n-1);

symbolic procedure repasc(u,v,w);
   % replaces value of key U by V in association list W.
   if null w then rederr list("key",u,"not found")
    else if u = caar w then (u . v) . cdr w
    else car w . repasc(u,v,cdr w);

symbolic procedure repeats x;
   if null x then nil
    else if car x member cdr x then car x . repeats cdr x
    else repeats cdr x;

symbolic procedure revpr u;
   cdr u . car u;

symbolic procedure smember(u,v);
   %determines if S-expression U is a member of V at any level;
   if u=v then t
    else if atom v then nil
    else smember(u,car v) or smember(u,cdr v);

symbolic procedure smemql(u,v);
   %Returns those members of id list U contained in V at any
   %level (excluding quoted expressions);
   if null u then nil
    else if smemq(car u,v) then car u . smemql(cdr u,v)
    else smemql(cdr u,v);

symbolic procedure smemqlp(u,v);
   %True if any member of id list U is contained at any level
   %in V (exclusive of quoted expressions);
   if null v then nil
    else if atom v then v memq u
    else if car v eq 'quote then nil
    else smemqlp(u,car v) or smemqlp(u,cdr v);

symbolic procedure spaces n; for i := 1:n do prin2 " ";

symbolic procedure subla(u,v);
   begin scalar x;
        if null u or null v then return v
         else if atom v
                 then return if x:= atsoc(v,u) then cdr x else v
         else return(subla(u,car v) . subla(u,cdr v))
   end;

symbolic procedure xnp(u,v);
   %returns true if the atom lists U and V have at least one common
   %element;
   u and (car u memq v or xnp(cdr u,v));

endmodule;


module sqconsel;   % Constructors and selectors for standard forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

smacro procedure u.+v; %standard (polynomial) addition constructor;
   u . v;

smacro procedure lc u;   %leading coefficient of standard form;
   cdar u;

smacro procedure ldeg u; %leading degree of standard form;
   cdaar u;

smacro procedure lt u;   %leading term of standard form;
   car u;

smacro procedure u.*v;  %standard form multiplication constructor;
   u . v;

smacro procedure mvar u; %main variable of standard form;
   caaar u;

smacro procedure lpow u; %leading power of standard form;
   caar u;

smacro procedure pdeg u;
   %returns the degree of the power U;
   cdr u;

smacro procedure red u; %reductum of standard form;
   cdr u;

smacro procedure tc u;   %coefficient of standard term;
   cdr u;

smacro procedure tdeg u; %degree of standard term;
   cdar u;

smacro procedure tpow u; %power of standard term;
   car u;

smacro procedure tvar u; %main variable of a standard term;
   caar u;

smacro procedure numr u; %numerator of standard quotient;
   car u;

smacro procedure denr u; %denominator of standard quotient;
   cdr u;

smacro procedure u ./ v; %constructor for standard quotient;
   u . v;

symbolic smacro procedure domainp u; atom u or atom car u;

endmodule;


module sqconvert;  % Procedures for converting between parts of standard
                   % quotients and prefix forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*mcd);

global '(wtl!*);

symbolic procedure !*a2f u;
   %U is an algebraic expression. Value is the equivalent form
   %or an error if conversion is not possible;
   !*q2f simp!* u;

symbolic procedure !*a2k u;
   %U is an algebraic expression. Value is the equivalent kernel
   %or an error if conversion is not possible.
   %earlier versions used SIMP0;
   begin scalar x;
      if kernp(x := simp!* u) then return mvar numr x
       else typerr(u,'kernel)
   end;

symbolic procedure !*d2q u;
   %converts domain element U into a standard quotient.
   if numberp u
     then if zerop u then nil ./ 1
   %       else if floatp u then mkfloat u ./ 1
           else u ./ 1
    else if eqcar(u,'!:rn!:) and !*mcd then cdr u
    else u ./ 1;

symbolic procedure !*ff2a(u,v);
   % Converts ratio of two forms U and V to a prefix form.
   (if wtl!* then prepsq x else mk!*sq x) where x = cancel( u ./ v);

smacro procedure !*f2a u; prepf u;

smacro procedure !*f2q u;
   %U is a standard form, value is a standard quotient;
   u . 1;

smacro procedure !*k2f u;
   %U is a kernel, value is a standard form;
   list ((u .** 1) . 1);

smacro procedure !*k2q u;
   %U is a kernel, value is a standard quotient;
   list((u .** 1) . 1) . 1;

symbolic procedure !*n2f u;
   %U is a number. Value is a standard form;
   if zerop u then nil else u;

smacro procedure !*p2f u;
   %U is a standard power, value is a standard form;
   list (u . 1);

smacro procedure !*p2q u;
   %U is a standard power, value is a standard quotient;
   list(u . 1) . 1;

symbolic procedure !*q2a u;
   %U is a standard quotient, value is an algebraic expression.
   prepsqxx u;

symbolic procedure !*q2f u;
   %U is a standard quotient, value is a standard form;
   if denr u=1 then numr u else typerr(prepsq u,'polynomial);

symbolic procedure !*q2k u;
   %U is a standard quotient, value is a kernel or an error if
   %conversion not possible;
   if kernp u then mvar numr u else typerr(prepsq u,'kernel);

smacro procedure !*t2f u;
   %U is a standard term, value is a standard form;
   list u;

smacro procedure !*t2q u;
   %U is a standard term, value is a standard quotient;
   list u . 1;

endmodule;


module sort;  % A simple sorting routine.

% Author: Arthur C. Norman.
% Modified by: Anthony C. Hearn to use list changing operations for
%              greater efficiency.

expr procedure sort(lst,fn);
   begin scalar tree;
      if null lst or null cdr lst then return lst;
      tree := list(car lst,nil);
      while pairp(lst := cdr lst) do treeadd(car lst,tree,fn);
      return tree2list(tree,nil)
   end;

expr procedure tree2list(tree,lst);
   % { Convert a sorted tree into a list}
   if null tree then lst
    else tree2list(cadr tree,car tree . tree2list(cddr tree,lst));

expr procedure treeadd(item,node,fn);
   % { add item to a node, using fn as an order predicate}
   if apply2(fn,item, car node)
     then if cadr node then treeadd(item,cadr node,fn)
           else rplaca(cdr node,list(item,nil))
    else if cddr node then treeadd(item,cddr node,fn)
    else rplacd(cdr node,list(item,nil));

% expr procedure treeadd(item,tree,fn);
%    % add item to a tree, using fn as an order predicate;
%    if null tree then item . (nil . nil)
%     else if apply2(fn,item,car tree)
%      then car tree . (treeadd(item,cadr tree,fn) . cddr tree)
%     else car tree . (cadr tree . treeadd(item,cddr tree,fn));

symbolic procedure idsort u;
   % lexicographically sort list of ids.
   sort(u,function idcompare);

symbolic procedure idcompare(u,v);
   % compare lexicographical ordering of two ids.
   idcomp1(explode2 u,explode2 v);

symbolic procedure idcomp1(u,v);
   if null u then t
    else if null v then nil
    else if car u eq car v then idcomp1(cdr u,cdr v)
    else orderp(car u,car v);

% Comparison functions and special cases for sorting.

symbolic procedure lesspcar(a,b); car a < car b;

symbolic procedure lesspcdr(a,b); cdr a < cdr b;

symbolic procedure lessppair(a,b);
    if car a = car b then cdr a<cdr b else car a<car b;

symbolic procedure greaterpcdr(a,b); cdr a > cdr b;

symbolic procedure lesspcdadr(a,b); cdadr a < cdadr b;

symbolic procedure lesspdeg(a,b);
   if domainp b then nil else if domainp a then t else ldeg a<ldeg b;

symbolic procedure ordopcar(a,b); ordop(car a,car b);

symbolic procedure orderfactors(a,b);
   if cdr a = cdr b then ordp(car a,car b) else cdr a < cdr b;

endmodule;


module reval; % Functions for algebraic evaluation of prefix forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*exp !*intstr alglist!* dmode!*);

global '(!*resubs !*sqvar!* !*val);

symbolic procedure reval u;
   reval1(u,t);

symbolic procedure aeval u;
   reval1(u,nil);

symbolic procedure reval1(u,v);
   begin scalar alglist!*,x;
      % We rebind alglist!* to avoid invalid computation in loops.
      if null u then return nil   % this may give trouble
       else if stringp u then return u
       else if numberp u and fixp u
        then return if flagp(dmode!*,'convert) then reval2(u,v) else u
       else if atom u
        then if idp u and (x := get(u,'avalue))
               then return reval1(cadr x,v)
              else nil
       else if not idp car u or car u eq '!*comma!*
        then errpri2(u,t)
       else if car u eq '!*sq
        then return if caddr u
                      then if null v then u else prepsqxx cadr u
                     else reval2(u,v)
       else if flagp(car u,'opfn) then return reval1(opfneval u,v)
       else if x := get(car u,'psopfn) then return apply1(x,cdr u)
          % Note that we assume that the results of such functions are
          % always returned in evaluated form.
       else if arrayp car u then return reval1(getelv u,v);
       return if x := getrtype u then apply2(get(x,'evfn),u,v)
               else reval2(u,v)
   end;

symbolic procedure opfneval u;
   eval(car u . for each j in
                  (if flagp(car u,'noval) then cdr u else revlis cdr u)
                  collect mkquote j);

flag('(reval),'opfn);   % to make it a symbolic operator.

symbolic procedure reval2(u,v);
   (if null v then mk!*sq x else prepsqxx x) where x = simp!* u;

symbolic procedure getrtype u;
   % Returns overall algebraic type of u (or NIL is expression is a
   % scalar). Analysis is incomplete for efficiency reasons.
   % Type conflicts will later be resolved when expression is evaluated.
   begin scalar x,y;
    return
    if atom u
      then if not idp u then nil
            else if flagp(u,'share) then getrtype eval u
            else if x := get(u,'rtype)
                    then if y := get(x,'rtypefn) then apply1(y,nil)
                          else x
                  else nil
     else if not idp car u then nil
     else if (x := get(car u,'rtype)) and (x := get(x,'rtypefn))
      then apply1(x,cdr u)
     else if x := get(car u,'rtypefn) then apply1(x,cdr u)
     else nil
   end;

deflist('
  ((difference getrtypecar)
   (expt getrtypecar)
   (minus getrtypecar)
   (plus getrtypecar)
   (quotient getrtypeor)
   (recip getrtypecar)
   (times getrtypeor)
   (!*sq (lambda (x) nil))
 ),'rtypefn);

symbolic procedure getrtypecar u; getrtype car u;

symbolic procedure getrtypeor u;
   u and (getrtype car u or getrtypeor cdr u);

symbolic procedure !*eqn2a u;
   % Converts equation U to the difference of its two arguments.
   if null cdr u or null cddr u or cdddr u then typerr(u,"equation")
    else list('difference,cadr u,caddr u);

symbolic procedure getelv u;
   %returns the value of the array element U;
   getel(car u . for each x in cdr u collect ieval x);

symbolic procedure setelv(u,v);
   setel(car u . for each x in cdr u collect ieval x,v);

symbolic procedure revlis u; for each j in u collect reval j;

symbolic procedure revop1 u;
   if !*val then car u . revlis cdr u else u;

symbolic procedure mk!*sq u;
   if null numr u then 0
    else if atom numr u and denr u=1 then numr u
    else '!*sq . expchk u . if !*resubs then !*sqvar!* else list nil;

symbolic procedure expchk u;
   if !*exp then u else canprod(mkprod!* numr u,mkprod!* denr u);

symbolic procedure lengthreval u;
   begin scalar v,w;
      if length u neq 1
        then rederr "LENGTH called with wrong number of arguments"
       else if idp car u and arrayp car u
        then return 'list . get(car u,'dimension);
      v := aeval car u;
      if (w := getrtype v) and (w := get(w,'lengthfn))
        then return apply1(w,v)
       else if atom v then return 1
       else if not idp car v or not(w := get(car v,'lengthfn))
        then typerr(u,"length argument")
       else return apply1(w,cdr v)
   end;

put('length,'psopfn,'lengthreval);

endmodule;


module algbool; % Evaluation functions for algebraic boolean operators.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

symbolic procedure evalequal(u,v);
   begin scalar x;
      return if (x := getrtype u) neq getrtype v then nil
              else if null x
               then numberp(x := reval list('difference,u,v))
                       and zerop x
              else u=v
   end;

put('equal,'boolfn,'evalequal);

symbolic procedure equalreval u; 'equal . revlis u;

put('equal,'psopfn,'equalreval);

symbolic procedure evalgreaterp(u,v);
   (lambda x;
    if not atom denr x or not domainp numr x
      then typerr(mk!*sq if minusf numr x then negsq x else x,"number")
     else numr x and !:minusp numr x)
        simp!* list('difference,v,u);

put('greaterp,'boolfn,'evalgreaterp);

symbolic procedure evalgeq(u,v); not evallessp(u,v);

put('geq,'boolfn,'evalgeq);

symbolic procedure evallessp(u,v); evalgreaterp(v,u);

put('lessp,'boolfn,'evallessp);

symbolic procedure evalleq(u,v); not evalgreaterp(u,v);

put('leq,'boolfn,'evalleq);

symbolic procedure evalneq(u,v); not evalequal(u,v);

put('neq,'boolfn,'evalneq);

symbolic procedure evalnumberp u; 
   (lambda x; atom denr x and domainp numr x) simp!* u;

put('numberp,'boolfn,'evalnumberp);

endmodule;


module simp; % Functions to convert prefix forms into canonical forms.

% Author: Anthony C. Hearn.

% Modifications by: F. Kako.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*asymp!* !*exp !*gcd !*keepsqrts !*mcd !*mode !*numval
        !*precise !*rationalize !*sub2 !*uncached alglist!*
        current!-modulus dmode!*);

global '(!*convert
         !*match
         !*reduced
         exptl!*
         frlis!*
         initl!*
         mul!*
         ncmp!*
         powlis1!*
         simpcount!*
         simplimit!*
         subfg!*
         tstack!*
         ws);

% !*KEEPSQRTS causes SQRT rather than EXPT to be used;

!*convert := t;

put('simpcount!*,'initl,0);

initl!* := union('(simpcount!*),initl!*);

simplimit!* := 1000;

flagop noncom;

symbolic procedure simp!* u;
   begin scalar !*asymp!*,x;
        if eqcar(u,'!*sq) and caddr u then return cadr u;
        x := mul!* . !*sub2;    %save current environment;
        mul!* := nil;
        u:= simp u;
        for each j in mul!* do u:= apply1(j,u);
        mul!* := car x;
        u := subs2 u;
        if !*rationalize then u := rationalizesq u;
        !*sub2 := cdr x;
        % If any leading terms have cancelled, a gcd check is required.
        if !*asymp!* and !*rationalize then u := gcdchk u;
        return u
   end;

symbolic procedure subs2 u;
   begin scalar xexp,v,w;
        if null subfg!* then return u
         else if !*sub2 or powlis1!* then u := subs2q u;
        if null !*match or null numr u then return u
         else if null !*exp
          then <<xexp:= t; !*exp := t; v := u; w := u := resimp u>>;
        u := subs3q u;
        if xexp then <<!*exp := nil; if u=w then u := v>>;
        return u
   end;

symbolic procedure simp u;
   begin scalar x;
        if simpcount!*>simplimit!*
         then <<simpcount!* := 0;
                rederr "Simplification recursion too deep">>
         else if eqcar(u,'!*sq) and caddr u then return cadr u
         else if null !*uncached and (x := assoc(u,alglist!*))
          then return <<if cadr x then !*sub2 := t; cddr x>>;
        simpcount!* := simpcount!*+1;
        if atom u then return !*ssave(simpatom u,u)
         else if not idp car u
          then if idp caar u and (x := get(caar u,'name))
                 then return !*ssave(u,u)     %%% not yet correct
                else errpri2(u,t)
         else if flagp(car u,'opfn)
          then if getrtype(x := opfneval u) then typerr(u,"scalar")
                else return !*ssave(simp x,u)
         else if x := get(car u,'psopfn)
          then if getrtype(x := apply1(x,cdr u)) then typerr(u,"scalar")
                else if x=u then return !*ssave(!*k2q x,u)
                else return !*ssave(simp x,u)
         else if x := get(car u,'polyfn)
          then return !*ssave(!*f2q apply(x,
                        for each j in cdr u collect !*q2f simp!* j),
                        u)
         else if get(car u,'opmtch)
                and not(get(car u,'simpfn) eq 'simpiden)
                and (x := opmtch revop1 u)
          then return !*ssave(simp x,u)
         else if x := get(car u,'simpfn)
          then return !*ssave(if flagp(car u,'full) or x eq 'simpiden
                        then apply1(x,u)
                       else apply1(x,cdr u),u)
         else if (x := get(car u,'rtype)) and (x := get(x,'getelemfn))
          then return !*ssave(simp apply1(x,u),u)
         else if flagp(car u,'boolean) or get(car u,'infix)
          then typerr(if x := get(car u,'prtch) then x else car u,
                      "algebraic operator")
         else if flagp(car u,'nochange)
          then return !*ssave(simp eval u,u)
         else if get(car u,'psopfn) then typerr(u,"scalar")
         else <<redmsg(car u,"operator");
                mkop car u;
                return !*ssave(simp u,u)>>;
   end;

put('array,'getelemfn,'getelv);

put('array,'setelemfn,'setelv);

symbolic procedure getinfix u;
   %finds infix symbol for U if it exists;
   begin scalar x; return if x := get(u,'prtch) then x else u end;

symbolic procedure !*ssave(u,v);
   % We keep sub2!* as well, since there may be an unsubstituted
   % power in U.
   begin
      if not !*uncached
        then alglist!* := (v . (!*sub2 . u)) . alglist!*;
      simpcount!* := simpcount!*-1;
      return u
   end;

symbolic procedure numlis u;
   null u or (numberp car u and numlis cdr u);

symbolic procedure simpatom u;
   if null u then nil ./ 1
    else if numberp u 
     then if zerop u then nil ./ 1
           else if not fixp u
            then !*d2q int!-equiv!-chk if null dmode!* then mkrat u
                  else if dmode!* eq '!:ft!: then mkfloat u
                  else apply1(get('!:ft!:,dmode!*),mkfloat u)
             % we assume that a non-fixp number is a float.
           else if flagp(dmode!*,'convert)
            then !*d2q int!-equiv!-chk apply1(get(dmode!*,'i2d),u)
           else u ./ 1
%   else if not idp u then typerr(u,"identifier")
    else if flagp(u,'share) then simp eval u
    else begin scalar z;
      if z := get(u,'idvalfn) then return apply1(z,u)
       else if !*numval and dmode!* and flagp(u,'constant)
          and (z := get(u,dmode!*))
          and not errorp(z := errorset(list('apply,mkquote z,nil),
                         nil,nil))
        then return !*d2q int!-equiv!-chk car z
       else if getrtype u then typerr(u,'scalar)
       else return mksq(u,1)
   end;

flag('(e pi),'constant);

symbolic procedure mkrat u;
   begin scalar x;
      x := !*ft2rn mkfloat u;
      msgpri(nil,u,"represented by",
             if atom x then x else list('quotient,cadr x,cddr x),
             nil);
      return x
   end;

symbolic procedure mkop u;
   begin scalar x;
        if null u then typerr("Local variable","operator")
         else if (x := gettype u) eq 'operator
          then lprim list(u,"already defined as operator")
         else if x and not x eq 'procedure then typerr(u,'operator)
         else if u memq frlis!* then typerr(u,"free variable")
         else put(u,'simpfn,'simpiden)
   end;

symbolic procedure operatorp u;
    gettype u eq 'operator;

symbolic procedure simpcar u;
   simp car u;

put('quote,'simpfn,'simpcar);

symbolic procedure share u;
   begin scalar y;
      for each x in u do
         if not idp x then typerr(x,"id")
          else <<global list x;
                 if y := get(x,'avalue) then set(x,cadr y);
                 flag(list x,'share)>>
   end;

rlistat '(share);

flag('(ws !*mode),'share);


% ***** SIMPLIFICATION FUNCTIONS FOR EXPLICIT OPERATORS *****

symbolic procedure simpabs u;
   (lambda x; absf!* numr x ./ denr x) simpcar u;

put('abs,'simpfn,'simpabs);

symbolic procedure simpexpon u;
   % Exponents must not use non-integer arithmetic unless NUMVAL is on,
   % in which case DOMAINVALCHK must know the mode.
   if !*numval and not(dmode!* eq '!:mod!:) then simp!* u
    else begin scalar dmode!*,alglist!*; return simp!* u; end;

symbolic procedure simpexpt u;
   begin scalar flg,m,n,x,y;
        n := simpexpon carx(cdr u,'expt);
        u := car u;
    a:  if onep u then return 1 ./ 1;
        m := numr n;
        if not domainp m or not domainp denr n then go to nonumexp
         else if null m
          then return if numberp u and zerop u
                        then rederr " 0**0 formed"
                       else 1 ./ 1;
        x := simp u;
           %we could use simp!* here, except that it messes up the
           %handling of gamma matrix expressions;
        if null numr x then return nil ./ 1
         else if atom m and m>0 and denr n=1 and domainp numr x
                 and denr x=1
          then return !*d2q if atom numr x then numr x**m
                             else int!-equiv!-chk !:expt(numr x,m)
         else if y := domainvalchk('expt,list(x,n))
          then return y
         else if not atom m or denr n neq 1 then go to nonumexp
         else if not m<0 then return exptsq(x,m)
         else if !*mcd then return invsq exptsq(x,-m)
         else return expsq(x,m);   %using OFF EXP code here;
                %there may be a pattern matching problem though;
    nonumexp:
        if onep u then return 1 ./ 1
         else if atom u then go to a2
         else if car u eq 'times
          then <<n := prepsq n;
                 x := 1 ./ 1;
                 for each z in cdr u do
                   x := multsq(simpexpt list(z,n),x);
                 return x>>
         else if car u eq 'quotient
          then <<if not flg and !*mcd then go to a2;
                 n := prepsq n;
                 return multsq(simpexpt list(cadr u,n),
                          simpexpt list(caddr u,list('minus,n)))>>
         else if car u eq 'expt
          then <<n := multsq(simp caddr u,n);
                 if !*precise
                    and numberp caddr u and evenp caddr u
                    and numberp numr n and not evenp numr n
                   then u := list('abs,cadr u)
                  else u := cadr u;
                 x := nil;
                 go to a>>
         else if car u eq 'sqrt and not !*keepsqrts
          then <<n := multsq(1 ./ 2,n);
                 u := cadr u;
                 x := nil;
                 go to a>>
         else if car u eq 'minus and numberp m and denr n=1
          then return multsq(simpexpt list(-1,m),
                             simpexpt list(cadr u,m));
    a2: if null flg
          then <<flg := t;
                 u := prepsq if null x then (x := simp!* u) else x;
                 go to nonumexp>>
         else if numberp u and zerop u then return nil ./ 1
         else if not numberp m then m := prepf m;
        n := prepf cdr n;
        if m memq frlis!* and n=1 then return list ((u . m) . 1) . 1;
           %"power" is not unique here;
        if !*mcd or cdr x neq 1 or not numberp m or n neq 1
          or atom u then go to c
   %     else if minusf car x then return multsq(simpexpt list(-1,m),
   %                            simpexpt list(prepf negf car x,m));
         else if car u eq 'plus or not !*mcd and n=1
          then return mksq(u,m); %to make pattern matching work.
    c:% if !*numval and domaintypep u and n=1
      %    and (y := domainvalchk list('expt,u,m))  *** not correct now
      %   then return y else
        return simpx1(u,m,n)
   end;

% symbolic procedure intexpt(u,n);
%    if null current!-modulus or null(dmode!* eq '!:mod!:) then u**n
%         % I'm not sure we need both here.
%     else if n<0
%      then general!-modular!-expt(general!-modular!-recip u,-n)
%     else general!-modular!-expt(u,n);

put('expt,'simpfn,'simpexpt);

symbolic procedure simpx1(u,m,n);
   %U,M and N are prefix expressions;
   %Value is the standard quotient expression for U**(M/N);
        begin scalar flg,x,z;
        if numberp m and numberp n
           or null(smemqlp(frlis!*,m) or smemqlp(frlis!*,n))
          then go to a;
        % exptp!* := t;
        return mksq(list('expt,u,if n=1 then m
                                   else list('quotient,m,n)),1);
    a:  if numberp m then if minusp m then <<m := -m; go to mns>>
                           else if fixp m then go to e
                           else go to b
         else if atom m then go to b
         else if car m eq 'minus then <<m := cadr m; go to mns>>
         else if car m eq 'plus then go to pls
         else if car m eq 'times and numberp cadr m and fixp cadr m
                and numberp n
          then go to tms;
    b:  z := 1;
    c:  if idp u and not flagp(u,'used!*) then flag(list u,'used!*);
        if u = '(minus 1) 
               and n=1
               and null numr simp list('difference,m,'(quotient 1 2))
         then return simp 'i;
        u := list('expt,u,if n=1 then m else list('quotient,m,n));
        if not u member exptl!* then exptl!* := u . exptl!*;
    d:  return mksq(u,if flg then -z else z); %U is already in lowest
        %terms;
    e:  if numberp n and fixp n then go to int;
        z := m;
        m := 1;
        go to c;
    mns: %if numberp m and numberp n and !*rationalizeflag
         %  then return multsq(simpx1(u,n-m,n),invsq simp u) else
        if !*mcd then return invsq simpx1(u,m,n);
        flg := not flg;
        go to a;
    pls: z := 1 ./ 1;
    pl1: m := cdr m;
        if null m then return z;
        z := multsq(simpexpt list(u,
                        list('quotient,if flg then list('minus,car m)
                                        else car m,n)),
                    z);
        go to pl1;
    tms: z := gcdn(n,cadr m);
        n := n/z;
        z := cadr m/z;
        m := retimes cddr m;
        go to c;
    int:z := divide(m,n);
        if cdr z<0 then z:= (car z - 1) . (cdr z+n);
        x := simpexpt list(u,car z);
        if cdr z=0 then return x
         else if n=2 then return multsq(x,simpsqrt list u)
         else return multsq(x,exptsq(simprad(simp!* u,n),cdr z))
   end;

symbolic procedure expsq(u,n);
   % Raises standard quotient u to negative power n with exp off.
   multf(expf(numr u,n),mksfpf(denr u,-n)) ./ 1;

symbolic procedure expf(u,n);
   %U is a standard form. Value is standard form of U raised to
   %negative integer power N. MCD is assumed off;
   %what if U is invertable?;
   if null u then nil
    else if u=1 then u
    else if atom u then mkrn(1,u**(-n))
    else if domainp u then !:expt(u,n)
    else if red u then mksp!*(u,n)
    else (lambda x; if x>0 and sfp mvar u
                     then multf(exptf(mvar u,x),expf(lc u,n))
                    else mvar u .** x .* expf(lc u,n) .+ nil)
         (ldeg u*n);

symbolic procedure simprad(u,n);
   %simplifies radical expressions;
   begin scalar x,y,z;
      x := radf(numr u,n);
      y := radf(denr u,n);
      z := multsq(car x ./ 1,1 ./ car y);
      z := multsq(multsq(mkrootlsq(cdr x,n),invsq mkrootlsq(cdr y,n)),
                  z);
      return z
   end;

symbolic procedure mkrootlsq(u,n);
   %U is a list of prefix expressions, N an integer.
   %Value is standard quotient for U**(1/N);
   % NOTE we need the REVAL call so that PREPSQXX is properly called on
   % the argument for consistency with the pattern matcher.  Otherwise
   % for all x,y let sqrt(x)*sqrt(y)=sqrt(x*y); sqrt(30*(l+1))*sqrt 5;
   % goes into an infinite loop.
   if null u then !*d2q 1
    else if null !*reduced then mkrootsq(reval retimes u,n)
    else mkrootlsq1(u,n);

symbolic procedure mkrootlsq1(u,n);
   if null u then !*d2q 1
    else multsq(mkrootsq(car u,n),mkrootlsq1(cdr u,n));

symbolic procedure mkrootsq(u,n);
   %U is a prefix expression, N an integer.
   %Value is a standard quotient for U**(1/N);
   if u=1 then !*d2q 1
    else if n=2 and (u= -1 or u= '(minus 1)) then simp 'i
    else if eqcar(u,'expt) and fixp caddr u
        then mksq(if n=2 then mksqrt cadr u
                   else list('expt,cadr u,list('quotient,1,n)),caddr u)
       else mksq(if n=2 then mksqrt u
                  else list('expt,u,list('quotient,1,n)),1);


comment The following three procedures return a partitioned root
        expression, which is a dotted pair of integral part (a standard
        form) and radical part (a list of prefix expressions). The whole
        structure represents U**(1/N);

symbolic procedure radf(u,n);
   %U is a standard form, N a positive integer. Value is a partitioned
   %root expression for U**(1/N);
   begin scalar ipart,rpart,x,y,z,!*gcd;
      if null u then return list u;
      !*gcd := t;
      ipart := 1;
      z := 1;
      while not domainp u do
         <<y := comfac u;
           if car y
             then <<x := divide(pdeg car y,n);
                    if car x neq 0
                      then ipart:=multf(!*p2f if null !*precise
                                                 or evenp car x
                                                then mvar u .** car x
                                         else mksp(list('abs,mvar u),
                                                   car x),
                                        ipart);
                    if cdr x neq 0
                      then rpart :=
                           mkexpt(if sfp mvar u then prepf mvar u
                                   else mvar u,cdr x) . rpart>>;
           x := quotf1(u,comfac!-to!-poly y);
           u := cdr y;
           if !*reduced and minusf x
             then <<x := negf x; u := negf u>>;
           if flagp(dmode!*,'field) then
              <<y := lnc x; 
                if y neq 1 then <<x := quotf1(x,y); z := multd(y,z)>>>>;
           if x neq 1
             then <<x := radf1(sqfrf x,n);
           ipart := multf(car x,ipart);
           rpart := append(rpart,cdr x)>>>>;
      if u neq 1
        then <<x := radd(u,n);
               ipart := multf(car x,ipart);
               rpart := append(cdr x,rpart)>>;
      if z neq 1
        then if !*numval
                and (y := domainvalchk('expt,
                                       list(!*f2q z,!*f2q !:recip n)))
               then ipart := multd(!*q2f y,ipart)
              else rpart := prepf z . rpart;  % was aconc(rpart,z)
      return ipart . rpart
   end;

symbolic procedure radf1(u,n);
   %U is a form_power list, N a positive integer. Value is a
   %partitioned root expression for U**(1/N);
   begin scalar ipart,rpart,x;
      ipart := 1;
      for each z in u do
         <<x := divide(cdr z,n);
           if not(car x=0)
                    then ipart := multf(exptf(car z,car x),ipart);
                  if not(cdr x=0)
                    then rpart := mkexpt(prepsq!*(car z ./ 1),cdr x)
                                   . rpart>>;
      return ipart . rpart
   end;

symbolic procedure radd(u,n);
   %U is a domain element, N an integer.
   %Value is a partitioned root expression for U**(1/N);
   begin scalar bool,ipart,x;
      if not atom u then return list(1,prepf u);
%      then if x := integer!-equiv u then u := x
%            else return list(1,prepf u);
      if u<0 and evenp n then <<bool := t; u := -u>>;
      x := nrootn(u,n);
      if bool then if !*reduced and n=2
                     then <<ipart := multd(car x,!*k2f 'i);
                            x := cdr x>>
                    else <<ipart := car x; x := -cdr x>>
       else <<ipart := car x; x := cdr x>>;
      return if x=1 then list ipart else list(ipart,x)
   end;

symbolic procedure iroot(m,n);
   %M and N are positive integers.
   %If M**(1/N) is an integer, this value is returned, otherwise NIL;
   begin scalar x,x1,bk;
      if m=0 then return m;
      x := 10**iroot!-ceiling(lengthc m,n);   %first guess;
   a: x1 := x**(n-1);
      bk := x-m/x1;
      if bk<0 then return nil
       else if bk=0 then return if x1*x=m then x else nil;
      x := x - iroot!-ceiling(bk,n);
      go to a
   end;

symbolic procedure iroot!-ceiling(m,n);
   %M and N are positive integers. Value is ceiling of (M/N) (i.e.,
   %least integer greater or equal to M/N);
   (lambda x; if cdr x=0 then car x else car x+1) divide(m,n);

symbolic procedure mkexpt(u,n);
   if n=1 then u else list('expt,u,n);

symbolic procedure nrootn(n,x); 
   %N is an integer, X a positive integer. Value is a pair
   %of integers I,J such that I*J**(1/X)=N**(1/X);
   begin scalar i,j,r,signn; 
      r := 1; 
      if n<0 then <<n := -n; if evenp x then signn := t else r := -1>>;
      j := 2**x; 
      while remainder(n,j)=0 do <<n := n/j; r := r*2>>; 
      i := 3; 
      j := 3**x; 
      while j<=n do 
         <<while remainder(n,j)=0 do <<n := n/j; r := r*i>>; 
           if remainder(i,3)=1 then i := i+4 else i := i+2; 
           j := i**x>>; 
      if signn then n := -n; 
      return r . n
   end;

symbolic procedure simpiden u;
   begin scalar bool,fn,x,y,z;
        fn := car u;
        x := for each j in cdr u collect aeval j;
        u := fn . for each j in x collect
                      if eqcar(j,'!*sq) then prepsqxx cadr j
                       else if numberp j then j
                       else <<bool := t; j>>;
        if flagp(fn,'noncom) then ncmp!* := t;
        if null subfg!* then go to c
         else if flagp(fn,'linear) and (z := formlnr u) neq u
          then return simp z
         else if z := opmtch u then return simp z
         else if z := get(car u,'opvalfn) then return apply1(z,u)
         else if null bool and (z := domainvalchk(fn,
                                 for each j in x collect simp j))
          then return z;
    c:  if flagp(fn,'symmetric) then u := fn . ordn cdr u
         else if flagp(fn,'antisymmetric)
          then <<if repeats cdr u then return (nil ./ 1)
                  else if not permp(z:= ordn cdr u,cdr u) then y := t;
                 u := car u . z>>;
        u := mksq(u,1);
        return if y then negsq u else u
   end;

symbolic procedure domainvalchk(opr,args);
   % OPR is an operator, and ARGS its arguments as standard quotients.
   % If OPR . ARGS can be evaluated to a constant, result is the value,
   % otherwise NIL;
   begin scalar v,w,x,y,z;
      v := dmode!*;
      if null v or null !*numval or null(w := get(opr,dmode!*))
        then return nil;
   a: if null args
        then return if errorp(w := errorset(list('apply,
                                        mkquote w,mkquote reversip!* y),
                                       nil,nil))
                       or getd 'complexp and complexp car w
                      then nil
                     else if not domainp car w then car w ./ 1
                     else !*d2q int!-equiv!-chk car w
       else if not domainp(x := numr car args) or denr car args neq 1
        then return nil;
      if atom x
        then z := apply1(get(v,'i2d),if null x then 0 else x)
       else if car x eq v then z := x
       else if not(z := get(car x,v)) then return nil
       else z := apply1(z,x);
      y := z . y;
      args := cdr args;
      go to a
   end;

symbolic procedure simpdiff u;
   addsq(simpcar u,simpminus cdr u);

put('difference,'simpfn,'simpdiff);

symbolic procedure simpminus u;
   negsq simp carx(u,'minus);

put('minus,'simpfn,'simpminus);

symbolic procedure simpplus u;
   begin scalar z;
        z := nil ./ 1;
    a:  if null u then return z;
        z := addsq(simpcar u,z);
        u := cdr u;
        go to a
   end;

put('plus,'simpfn,'simpplus);

symbolic procedure simpquot u;
   multsq(simpcar u,simprecip cdr u);

put('quotient,'simpfn,'simpquot);

symbolic procedure simprecip u;
   if null !*mcd then simpexpt list(carx(u,'recip),-1)
    else invsq simp carx(u,'recip);

put('recip,'simpfn,'simprecip);

symbolic procedure simpset u;
  begin scalar x;
     if not idp (x := !*q2a simp!* car u) or null x
       then typerr(x,"set variable");
     let0 list(list('equal,x,mk!*sq(u := simp!* cadr u)));
     return u
  end;

put ('set, 'simpfn, 'simpset);

symbolic procedure simpsqrt u;
   begin scalar x,y;
      x := xsimp car u;
      return if denr x=1 and domainp numr x and !:minusp numr x
               then if numr x=-1 then simp 'i
                     else multsq(simp 'i,
                                 simpsqrt list prepd !:minus numr x)
              else if y := domainvalchk('expt,
                                        list(x,!*f2q mkfloat 0.5))
               then y
              else simprad(x,2)
   end;

symbolic procedure xsimp u; expchk simp!* u;

symbolic procedure simptimes u;
   begin scalar x,y;
        if tstack!* neq 0 or null mul!* then go to a0;
        y := mul!*;
        mul!* := nil;
    a0: tstack!* := tstack!*+1;
        x := simpcar u;
    a:  u := cdr u;
        if null numr x then go to c
         else if null u then go to b;
        x := multsq(x,simpcar u);
        go to a;
    b:  if null mul!* or tstack!*>1 then go to c;
        x:= apply1(car mul!*,x);
        alglist!* := nil;   % since we may need MUL!* set again;
        mul!*:= cdr mul!*;
        go to b;
    c:  tstack!* := tstack!*-1;
        if tstack!* = 0 then mul!* := y;
        return x;
   end;

put('times,'simpfn,'simptimes);

symbolic procedure resimp u;
   %U is a standard quotient.
   %Value is the resimplified standard quotient;
   quotsq(subf1(numr u,nil),subf1(denr u,nil));

symbolic procedure simp!*sq u;
   if null cadr u then resimp car u else car u;

put('!*sq,'simpfn,'simp!*sq);

endmodule;


module dmode; % Functions for defining and using poly domain modes.

% Author: Anthony C. Hearn;

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*complex dmode!*);

global '(!*convert domainlist!*);

switch convert;

symbolic procedure initdmode u;
   % Checks that U is a valid domain mode, and sets up appropriate
   % interfaces to the system.
   begin
      dmodechk u;
      put(u,'simpfg,list(list(t,list('setdmode,mkquote u,t)),
                         list(nil,list('setdmode,mkquote u,nil))))
   end;

symbolic procedure setdmode(u,bool);
   % Sets polynomial domain mode.  If bool is NIL, integers are used,
   % or in the case of complex, set to the lower domain.
   % Otherwise mode is set to u, or derived from it.
   if null get(u,'tag)
     then rederr list("Domain mode error:",u,"is not a domain mode")
    else if u eq 'complex or !*complex then setcmpxmode(u,bool)
    else setdmode1(u,bool);

symbolic procedure setdmode1(u,bool);
   begin scalar x,y;
      x := get(u,'tag);
      y := dmode!*;
      if null bool
        then return if null y then nil
                     else <<rmsubs(); dmode!* := nil; get(y,'dname)>>
       else if x eq y then return x;
      % Now make sure there are no other domain switches left on.
      for each j in domainlist!* do
         if j neq '!:gi!: then
         set(intern compress append(explode '!*,explode get(j,'dname)),
             nil);
      rmsubs();
      y := get(y,'dname);
      if y then lprim list("Domain mode",y,"changed to",u);
      if u := get(u,'module!-name) then load!-module u;
      dmode!* := x;
      return y
   end;

symbolic procedure dmodechk u;
   %checks to see if U has complete specification for a domain mode;
   begin scalar z;
      if not(z := get(u,'tag))
        then rederr list("Domain mode error:","No tag for",z)
       else if not(get(z,'dname) eq u)
        then rederr list("Domain mode error:",
                         "Inconsistent or missing DNAME for",z)
       else if not z memq domainlist!*
        then rederr list("Domain mode error:",
                         z,"not on domain list");
      u := z;
      for each x in domainlist!*
        do if u=x then nil
            else <<if not get(u,x) then put(u,x,mkdmoderr(u,x));
                   if not get(x,u) then put(x,u,mkdmoderr(x,u))>>;
%            then rederr list("Domain mode error:",
%                          "No conversion defined between",U,"and",X);
      z := '(plus difference times quotient i2d prepfn prifn
             minusp onep zerop);
      if not flagp(u,'field) then z := 'divide . 'gcd . z;
      for each x in z do if not get(u,x)
             then rederr list("Domain mode error:",
                              x,"is not defined for",u)
   end;

symbolic procedure dmoderr(u,v);
   rederr list("Conversion between",get(u,'dname),
               "and",get(v,'dname),"not defined");

symbolic procedure mkdmoderr(u,v);
   list('lambda,'(!*x!*),list('dmoderr,mkquote u,mkquote v));


comment *** General Support Functions ***;

symbolic procedure fieldp u;
   %U is a domain element. Value is T if U is invertable, NIL
   %otherwise;
   not atom u and flagp(car u,'field);

symbolic procedure !:expt(u,n);
   % Raises domain element U to integer power N.  Value is a domain
   % element;
   if null u then if n=0 then rederr "0/0 formed" else nil
    else if n=0 then 1
    else if n=1 then u
    else if u=1 then 1
    else if n<0
     then !:recip !:expt(if not fieldp u then mkratnum u else u,-n)
    else if atom u then u**n
    else if car u eq '!:mod!:
     then (lambda x; if x=0 then nil else if x=1 then 1 else car u . x)
           general!-modular!-expt(cdr u,n)
    else begin scalar v,w,x;
      v := apply1(get(car u,'i2d),1);   %unit element;
      x := get(car u,'times);
   a: w := divide(n,2);
      if cdr w=1 then v := apply2(x,u,v);
      if car w=0 then return v;
      u := apply2(x,u,u);
      n := car w;
      go to a
   end;

symbolic procedure !:minus u;
   %U is a domain element. Value is -U;
   if atom u then -u else dcombine(u,-1,'times);

symbolic procedure !:minusp u;
   if atom u then minusp u else apply1(get(car u,'minusp),u);

symbolic procedure minuschk u;
   if eqcar(u,'minus)
      and (numberp cadr u
         or not atom cadr u and idp caadr u and get(caadr u,'dname))
     then !:minus cadr u
    else u;

symbolic procedure !:recip u;
   %U is an invertable domain element. Value is 1/U;
   begin
      if numberp u
        then if abs u=1 then return u
       else if null dmode!* then return mkrn(1,u)
       else if dmode!* eq '!:ft!: then return !*rn2ft mkrn(1,u)
       else u := apply1(get(dmode!*,'i2d),u);
      return dcombine(1,u,'quotient)
   end;

symbolic procedure dcombine(u,v,fn);
   %U and V are domain elements, but not both atoms (integers).
   %FN is a binary function on domain elements;
   %Value is the domain element representing FN(U,V);
   int!-equiv!-chk if atom u
        then apply2(get(car v,fn),apply1(get(car v,'i2d),u),v)
       else if atom v
        then apply2(get(car u,fn),u,apply1(get(car u,'i2d),v))
       else if car u eq car v then apply2(get(car u,fn),u,v)
       else begin scalar x;
        if not(x := get(car u,car v))
           then <<v := apply1(get(car v,car u),v);
                  x := get(car u,fn)>>
          else <<u := apply1(x,u); x := get(car v,fn)>>;
         return apply2(x,u,v)
        end;

symbolic procedure int!-equiv!-chk u;
   % U is a domain element. If U can be converted to 0, result is NIL,
   % if U can be converted to 1, result is 1,
   % if *convert is on and U can be converted to an integer, result
   % is that integer. Otherwise, U is returned.
   % In most cases, U will be structured.
   begin scalar x;
      if atom u then return u;
      if apply1(get(car u,'zerop),u) then return nil
       else if apply1(get(car u,'onep),u) then return 1
       else if null !*convert then return u
       else if (x := get(car u,'intequivfn)) and (x := apply1(x,u))
        then return x
       else return u
   end;


comment
   *** Description of Definition Requirements for Domain arithmetics ***

Syntactically, such elements have the following form:

<domain element>:=NIL|integer|<structured domain element>

<structured domain element> ::=
        (<domain identifier>.<domain structure>),

where NIL represents the domain element zero.

To introduce a new domain, we need to define:

1) A conversion function from integer to the given mode, stored under
   the attribute I2D.

2) A conversion function from new mode to or from every other mode.

3) Particular instances of the binary operations +,- and * for this
   mode.

4) Particular instances of ZEROP, ONEP and MINUSP for this mode.
   Although ONEP could be defined in terms of ZEROP, we believe it is
   more efficient to have both functions (though this has not been
   thoroughly tested).

5) If domain is a field, a quotient must be defined.  If domain is a
   ring, a gcd and divide must be defined, and also a quotient
   function which returns NIL if the division fails.

6) A printing function for this mode that can print the object in a
   linear form. The printing function is associated with the attribute
   PRIFN.  This printing function should enclose the printed expression
   in parentheses if its top level operator has a precedence greater
   than +.

7) A function to convert structure to an appropriate prefix form.

8) A reading function for this mode.

9) A DNAME property for the tag, and a TAG property for the DNAME

To facilitate this, all such modes should be listed in the global
variable DOMAINLIST!*.

The following rules should also be followed when introducing new
domains:

Some modes, such as modular arithmetic, require that integers be
converted to domain elements when input or addition or multiplication
of such objects occurs.  Such modes should be flagged "convert".

In ALL cases it is assumed that any domain element that tests true to
the zero test can be converted into an explicit 0 (represented by NIL),
and any that tests true to the onep test can be converted into an
explicit 1.  If the domain allows for the conversion of other elements
into equivalent integers, a function under the optional attribute
INTEQUIVFN may also be defined to effect this conversion.

The result of an arithmetic (as opposed to a boolean) operation on
structured domain elements with the same tag must be another structured
domain element with the same tag.  In particular, a domain zero must be
returned as a tagged zero in that domain.

In some cases, it is possible to map functions on domain elements to
domain elements.  To provide for this capability in the complete
system, one can give such functions the domain tag as an indicator.
The results of this evaluation must be a tagged domain element (or an
integer?), but not necessarily an element from the same domain, or the
evaluation should abort with an error.  The error number associated
with this should be in the range 100-150;

endmodule;


module rational; % *** Tables for rational numbers ***;

% Author: Anthony C. Hearn;

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

global '(domainlist!*);

switch rational;

domainlist!* := union('(!:rn!:),domainlist!*);
put('rational,'tag,'!:rn!:);
put('!:rn!:,'dname,'rational);
flag('(!:rn!:),'field);
put('!:rn!:,'i2d,'!*i2rn);
put('!:rn!:,'minusp,'rnminusp!:);
put('!:rn!:,'plus,'rnplus!:);
put('!:rn!:,'times,'rntimes!:);
put('!:rn!:,'difference,'rndifference!:);
put('!:rn!:,'quotient,'rnquotient!:);
put('!:rn!:,'zerop,'rnzerop!:);
put('!:rn!:,'onep,'rnonep!:);
put('!:rn!:,'factorfn,'rnfactor!:);
put('!:rn!:,'prepfn,'rnprep!:);
put('!:rn!:,'prifn,'rnprin);
flag('(!:rn!:),'ratmode);

symbolic procedure mkratnum u;
   %U is a domain element. Value is equivalent rational number;
   if atom u then !*i2rn u else apply1(get(car u,'!:rn!:),u);

symbolic procedure mkrn(u,v);
   %converts two integers U and V into a rational number, an integer
   %or NIL;
   if v<0 then mkrn(-u,-v)
    else (lambda m; '!:rn!: . ((u/m) . (v/m))) gcdn(u,v);

symbolic procedure !*i2rn u;
   %converts integer U to rational number;
   '!:rn!: . (u . 1);

symbolic procedure rnminusp!: u; cadr u<0;

symbolic procedure rnplus!:(u,v);
   mkrn(cadr u*cddr v+cddr u*cadr v,cddr u*cddr v);

symbolic procedure rntimes!:(u,v);
   mkrn(cadr u*cadr v,cddr u*cddr v);

symbolic procedure rndifference!:(u,v);
   mkrn(cadr u*cddr v-cddr u*cadr v,cddr u*cddr v);

symbolic procedure rnquotient!:(u,v);
   mkrn(cadr u*cddr v,cddr u*cadr v);

symbolic procedure rnzerop!: u; cadr u=0;

symbolic procedure rnonep!: u; cadr u=1 and cddr u=1;

symbolic procedure rnfactor!: u;
   begin scalar x,y,dmode!*; integer m,n;
     x := subf(u,nil);
     y := factorf numr x;
     n := car y;
     dmode!* := '!:rn!:;
     y := for each j in cdr y collect
           <<n := n*(m := (lnc ckrn car j)**cdr j);
             quotfd(car j,m) . cdr j>>;
     return int!-equiv!-chk mkrn(n,denr x) . y
   end;

symbolic procedure rnprep!: u;
   % PREPF is called on arguments, since the LOWEST-TERMS code in extout
   % can create rational objects with structured arguments.
   (if cddr u=1 then x else list('quotient,x,prepf cddr u))
    where x = prepf cadr u;

symbolic procedure rnprin u; 
   <<prin2!* cadr u; prin2!* "/"; prin2!* cddr u>>;

initdmode 'rational;

endmodule;


module float; % *** Tables for floats ***.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

global '(domainlist!* ft!-tolerance!*);

switch float;

domainlist!* := union('(!:ft!:),domainlist!*);
put('float,'tag,'!:ft!:);
put('!:ft!:,'dname,'float);
flag('(!:ft!:),'field);
put('!:ft!:,'i2d,'!*i2ft);
put('!:ft!:,'!:rn!:,'!*ft2rn);
put('!:ft!:,'minusp,'ftminusp!:);
put('!:ft!:,'plus,'ftplus!:);
put('!:ft!:,'times,'fttimes!:);
put('!:ft!:,'difference,'ftdifference!:);
put('!:ft!:,'quotient,'ftquotient!:);
put('!:ft!:,'zerop,'ftzerop!:);
put('!:ft!:,'onep,'ftonep!:);
put('!:ft!:,'prepfn,'ftprep!:);
put('!:ft!:,'prifn,'floatprn);
put('!:ft!:,'cmpxtype,list '!:gf!:);
put('!:ft!:,'intequivfn,'ftintequiv);

symbolic procedure mkfloat u; '!:ft!: . u;

symbolic procedure !*i2ft u;
   %converts integer U to tagged floating point form;
   '!:ft!: . float u;

symbolic procedure !*ft2rn n;
   % Converts a floating point number N into a rational to the system
   % floating point precision.
   mkrn(car x,cdr x) where x = ft2rn1(cdr n,ft!-tolerance!*);

symbolic procedure ft2rn1(n,prec);
   begin scalar negp,a,p0,p1,q0,q1,w,flagg;
      if zerop n then return 0 . 1
       else if n<0 then <<negp := t; n := -n>>;
 top: a := fix n;
      n := n - float a;
      if not flagg
        then <<flagg := t; p0 := 1; p1 := a; q0 := 0; q1 := 1>>
       else <<w := p0 + a*p1; p0 := p1; p1 := w;
              w := q0 + a*q1; q0 := q1; q1 := w>>;
      if n<prec*a then return if negp then (-p1) . q1 else p1 . q1
       else if p1*q1*prec>1.0
        then return if negp then (-p0) . q0 else p0 . q0;
      n := 1.0/n;
      go to top
   end;

symbolic procedure !*rn2ft u;
   % Converts the (tagged) rational u/v into a (tagged) floating point
   % number to the system precision.
   mkfloat rn2ft1(cadr u,cddr u,ft!-tolerance!*);

symbolic procedure rn2ft1(u,v,prec);
   begin scalar negp,x,y,z;
      if v=0 then rederr "zero denominator"
       else if u=0 then return 0.0
       else if v<0 then <<u := -u; v := -v>>;
      if u<0 then <<negp := t; u := -u>>;
      x := 1.0;
      y := 0;
      z := 0.0;
      repeat
         <<z := y + z; y := divide(u,v); u := 10*cdr y;
           y := x*car y; x := x/10>>
        until u*x < prec*z;
      z := y + z;
      return if negp then -z else z
   end;

symbolic procedure ftminusp!: u; cdr u<0;

symbolic procedure ftplus!:(u,v);
%  car u . (lambda x; if abs x<0.000001*abs cdr u then 0.0 else x)
%           (cdr u+cdr v);
   car u . (cdr u+cdr v);

symbolic procedure fttimes!:(u,v); car u . (cdr u*cdr v);

symbolic procedure ftdifference!:(u,v); car u .(cdr u-cdr v);

symbolic procedure ftquotient!:(u,v); car u . (cdr u/cdr v);

symbolic procedure ftzerop!: u;
   abs cdr u < ft!-tolerance!*;

symbolic procedure ftonep!: u;
   abs(cdr u - 1.0) < ft!-tolerance!*;

symbolic procedure ftprep!: u; cdr u;

symbolic procedure floatprn u; prin2 cdr u;

symbolic procedure ftintequiv u;
   % Converts floating point number U to integer equivalent if within
   % precision of system.
   begin scalar x;
      u := cdr u;
      return if abs(u-(x := fix u)) < ft!-tolerance!* then x else nil
   end;

% The following square root function was written by Mary Ann Moore.

symbolic procedure sqrt n; sqrt!-float float n;

symbolic procedure sqrt!-float n;
% Simple Newton-Raphson floating point square root calculator.
  begin scalar scale,ans;
    if n=0.0 then return 0.0
    else if n<0.0 then rederr "SQRT!-FLOAT given negative argument";
    scale := 1.0; 
    % Detach the exponent by doing a sequence of multiplications
    % and divisions by powers of 2 until the remaining number is in
    % the range 1.0 to 4.0. On a binary machine the scaling should
    % not introduce any error at all;
    while n>256.0 do <<scale := scale*16.0; n := n/256.0>>;
    while n<1.0/256.0 do <<scale := scale/16.0; n := n*256.0>>;
    % Coarse scaled: now finish off the job.
    while n<1.0 do <<scale := scale/2.0; n := n*4.0>>;
    while n>4.0 do <<scale := scale*2.0; n := n/4.0>>;
    % 5 iterations get me as good a result as I can reasonably want
    % and it is cheaper  to do 5 always than to test for stopping
    % criteria.
    ans := 2.0;
    for i:=1:5 do ans := (ans+n/ans)/2.0;
    return ans*scale
  end;

initdmode 'float;


comment *** Entry points for the bigfloat package ***;

put('bigfloat,'simpfg,'((t (setdmode (quote bigfloat) t))
                        (nil (setdmode (quote bigfloat) nil))));

put('bigfloat,'tag,'!:bf!:);

switch bigfloat;

endmodule;


module polrep; % Arithmetic operations on standard forms and quotients.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*asymp!* !*exp !*gcd !*lcm !*mcd !*sub2 asymplis!* dmode!*);

global '(!*factor !*group ncmp!* powlis!* subfg!* wtl!*);

symbolic smacro procedure subtrsq(u,v); addsq(u,negsq v);

symbolic procedure addsq(u,v);
   %U and V are standard quotients.
   %Value is canonical sum of U and V;
   if null numr u then v
    else if null numr v then u
    else if denr u=1 and denr v=1 then addf(numr u,numr v) ./ 1
    else begin scalar x,y,z;
        if null !*exp then <<u := numr u ./ mkprod!* denr u;
                             v := numr v ./ mkprod!* denr v>>;
        if !*lcm then x := gcdf!*(denr u,denr v)
         else x := gcdf(denr u,denr v);
        z := canonsq(quotf(denr u,x) ./ quotf(denr v,x));
        y := addf(multf(denr z,numr u),multf(numr z,numr v));
        if null y then return nil ./ 1;
        z := multf(denr u,denr z);
        if x=1 then return y ./ z;     % ONEP
        x := gcdf(y,x);
        return if x=1 then y ./ z
                else canonsq(quotf(y,x) ./ quotf(z,x))
    end;

symbolic procedure multsq(u,v);
   %U and V are standard quotients.
   %Value is canonical product of U and V;
   if null numr u or null numr v then nil ./ 1
    else if denr u=1 and denr v=1 then multf(numr u,numr v) ./ 1
    else begin scalar x,y;
        x := gcdf(numr u,denr v);
        y := gcdf(numr v,denr u);
        return canonsq(multf(quotf(numr u,x),quotf(numr v,y))
                ./ multf(quotf(denr u,y),quotf(denr v,x)))
    end;

symbolic procedure negsq u;
   negf numr u ./ denr u;

smacro procedure multpq(u,v);
   multsq(!*p2q u,v);

symbolic procedure cancel u;
   %returns canonical form of non-canonical standard form U;
   if !*mcd or denr u=1 then multsq(numr u ./ 1,1 ./ denr u)
    else multsq(numr u ./ 1,simpexpt list(mk!*sq(denr u ./ 1),-1));


% ***** FUNCTIONS FOR ADDING AND MULTIPLYING STANDARD FORMS *****

symbolic smacro procedure peq(u,v);
   %tests for equality of powers U and V;
   u = v;

symbolic procedure addf(u,v);
   %U and V are standard forms. Value is standard form for U+V;
   if null u then v
    else if null v then u
    else if domainp u then addd(u,v)
    else if domainp v then addd(v,u)
    else if peq(lpow u,lpow v)
       then (lambda (x,y); if null x then y else lpow u .* x .+ y)
                (addf(lc u,lc v),addf(red u,red v))
    else if ordpp(lpow u,lpow v) then lt u .+ addf(red u,v)
    else lt v .+ addf(u,red v);

symbolic procedure addd(u,v);
   %U is a domain element, V a standard form.
   %Value is a standard form for U+V;
   if null v then u
    else if domainp v then adddm(u,v)
    else lt v .+ addd(u,red v);

symbolic procedure adddm(u,v);
   %U and V are both non-zero domain elements.
   %Value is standard form for U+V;
   if atom u and atom v
     then (lambda x; if null dmode!* or not flagp(dmode!*,'convert)
                       then !*n2f x
                      else int!-equiv!-chk
                              apply1(get(dmode!*,'i2d),x))
           plus2(u,v)
    else dcombine(u,v,'plus);

symbolic procedure domainp u; atom u or atom car u;

symbolic procedure noncomf u;
   if domainp u then nil
    else noncomp mvar u or noncomf lc u or noncomf red u;

symbolic procedure noncomp u; flagpcar(u,'noncom);

symbolic procedure multf(u,v);
   %U and V are standard forms.
   %Value is standard form for U*V;
   begin scalar ncmp,x,y;
    a:  if null u or null v then return nil
         else if u=1 then return v     % ONEP
         else if v=1 then return u     % ONEP
         else if domainp u then return multd(u,v)
         else if domainp v then return multd(v,u)
         else if not(!*exp or ncmp!* or wtl!* or x)
          then <<u := mkprod u; v := mkprod v; x := t; go to a>>;
        x := mvar u;
        y := mvar v;
        if (ncmp := noncomp y) and noncomp x then return multfnc(u,v)
         else if x eq y
          then <<x := mkspm(x,ldeg u+ldeg v);
                 y := addf(multf(red u,v),multf(!*t2f lt u,red v));
                 return if null x or null(u := multf(lc u,lc v))
                    then <<!*asymp!* := t; y>>
                   else if x=1 then addf(u,y)
                   else if null !*mcd then addf(!*t2f(x .* u),y)
                   else x .* u .+ y>>
         else if ordop(x,y) or ncmp and noncomf lc u
          then <<x := multf(lc u,v);
                 y := multf(red u,v);
                 return if null x then y else lpow u .* x .+ y>>;
        x := multf(u,lc v);
        y := multf(u,red v);
        return if null x then y else lpow v .* x .+ y
   end;

symbolic procedure multfnc(u,v);
   %returns canonical product of U and V, with both main vars non-
   %commutative;
   begin scalar x,y;
      x := multf(lc u,!*t2f lt v);
      return addf((if not domainp x and mvar x eq mvar u
                    then addf(if null (y := mkspm(mvar u,ldeg u+ldeg v))
                                then nil
                               else if y = 1 then lc x
                               else !*t2f(y .* lc x),
                            multf(!*p2f lpow u,red x))
                    else !*t2f(lpow u .* x)),
                  addf(multf(red u,v),multf(!*t2f lt u,red v)))
   end;

symbolic procedure multd(u,v);
   %U is a domain element, V a standard form.
   %Value is standard form for U*V;
   if null v then nil
    else if domainp v then multdm(u,v)
    else lpow v .* multd(u,lc v) .+ multd(u,red v);

symbolic procedure multdm(u,v);
   % U and V are both non-zero domain elements.
   % Value is standard form for U*V;
   if atom u and atom v
     then (lambda x; if null dmode!*
                        or not flagp(dmode!*,'convert) then x
                      else int!-equiv!-chk
                              apply1(get(dmode!*,'i2d),x))
           times2(u,v)
    else dcombine(u,v,'times);

smacro procedure multpf(u,v); multf(!*p2f u,v);

symbolic procedure mkprod u;
   begin scalar w,x,y,z,!*exp,!*sub2;
        if null u or kernlp u then return u;
        %first make sure there are no further simplifications;
        !*sub2 := t;
        if denr(x := subs2(u ./ 1)) = 1 and numr x neq u
          then <<u := numr x; if null u or kernlp u then return u>>;
        !*exp := t;
        w := ckrn u;
        u := quotf(u,w);
        x := expnd u;
        if null x or kernlp x then return multf(w,x);
        % After this point, U is not KERNLP.
        % The check below for *MCD was suggested by James Davenport.
        % Without it, on gcd; off mcd,exp; (x**2+2x+1)/x+1; loops
        % forever.
        if !*mcd and (!*factor or !*gcd) then y := fctrf x
          else <<y := ckrn x; x := quotf(x,y); y := list(y,x . 1)>>;
          if cdadr y>1 or cddr y
            then <<z := car y;
                   for each j in cdr y do
                      z := multf(mksp!*(car j,cdr j),z)>>
         else if not !*group and tmsf u>tmsf caadr y
          then z := multf(mksp!*(caadr y,cdadr y),car y)
         else z := mksp!*(u,1);
        return multf(w,z)
   end;

symbolic procedure mksp!*(u,n);
   % Returns a standard form for U**N. If U is a kernel product,
   % direct exponentiation is used.  Otherwise, U is first made
   % positive and then converted into a kernel.
   begin scalar b;
      if kernlp u then return exptf(u,n)
       else if minusf u then <<b := t; u := negf u>>;
      u := !*p2f mksp(u,n);
      return if b and not evenp n then negf u else u
   end;

put('!*sq,'lengthfn,'!*sqlength);

symbolic procedure !*sqlength u;
   (if denr car u=1 then x else x+termsf denr car u)
    where x = termsf numr car u;

symbolic procedure terms u;
%  <<lprim "Please use LENGTH instead"; termsf numr simp!* u>>;
   termsf numr simp!* u;

flag('(terms),'opfn);

flag('(terms),'noval);

symbolic procedure termsf u;
   % U is a standard form.
   % Value is number of terms in U (excluding kernel structure).
   begin integer n;
      while not domainp u do <<n := n + termsf lc u; u := red u>>;
      return if null u then n else n+1
   end;

symbolic procedure tmsf u;
   % U is a standard form.
   % Value is number of terms in U (including kernel structure).
   begin integer n; scalar x;
    % Integer declaration initializes N to 0.
      while not domainp u do
       <<n := n+(if sfp(x := mvar u) then tmsf x else 1)+tmsf!* lc u;
         if ldeg u neq 1 then if ldeg u=2 then n := n+1 else n := n+2;
         u := red u>>;   % Previously, if U was non-zero, we used to add
                         % one more here.
      return if null u then n else n+1
   end;

symbolic procedure tmsf!* u;
   if numberp u and abs fix u=1 then 0 else tmsf u; % Was tmsf u+1.

symbolic procedure tms u; tmsf numr simp!* u;

flag('(tms),'opfn);

flag('(tms),'noval);

symbolic procedure expnd u;
   if domainp u then u
    else addf(if not sfp mvar u or ldeg u<0
                then multpf(lpow u,expnd lc u)
        else multf(exptf(expnd mvar u,ldeg u),expnd lc u),
                        expnd red u);

symbolic procedure mkprod!* u;
   if domainp u then u else mkprod u;

symbolic procedure canprod(p,q);
   %P and Q are kernel product standard forms, value is P/Q;
   begin scalar v,w,x,y,z;
        if domainp q then return cancel(p ./ q);
      while not domainp p or not domainp q do
        if sfpf p then
                <<z := cprod1(mvar p,ldeg p,v,w);
                        v := car z; w := cdr z; p := lc p>>
         else if sfpf q then <<z := cprod1(mvar q,ldeg q,w,v);
                        w := car z; v := cdr z; q := lc q>>
         else if domainp p then <<y := lpow q . y; q := lc q>>
         else if domainp q then <<x := lpow p . x; p := lc p>>
         else <<x := lpow p . x; y := lpow q . y;
                p := lc p; q := lc q>>;
      v := reprod(v,reprod(x,p));
      w := reprod(w,reprod(y,q));
      if minusf w then <<v := negf v; w := negf w>>;
      w := cancel(v ./ w);
      v := numr w;
        if not domainp v and null red v and lc v=1     % ONEP
         and ldeg v=1 and sfp(x := mvar v)
        then v := x;
      return canonsq(v ./ denr w)
   end;

symbolic procedure sfpf u;
   not domainp u and sfp mvar u;

symbolic procedure sfp u;
   %determines if mvar U is a standard form;
   not atom u and not atom car u;

symbolic procedure reprod(u,v);
   %U is a list of powers,V a standard form;
   %value is product of terms in U with V;
   <<while u do <<v := multpf(car u,v); u := cdr u>>; v>>;

symbolic procedure cprod1(p,m,v,w);
   %U is a standard form, which occurs in a kernel raised to power M.
   %V is a list of powers multiplying P**M, W a list dividing it.
   %Value is a dotted pair of lists of powers after all possible kernels
   %have been cancelled;
   begin scalar z;
      z := cprod2(p,m,w,nil);
      w := cadr z;
      v := append(cddr z,v);
      z := cprod2(car z,m,v,t);
      v := cadr z;
      w := append(cddr z,w);
      if car z neq 1 then v := mksp(car z,m) . v;
      return v . w
   end;

symbolic procedure cprod2(p,m,u,b);
   %P and M are as in CPROD1. U is a list of powers. B is true if P**M
   %multiplies U, false if it divides.
   %Value has three parts: the first is the part of P which does not
   %have any common factors with U, the second a list of powers (plus
   %U) which multiply U, and the third a list of powers which divide U;
   %it is implicit here that the kernel standard forms are positive;
   begin scalar n,v,w,y,z;
      while u and p neq 1 do
        <<if (z := gcdf(p,caar u)) neq 1
            then
           <<p := quotf(p,z);
             y := quotf(caar u,z);
             if y neq 1 then v := mksp(y,cdar u) . v;
             if b then v := mksp(z,m+cdar u) . v
              else if (n := m-cdar u)>0 then w := mksp(z,n) . w
              else if n<0 then v := mksp(z,-n) . v>>
            else v := car u . v;
           u := cdr u>>;
      return (p . nconc!*(u,v) . w)
   end;

symbolic procedure mkspm(u,p);
   %U is a unique kernel, P an integer;
   %value is 1 if P=0, NIL if U**P is 0, else standard power of U**P;
   % should we add a check for NOT(U EQ K!*) in first line?
   if p=0 then 1
    else begin scalar x;
        if subfg!* and (x:= atsoc(u,asymplis!*)) and cdr x<=p
          then return nil;
        sub2chk u;
        return u .** p
   end;

symbolic procedure sub2chk u;
   %determines if kernel U is such that a power substitution is
   %necessary;
   if subfg!*
      and(atsoc(u,powlis!*) or not atom u and car u memq '(expt sqrt))
     then !*sub2 := t;

symbolic procedure negf u;
   multd(-1,u);


% ***** FUNCTIONS FOR DIVIDING STANDARD FORMS *****

symbolic procedure quotsq(u,v);
   multsq(u,invsq v);

symbolic procedure quotf!*(u,v);
   if null u then nil
    else (lambda x; if null x then errach list("DIVISION FAILED",u,v)
                         else x)
          quotf(u,v);

symbolic procedure quotf(u,v);
   begin scalar xexp;
        xexp := !*exp;
        !*exp := t;
        u := quotf1(u,v);
        !*exp := xexp;
        return u
   end;

symbolic procedure quotf1(p,q);
   %P and Q are standard forms
   %Value is the quotient of P and Q if it exists or NIL;
   if null p then nil
    else if p=q then 1
    else if q=1 then p
    else if domainp q then quotfd(p,q)
    else if domainp p then nil
    else if mvar p eq mvar q
     then begin scalar u,v,w,x,y,z,z1; integer n;
    a:if idp(u := rank p) or idp(v := rank q) or u<v then return nil;
        %the above IDP test is because of the possibility of a free
        %variable in the degree position from LET statements;
        u := lt!* p;
        v := lt!* q;
        w := mvar q;
        x := quotf1(tc u,tc v);
        if null x then return nil;
        n := tdeg u-tdeg v;
        if n neq 0 then y := w .** n;
        p := addf(p,multf(if n=0 then q
                               else multpf(y,q),negf x));
        %leading terms of P and Q do not cancel if MCD is off;
        %however, there may be a problem with off exp;
        if p and (domainp p or mvar p neq w) then return nil
         else if n=0 then go to b;
        z := aconc!*(z,y .* x);
        %provided we have a non-zero power of X, terms
        %come out in right order;
        if null p then return if z1 then nconc!*(z,z1) else z;
        go to a;
    b:  if null p then return nconc!*(z,x)
         else if !*mcd then return nil
         else z1 := x;
        go to a
   end
    else if ordop(mvar p,mvar q) then quotk(p,q)
    else nil;

symbolic procedure quotfd(p,q);
   % P is a standard form, Q a domain element.
   % Value is P/Q if exact division is possible, or NIL otherwise.
   begin scalar x;
      return if p=q then 1
              else if flagp(dmode!*,'field) and (x := !:recip q)
               then multd(x,p)
              else if domainp p then quotdd(p,q)
              else quotk(p,q)
   end;

symbolic procedure quotdd(u,v);
   % U and V are domain elements.  Value is U/V if division is exact,
   % NIL otherwise.
   if atom u then if atom v
                    then if remainder(u,v)=0 then u/v else nil
                   else quotdd(apply1(get(car v,'i2d),u),v)
    else if atom v then quotdd(u,apply1(get(car u,'i2d),v))
    else dcombine(u,v,'quotient);

symbolic procedure quotk(p,q);
   (lambda w;
      if w then if null red p then list (lpow p .* w)
                 else (lambda y;if y then lpow p .* w .+ y else nil)
                          quotf1(red p,q)
         else nil)
      quotf1(lc p,q);

symbolic procedure rank p;
   %P is a standard form
   %Value is the rank of P;
   if !*mcd then ldeg p
    else begin integer m,n; scalar y;
        n := ldeg p;
        y := mvar p;
    a:  m := ldeg p;
        if null red p then return n-m;
        p := red p;
        if degr(p,y)=0 then return if m<0 then if n<0 then -m
                else n-m else n;
        go to a
    end;

symbolic procedure lt!* p;
   %Returns true leading term of polynomial P;
   if !*mcd or ldeg p>0 then car p
    else begin scalar x,y;
        x := lt p;
        y := mvar p;
    a:  p := red p;
        if null p then return x
         else if degr(p,y)=0 then return (y . 0) .* p;
        go to a
   end;

symbolic procedure remf(u,v);
   %returns the remainder of U divided by V;
   cdr qremf(u,v);

put('remainder,'polyfn,'remf);

symbolic procedure qremf(u,v);
   %returns the quotient and remainder of U divided by V;
   begin integer n; scalar x,y,z;
        if domainp v then return qremd(u,v);
        z := list nil;   %final value;
    a:  if domainp u then return praddf(z,nil . u)
         else if mvar u eq mvar v
          then if (n := ldeg u-ldeg v)<0 then return praddf(z,nil . u)
                else <<x := qremf(lc u,lc v);
                y := multpf(lpow u,cdr x);
                z := praddf(z,(if n=0 then car x
                                else multpf(mvar u .** n,car x))
                                . y);
                u := if null car x then red u
                        else addf(addf(u,multf(if n=0 then v
                                        else multpf(mvar u .** n,v),
                                        negf car x)), negf y);
                go to a>>
         else if not ordop(mvar u,mvar v)
          then return praddf(z,nil . u);
        x := qremf(lc u,v);
        z := praddf(z,multpf(lpow u,car x) . multpf(lpow u,cdr x));
        u := red u;
        go to a
   end;

symbolic procedure praddf(u,v);
   %U and V are dotted pairs of standard forms;
   addf(car u,car v) . addf(cdr u,cdr v);

symbolic procedure qremd(u,v);
   %Returns a dotted pair of quotient and remainder of form U
   %divided by domain element V;
   if null u then u . u
    else if v=1 then list u
    else if flagp(dmode!*,'field) then list multd(!:recip v,u)
    else if domainp u then qremdd(u,v)
    else begin scalar x;
        x := qremf(lc u,v);
        return praddf(multpf(lpow u,car x) . multpf(lpow u,cdr x),
                        qremd(red u,v))
   end;

symbolic procedure qremdd(u,v);
   %returns a dotted pair of quotient and remainder of non-invertable
   %domain element U divided by non-invertable domain element V;
   if atom u and atom v then dividef(u,v) else dcombine(u,v,'divide);

symbolic procedure dividef(m,n);
   (lambda x; (if car x=0 then nil else car x).
                        if cdr x=0 then nil else cdr x)
   divide(m,n);

symbolic procedure lqremf(u,v);
   %returns a list of coeffs of powers of V in U, constant term first;
   begin scalar x,y;
      y := list u;
      while car(x := qremf(car y,v)) do y := car x . cdr x . cdr y;
      return reversip!* y
   end;

symbolic procedure minusf u;
   %U is a non-zero standard form.
   %Value is T if U has a negative leading numerical coeff,
   %NIL otherwise;
   if null u then nil
    else if domainp u
           then if atom u then u<0 else apply1(get(car u,'minusp),u)
    else minusf lc u;

symbolic procedure absf!* u;
   % Returns representation for absolute value of standard form U.
   (if domainp u then x else !*p2f mksp(list('abs,prepf x),1))
    where x = absf u;

symbolic procedure absf u;
   if minusf u then negf u else u;

symbolic procedure canonsq u;
   % U is a standard quotient.
   % Value is a standard quotient in which the leading power
   % of the denominator has a positive numerical coefficient and the
   % denominator is normalized where possible.
   if denr u=1 then u   % Used to be :ONEP
    else if null numr u then nil ./ 1
    else begin scalar x,y;
       % Check for non-trivial GCD if GCD is off, since an additional
       % factor may have been formed.
       if null !*gcd and (x := gcdf(numr u,denr u)) neq 1
         then u := quotf(numr u,x) ./ quotf(denr u,x);
       % See if we can remove numerical factor from denominator.
        x := lnc denr u;
        if x=1 then return u
         else if atom x then if minusp x
                               then <<u := negf numr u ./ negf denr u;
                                      x := -x>>
                              else nil
         else if apply1(get(car x,'minusp),x)
                               then <<u := negf numr u ./ negf denr u;
                                      x:= apply2(get(car x,'difference),
                                              apply1(get(car x,'i2d),0),
                                                     x)>>;
        if null dmode!* then return u
         else if flagp(dmode!*,'field)
          then <<
       % This section could be better coded if we required conversion
       % from rational to all field domains, but for the time being
       % we'll limit ourselves to floats.
               if atom x
                 then if dmode!* eq '!:ft!:
                        then return if atom numr u and atom denr u
                                 then !*rn2ft mkrn(numr u,denr u) ./ 1
                                else <<y := !*rn2ft mkrn(1,x);
                                       multd(y,numr u) ./
                                         multd(y,denr u)>>
                       else x := apply1(get(dmode!*,'i2d),x);
               y := dcombine(1,x,'quotient);
               if null y then errach list('canonsq,x);
               return multd(y,numr u) ./ multd(y,denr u)>>
         else if numberp x or not (y:= get(dmode!*,'units))
          then return u
         else return canonsq1(u,x,y)
   end;

symbolic procedure canonsq1(u,v,w);
   begin scalar z;
   a: if null w then return u;
      z := quotf1(v,caar w);
      if null z or not fixp z then <<w := cdr w; go to a>>;
      z := multf(denr u,cdar w);
      w := multf(numr u,cdar w);
      if minusf z then <<w := negf w; z := negf z>>;
      return w ./ z
   end;

symbolic procedure lnc u;
   % U is a standard form.  Value is the leading numerical coefficient.
   if null u then 0
    else if domainp u then u
    else lnc lc u;

symbolic procedure invsq u;
   begin
      if null numr u then rederr "Zero denominator"; 
      u := revpr u;
      if !*rationalize then u := gcdchk u; 
      % Since result may not be in lowest terms.
      return canonsq u
   end;

symbolic procedure gcdchk u;
   % Makes sure standard quotient u is in lowest terms.
   (if x neq 1 then quotf(numr u,x) ./ quotf(denr u,x) else u)
   where x = gcdf(numr u,denr u);

endmodule;


module gcdn;   % gcd of integers.

% Author: Anthony C. Hearn

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

expr procedure gcdn(u,v);
%  { U and v are integers. Value is absolute value of gcd of u and v}
   if v = 0 then abs u else gcdn(v,remainder(u,v));

endmodule;


module gcd; % Greatest common divisor routines.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*exp !*ezgcd !*gcd !*heugcd dmode!*);

switch ezgcd,heugcd;

symbolic procedure comfac p;
  % P is a non-atomic standard form
  % CAR of result is lowest common power of leading kernel in
  % every term in P (or NIL). CDR is gcd of all coefficients of
  % powers of leading kernel.
  % If field elements are involved, lnc is normalized to 1.
  % We need GCDF here since the same function is used by EZGCD.
   begin scalar x,y;
        if flagp(dmode!*,'field) and ((x := lnc p) neq 1)
          then p := multd(!:recip x,p);
        if null red p then return lt p;
        x := lc p;
        y := mvar p;
    a:  p := red p;
        if degr(p,y)=0 then return nil . gcdf(x,p)
         else if null red p then return lpow p . gcdf(x,lc p)
         else x := gcdf(lc p,x);
        go to a
   end;

symbolic procedure degr(u,var);
   if domainp u or not mvar u eq var then 0 else ldeg u;

put('gcd,'polyfn,'gcdf!*);

symbolic procedure gcdf!*(u,v);
   begin scalar !*gcd; !*gcd := t; return gcdf(u,v) end;

symbolic procedure gcdf(u,v);
   %U and V are standard forms.
   %Value is the gcd of U and V, complete only if *GCD is true;
   begin scalar !*exp;
      !*exp := t;
      u := if domainp u or domainp v or not !*ezgcd then gcdf1(u,v)
            else ezgcdf(u,v);
      return if minusf u then negf u else u
   end;

symbolic procedure gcdf1(u,v);
   begin scalar w;
      if null u then return v
       else if null v then return u
       else if u=1 or v=1 then return 1   % ONEP
       else if domainp u then return gcdfd(u,v)
       else if domainp v then return gcdfd(v,u)
       else if quotf1(u,v) then return v
       else if quotf1(v,u) then return u;
      w := gcdf2(u,v);
      if !*gcd and u and v
               and (null quotf1(u,w) or null quotf1(v,w))
        then errach list("GCDF FAILED",prepf u,prepf v);
           %this probably implies that integer overflow occurred;
      return w
   end;

symbolic procedure gcdf2(u,v);
   % U and V are both non-trivial forms. Value is their GCD;
   begin scalar w,x,y,z,z1;
      if !*gcd and length(z1 := kernord(u,v))>1
        then <<w := setkorder z1; u := reorder u; v := reorder v>>
       else z1 := nil;
      if mvar u eq mvar v
        then <<x := comfac u;
               y := comfac v;
               z := gcdf1(cdr x,cdr y);
               if !*gcd
                 then z := multf(gcdk(quotf1(u,comfac!-to!-poly x),
                                      quotf1(v,comfac!-to!-poly y)),
                                 z);
               if car x and car y
                 then if pdeg car x>pdeg car y
                        then z := multpf(car y,z)
                       else z := multpf(car x,z)>>
       else if ordop(mvar u,mvar v) then z := gcdf1(cdr comfac u,v)
       else z := gcdf1(cdr comfac v,u);
      if z1 then <<setkorder w; z := reorder z>>;
      return z
   end;

symbolic procedure gcdfd(u,v);
   %U is a domain element, V a form;
   %Value is gcd of U and V;
%  if not atom u and flagp(car u,'field) then 1 else gcdfd1(u,v);
   if flagp(dmode!*,'field) then 1 else gcdfd1(u,v);

symbolic procedure gcdfd1(u,v);
   if null v then u
    else if domainp v then gcddd(u,v)
    else gcdfd1(gcdfd1(u,lc v),red v);

symbolic procedure gcddd(u,v);
   %U and V are domain elements.  If they are invertable, value is 1
   %otherwise the gcd of U and V as a domain element;
   if u=1 or v=1 then 1
%   else if atom u and atom v then gcdn(u,v)
    else if atom u then if atom v then gcdn(u,v)
                         else if fieldp v then 1
                         else dcombine(u,v,'gcd)
    else if atom v
     then if flagp(car u,'field) then 1 else dcombine(u,v,'gcd)
    else if flagp(car u,'field) or flagp(car v,'field) then 1
    else dcombine(u,v,'gcd);

symbolic procedure gcdk(u,v);
   %U and V are primitive polynomials in the main variable VAR;
   %result is gcd of U and V;
   begin scalar lclst,var,w,x;
        if u=v then return u
         else if domainp u or degr(v,(var := mvar u))=0 then return 1
         else if ldeg u<ldeg v then <<w := u; u := v; v := w>>;
        if quotf1(u,v) then return v
         else if !*heugcd and (x := heu!-gcd(u,v)) then return x
         else if ldeg v=1
           or getd 'modular!-multicheck and modular!-multicheck(u,v,var)
          then return 1;
    a:  w := remk(u,v);
        if null w then return v
         else if degr(w,var)=0 then return 1;
        lclst := addlc(v,lclst);
        if x := quotf1(w,lc w) then w := x
         else for each y in lclst do while (x := quotf1(w,y)) do w := x;
        u := v; v := prim!-part w;
        if degr(v,var)=0 then return 1 else go to a
   end;

symbolic procedure addlc(u,v);
   if u=1 then v
    else (lambda x;
      if x=1 or x=-1 or not atom x and flagp(car x,'field) then v
       else x . v)
     lc u;

symbolic procedure delall(u,v);
   if null v then nil
    else if u eq caar v then delall(u,cdr v)
    else car v . delall(u,cdr v);

symbolic procedure kernord(u,v);
   <<u := kernord!-split(u,v);
     append(kernord!-sort car u,kernord!-sort cdr u)>>;

symbolic procedure kernord!-split(u,v);
   % splits U and V into a set of powers of those kernels occurring in
   % one form and not the other, and those occurring in both;
   begin scalar x,y;
      u := powers u;
      v := powers v;
      for each j in u do
          if assoc(car j,v) then y := j . y else x := j . x;
      for each j in v do
          if assoc(car j,u) then y := j . y else x := j . x;
      return reversip x . reversip y
   end;

symbolic procedure kernord!-sort u;
   % returns list of kernels ordered so that kernel with lowest maximum
   % power in U (a list of powers) is first, and so on;
   begin scalar x,y;
      while u do
       <<x := maxdeg(cdr u,car u);
         u := delall(car x,u);
         y := car x . y>>;
      return y
   end;

symbolic procedure maxdeg(u,v);
   if null u then v
    else if cdar u>cdr v then maxdeg(cdr u,car u)
    else maxdeg(cdr u,v);

symbolic procedure powers form;
   % returns a list of the maximum powers of each kernel in FORM.
   % order tends to be opposite to original order.
   powers0(form,nil);

symbolic procedure powers0(form,powlst);
   if null form or domainp form then powlst
    else begin scalar x;
        if (x := atsoc(mvar form,powlst))
%         then ldeg form>cdr x and rplacd(x,ldeg form)
          then (if ldeg form>cdr x
                  then powlst := repasc(mvar form,ldeg form,powlst))
         else powlst := (mvar form . ldeg form) . powlst;
        return powers0(red form,powers0(lc form,powlst))
     end;

put('lcm,'polyfn,'lcm!*);

symbolic procedure lcm!*(u,v);
   begin scalar !*gcd; !*gcd := t; return lcm(u,v) end;

symbolic procedure lcm(u,v);
   %U and V are standard forms. Value is lcm of U and V;
   if null u or null v then nil
    else if u=1 then v     % ONEP
    else if v=1 then u     % ONEP
    else multf(u,quotf(v,gcdf(u,v)));

symbolic procedure remk(u,v);
   %modified pseudo-remainder algorithm
   %U and V are polynomials, value is modified prem of U and V;
   begin scalar f1,var,x; integer k,n;
        f1 := lc v;
        var := mvar v;
        n := ldeg v;
        while (k := degr(u,var)-n)>=0 do
         <<x := negf multf(lc u,red v);
           if k>0 then x := multpf(var .** k,x);
           u := addf(multf(f1,red u),x)>>;
        return u
   end;

symbolic procedure prim!-part u;
   %returns the primitive part of the polynomial U wrt leading var;
   quotf1(u,comfac!-to!-poly comfac u);

symbolic procedure comfac!-to!-poly u;
   if null car u then cdr u else list u;

endmodule;


module sub; % Functions for substituting in standard forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*nosubs asymplis!* dmode!*);

global '(ncmp!*);

% Simplification interface

symbolic procedure simpsub u;
   begin scalar !*nosubs,w,x,z;
    a:  if null cdr u
          then <<if getrtype car u or eqcar(car u,'equal) 
                   then typerr(car u,"scalar");
                 u := simp!* car u;
                 z := reversip!* z;   % to put replacements in same
                                      % order as input.
                 return quotsq(subf(numr u,z),subf(denr u,z))>>;
        !*nosubs := t;  % We don't want left side of eqns to change.
        w := reval car u;
        !*nosubs := nil;
        if getrtype w eq 'list
          then <<u := append(cdr w,cdr u); go to a>>
         else if not eqexpr w then errpri2(car u,t); 
        x := cadr w;
        if null getrtype x then x := !*a2k x;
        z := (x . caddr w) . z;
        u := cdr u;
        go to a;
   end;

put('sub,'simpfn,'simpsub);

symbolic procedure subsq(u,v); quotsq(subf(numr u,v),subf(denr u,v));

symbolic procedure subf(u,l);
   begin scalar alglist!*,x;
   %domain may have changed, so next line uses simpatom;
      if domainp u then return !*d2q u
       else if ncmp!* and noncomexpf u then return subf1(u,l);
      x := reverse xn(for each y in l collect car y,
                      kernord(u,nil));
      x := setkorder x;
      u := subf1(reorder u,l);
      setkorder x;
      return reorder numr u ./ reorder denr u
   end;

symbolic procedure noncomexpf u;
   not domainp u
      and (noncomp mvar u or noncomexpf lc u or noncomexpf red u);

symbolic procedure subf1(u,l);
   %U is a standard form,
   %L an association list of substitutions of the form
   %(<kernel> . <substitution>).
   %Value is the standard quotient for substituted expression.
   %Algorithm used is essentially the straight method.
   %Procedure depends on explicit data structure for standard form;
   if domainp u
     then if atom u then if null dmode!* then u ./ 1 else simpatom u
          else if dmode!* eq car u then !*d2q u
          else simp prepf u
    else begin integer n; scalar kern,m,w,x,xexp,y,y1,z;
        z := nil ./ 1;
    a0: kern := mvar u;
        if m := assoc(kern,asymplis!*) then m := cdr m;
    a:  if null u or (n := degr(u,kern))=0 then go to b
         else if null m or n<m then y := lt u . y;
        u := red u;
        go to a;
    b:  if not atom kern and not atom car kern then kern := prepf kern;
        if null l then xexp := if kern eq 'k!* then 1 else kern
         else if (xexp := subsublis(l,kern)) = kern
                   and not assoc(kern,asymplis!*)
          then go to f;
    c:  w := 1 ./ 1;
        n := 0;
        if y and cdaar y<0 then go to h;
        if (x := getrtype xexp) then typerr(x,"substituted expression");
        x := simp xexp;
        % SIMP!* here causes problem with HE package;
        x := reorder numr x ./ reorder denr x;
        % needed in case substitution variable is in XEXP;
        if null l and kernp x and mvar numr x eq kern then go to f
         else if null numr x then go to e;   %Substitution of 0;
        for each j in y do
         <<m := cdar j;
           w := multsq(exptsq(x,m-n),w);
           n := m;
           z := addsq(multsq(w,subf1(cdr j,l)),z)>>;
    e:  y := nil;
        if null u then return z
         else if domainp u then return addsq(subf1(u,l),z);
        go to a0;
    f:  sub2chk kern;
        for each j in y do z := addsq(multpq(car j,subf1(cdr j,l)),z);
        go to e;
    h:  %Substitution for negative powers;
        x := simprecip list xexp;
    j:  y1 := car y . y1;
        y := cdr y;
        if y and cdaar y<0 then go to j;
    k:  m := -cdaar y1;
        w := multsq(exptsq(x,m-n),w);
        n := m;
        z := addsq(multsq(w,subf1(cdar y1,l)),z);
        y1 := cdr y1;
        if y1 then go to k else if y then go to c else go to e
     end;

symbolic procedure subsublis(u,v);
   % NOTE: This definition assumes that with the exception of *SQ and
   % domain elements, expressions do not contain dotted pairs.
   begin scalar x;
      return if x := assoc(v,u) then cdr x
              else if atom v then v
              else if not idp car v
               then for each j in v collect subsublis(u,j)
              else if flagp(car v,'subfn) then subsubf(u,v)
              else if get(car v,'dname) then v
              else if car v eq '!*sq then subsublis(u,prepsq cadr v)
              else for each j in v collect subsublis(u,j)
   end;

symbolic procedure subsubf(l,expn);
   %Sets up a formal SUB expression when necessary;
   begin scalar x,y;
      for each j in cddr expn do
         if (x := assoc(j,l)) then <<y := x . y; l := delete(x,l)>>;
      expn := sublis(l,car expn)
                 . for each j in cdr expn collect subsublis(l,j);
        %to ensure only opr and individual args are transformed;
      if null y then return expn;
      expn := aconc!*(for each j in reversip!* y
                     collect list('equal,car j,aeval cdr j),expn);
      return mk!*sq if l then simpsub expn
                     else !*p2q mksp('sub . expn,1)
   end;

flag('(int df),'subfn);

endmodule;


module exptf; % Functions for raising canonical forms to a power.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*exp);

symbolic procedure exptsq(u,n);
   begin scalar x;
        if n=1 then return u
         else if n=0
           then return if null numr u then rederr " 0**0 formed"
                        else 1 ./ 1
         else if null numr u then return u
         else if n<0 then return simpexpt list(mk!*sq u,n)
         else if null !*exp
          then return mksfpf(numr u,n) ./ mksfpf(denr u,n)
         else if kernp u then return mksq(mvar numr u,n)
         else if domainp numr u
          then return multsq(!:expt(numr u,n) ./ 1,
                             1 ./ exptf(denr u,n))
         else if denr u=1 then return exptf(numr u,n) ./ 1;
        x := u;
        while (n := n-1)>0 do x := multsq(u,x);
        return x
   end;

symbolic procedure exptf(u,n);
   if domainp u then !:expt(u,n)
    else if !*exp or kernlp u then exptf1(u,n)
    else mksfpf(u,n);

symbolic procedure exptf1(u,n);
   %iterative multiplication seems to be faster than a binary sub-
   %division algorithm, probably because multiplying a small polynomial
   %by a large one is cheaper than multiplying two medium sized ones;
   if n=0 then 1
    else begin scalar x;
         x := u;
         while (n := n-1)>0 do x := multf(u,x);
         return x
      end;


endmodule;


module kernel;   % Functions for operations on kernels.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

global '(exlist!* kprops!*);

symbolic procedure fkern u;
   %finds the unique "p-list" reference to the kernel U. The choice of
   %the search and merge used here has a strong influence on some
   %timings. The ordered list used here is also used by Prepsq* to
   %order factors in printed output, so cannot be unilaterally changed;
   begin scalar x,y;
        if atom u then return list(u,nil);
        y := if atom car u then get(car u,'klist) else exlist!*;
        if not (x := assoc(u,y))
          then <<x := list(u,nil);
                 y := ordad(x,y);
                 if atom car u
                   then <<kprops!* := union(list car u,kprops!*);
                          put(car u,'klist,y)>>
                  else exlist!* := y>>;
        return x
   end;

symbolic procedure kernels u;
   % Returns list of kernels in standard form u.
   kernels1(u,nil);

symbolic procedure kernels1(u,v);
   % We append to end of list to put kernels in the right order, even
   % though a cons on the front of the list would be faster.
   if domainp u then v
    else kernels1(lc u,
                  kernels1(red u,
                           if x memq v then v else append(v,list x)))
         where x=mvar u;

%   else kernels1(red u,kernels1(lc u,ordas(mvar u,v)));
%   else kernels1(lc u,kernels1(red u,ordas(mvar u,v)));

% symbolic procedure ordas(a,l);
%    if null l then list a
%     else if a=car l then l
%     else if ordp(a,car l) then a . l
%     else car l . ordas(a,cdr l);

symbolic procedure kernp u;
   % true if U is standard quotient representation for a kernel.
   denr u=1 and not domainp(u := numr u)
        and null red u and lc u=1 and ldeg u=1;     % ONEP

endmodule;


module mksp; % Functions for making standard powers.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*nosubs !*sub2 asymplis!*);

global '(!*resubs
         powlis!*
         subfg!*
         wtl!*);

% exports mksfpf,mksp,mksq,to;

% imports !*p2f,aconc,eqcar,exptf,exptsq,leq,mkprod!*,module,multsq,
%       ordad,over,simpcar,union;

symbolic procedure getpower(u,n);
   %U is a list (<kernel> . <properties>), N a positive integer.
   %Value is the standard power of U**N;
   <<if eqcar(car u,'expt) and n>1 then !*sub2 := t; car u . n>>;
%   begin scalar v;
%       v := cadr u;
%       if null v then return caar rplaca(cdr u,list (car u . n));
%    a: if n=cdar v then return car v
%        else if n<cdar v
%           then return car rplacw(v,(caar v . n) . (car v . cdr v))
%        else if null cdr v
%           then return cadr rplacd(v,list (caar v . n));
%       v := cdr v;
%       go to a
%   end;

symbolic procedure mksp(u,p);
   %U is a (non-unique) kernel and P a non-zero integer
   %Value is the standard power for U**P;
   getpower(fkern u,p);

symbolic procedure u to p;
   %U is a (unique) kernel and P a non-zero integer;
   %Value is the standard power of U**P;
   u . p;
%   getpower(fkern u,p);

symbolic procedure mksfpf(u,n);
   %raises form U to power N with EXP off. Returns a form;
%   if domainp u then !:expt(u,n)
%    else if n>=0 and kernlp u
%     then if null red u and onep lc u then !*p2f mksp(mvar u,ldeg u*n)
%          else exptf1(u,n)
%    else if n=1 or null subfg!* then mksp!*(u,n)
%    else (lambda x; %if x and cdr x<=n then nil else mksp!*(u,n))
%         assoc(u,asymplis!*);
   exptf(mkprod!* u,n);

symbolic procedure mksq(u,n);
    %U is a kernel, N a non-zero integer;
    %Value is a standard quotient of U**N, after making any
    %possible substitutions for U;
   begin scalar x,y,z;
        if null subfg!* then go to a1
         else if (y := assoc(u,wtl!*))
                and null car(y := mksq('k!*,n*cdr y)) then return y
         else if not atom u then go to b
         else if null !*nosubs and (z:= get(u,'avalue)) then go to c;
        if idp u then flag(list u,'used!*);
        %tell system U used as algebraic var (unless it's a string);
    a:  if !*nosubs or n=1 then go to a1
         else if (z:= assoc(u,asymplis!*)) and cdr z<=n
          then return nil ./ 1
         else if ((z:= assoc(u,powlis!*))
                or not atom u and car u memq '(expt sqrt)
                and (z := assoc(cadr u,powlis!*)))
             and not(n*cadr z)<0
           %implements explicit sign matching;
          then !*sub2 := t;
    a1: if null x then x := fkern u;
        x := !*p2f getpower(x,n) ./ 1;
        return if y then multsq(y,x) else x;
    b:  if null !*nosubs and atom car u
           and (z:= assoc(u,get(car u,'kvalue)))
          then go to c
         else if not('used!* memq cddr (x := fkern u))
          then aconc(x,'used!*);
        go to a;
    c:  z := cdr z;
    d:  %optimization is possible as shown if all expression
        %dependency is known;
        %if cdr z then return exptsq(cdr z,n); %value already computed;
        if null !*resubs then !*nosubs := t;
        x := simpcar z;
        !*nosubs := nil;
        %rplacd(z,x);           %save simplified value;
        %subl!* := z . subl!*;
        return exptsq(x,n)
   end;

endmodule;


module order; % Functions for internal ordering of expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(kord!*);

symbolic procedure ordad(a,u);
   if null u then list a
    else if ordp(a,car u) then a . u
    else car u . ordad(a,cdr u);

symbolic procedure ordn u;
   if null u then nil
    else if null cdr u then u
    else if null cddr u then ord2(car u,cadr u)
    else ordad(car u,ordn cdr u);

symbolic procedure ord2(u,v);
   if ordp(u,v) then list(u,v) else list(v,u);

symbolic procedure ordp(u,v);
   %returns TRUE if U ordered ahead or equal to V, NIL otherwise.
   %an expression with more structure at a given level is ordered 
   %ahead of one with less;
   if null u then null v
    else if null v then t
    else if atom u
       then if atom v
                then if numberp u then numberp v and not u<v
                      else if numberp v then t else orderp(u,v)
             else nil
    else if atom v then t
    else if car u=car v then ordp(cdr u,cdr v)
    else ordp(car u,car v);

symbolic procedure ordpp(u,v);
   % This used to check (incorrectly) for NCMP!*;
   if car u eq car v then cdr u>cdr v else ordop(car u,car v);

symbolic procedure ordop(u,v);
   begin scalar x;
        x := kord!*;
    a:  if null x then return ordp(u,v)
         else if u eq car x then return t
         else if v eq car x then return;
        x := cdr x;
        go to a
   end;

endmodule;


module reord; % Functions for reordering standard forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(kord!*);

global '(ncmp!*);

symbolic procedure reorder u;
   %reorders a standard form so that current kernel order is used;
   if domainp u then u
    else raddf(rmultpf(lpow u,reorder lc u),reorder red u);

symbolic procedure raddf(u,v);
   %adds reordered forms U and V;
   if null u then v
    else if null v then u
    else if domainp u then addd(u,v)
    else if domainp v then addd(v,u)
    else if peq(lpow u,lpow v)
     then (lpow u .* raddf(lc u,lc v)) .+ raddf(red u,red v)
    else if ordpp(lpow u,lpow v) then lt u . raddf(red u,v)
    else lt v . raddf(u,red v);

symbolic procedure rmultpf(u,v);
  %multiplies power U by reordered form V;
   if null v then nil
    else if domainp v or reordop(car u,mvar v) then !*t2f(u .* v)
    else (lpow v .* rmultpf(u,lc v)) .+ rmultpf(u,red v);

symbolic procedure reordop(u,v);
   if ncmp!* and noncomp u and noncomp v then t else ordop(u,v);

symbolic procedure korder u;
   <<kord!* := if u = '(nil) then nil
                else for each x in u collect !*a2k x;
     rmsubs()>>;

rlistat '(korder);

symbolic procedure setkorder u;
   begin scalar v; v := kord!*; kord!* := u; return v end;

endmodule;


module forall; % FOR ALL Command.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*backtrace !*sub2 alglist!* arbl!* asymplis!*);

global '(!*match
         cursym!*
         erfg!*
         frasc!*
         frlis!*
         letl!*
         mcond!*
         powlis!*
         powlis1!*
         subfg!*
         wtl!*);

letl!* := '(let match clear saveas such);   %special delimiters;

% Contains two RPLAC references commented out.

remprop('forall,'stat);

remprop('forall,'formfn);

symbolic procedure forallstat;
   begin scalar arbl,conds;
        if cursym!* memq letl!* then symerr('forall,t);
        flag(letl!*,'delim);
        arbl := remcomma xread nil;
        if cursym!* eq 'such then 
          <<if not scan() eq 'that then symerr('let,t);
            conds := xread nil>>;
        remflag(letl!*,'delim);
        if not cursym!* memq letl!* then symerr('let,t)
         else return list('forall,arbl,conds,xread1 t)
   end;

symbolic procedure forall u;
   begin scalar x,y;
      x := for each j in car u collect newvar j;
      y := pair(car u,x);
      mcond!* := subla(y,cadr u);
      frasc!* := y;
      frlis!* := union(x,frlis!*);
      return eval caddr u
   end;

symbolic procedure arbstat;
   <<lpriw("*****","ARB no longer supported");
     symerr('if,t)>>;

put('arb,'stat,'arbstat);

symbolic procedure newvar u;
   if not idp u then typerr(u,"free variable")
    else if flagp(u,'reserved)
     then typerr(list("Reserved variable",u),"free variable")
    else intern compress append(explode '!=,explode u);

symbolic procedure formforall(u,vars,mode);
   begin scalar arbl!*,x;
      u := cdr u;
%     vars := append(car u,vars);   % semantics are different
      if null cadr u then x := t else x := formbool(cadr u,vars,mode);
      return list('forall,list('list,mkquote union(arbl!*,car u),
                  mkquote x,mkquote form1(caddr u,vars,mode)))
   end;

symbolic procedure def u;
   % Defines a list of operators.
   for each x in u do
      if not eqexpr x or not idlistp cadr x then errpri2(x,t)
       else <<mkop caadr x;
              forall list(cdadr x,t,list('let,mkarg(list x,nil)))>>;

put('def,'stat,'rlis);

deflist('((forall formforall)),'formfn);

deflist('((forall forallstat)),'stat);

flag ('(clear let match),'quote);

symbolic procedure formlet1(u,vars,mode);
   'list . for each x in u collect
      if eqexpr x
        then list('list,mkquote 'equal,form1(cadr x,vars,mode),
                                !*s2arg(form1(caddr x,vars,mode),vars))
       else errpri2(x,t);

symbolic procedure !*s2arg(u,vars);
   %makes all NOCHANGE operators into their listed form;
   if atom u then u
    else if not idp car u or not flagp(car u,'nochange)
     then for each j in u collect !*s2arg(j,vars)
    else mkarg(u,vars);

put('let,'formfn,'formlet);

put('clear,'formfn,'formclear);

put('match,'formfn,'formmatch);

symbolic procedure formclear(u,vars,mode);
   list('clear,formclear1(cdr u,vars,mode));

symbolic procedure formclear1(u,vars,mode);
   'list . for each x in u collect form1(x,vars,mode);

symbolic procedure formlet(u,vars,mode);
   list('let,formlet1(cdr u,vars,mode));

symbolic procedure formmatch(u,vars,mode);
   list('match,formlet1(cdr u,vars,mode));

symbolic procedure let u; let0 u;    % to distinguish between operator
                                     % and function.
symbolic procedure let0 u;
   begin
   a: if null u
         or errorp
            errorset(list('let2,mkquote cadar u,mkquote caddar u,nil,t),
                     t,!*backtrace)
        then go to b;
      u := cdr u;
      go to a;
   b: mcond!* := frasc!* := nil
   end;

symbolic procedure let2(u,v,w,b);
   begin scalar flg,x,y,z;
        % FLG is set true if free variables are found;
        x := subla(frasc!*,u);
        if x neq u
          then if atom x then return errpri1 u
                 else <<flg := t; u := x>>;
        x := subla(frasc!*,v);
        if x neq v
          then <<v := x;
                 if eqcar(v,'!*sq!*) then v := prepsq!* cadr v>>;
                 % to ensure no kernels are replaced by uneq copies
                 % during pattern matching process;
        %check for unmatched free variables;
        x := smemql(frlis!*,mcond!*);
        y := smemql(frlis!*,u);
        if (z := setdiff(x,y))
           or (z := setdiff(setdiff(smemql(frlis!*,v),x),
                    setdiff(y,x)))
          then <<lprie ("Unmatched free variable(s)" . z);
                 erfg!* := 'hold;
                 return nil>>
         else if eqcar(u,'getel) then u := eval cadr u;
    a:  x := u;
        if null x then <<u := 0; return errpri1 u>>
         else if numberp x then return errpri1 u
         else if idp x and flagp(x,'reserved)
          then rederr list(x,"is a reserved identifier")
         else if y := getrtype x then return
                 if z := get(y,'typeletfn)
                    then apply(z,list(x,v,y,b,getrtype v))
                  else typelet(x,v,y,b,getrtype v)
         else if y := getrtype v then return
                 if z := get(y,'typeletfn)
                    then apply(z,list(x,v,nil,b,y))
                  else typelet(x,v,nil,b,y)
         else if not atom x
               then if not idp car x then return errpri2(u,'hold)
                     else if car x eq 'df
                      then if null letdf(u,v,w,x,b) then nil
                            else return nil
                     else if getrtype car x
                      then return let2(reval x,v,w,b)
                     else if not get(car x,'simpfn)
                      then <<redmsg(car x,"operator");
                             mkop car x; go to a>>
                     else nil
         else if null b and null w
          then <<if (y := get(x,'rtype)) 
                   then <<remprop(x,'rtype); remprop(x,'rvalue)>>
                  else remprop(x,'avalue);
                 remflag(list x,'antisymmetric);
                 remprop(x,'infix);
               % remprop(x,'klist);
               % commented out: the relevant objects may still exist.
                 remprop(x,'op);
                 remprop(x,'opmtch);
                 remprop(x,'simpfn);
                 remflag(list x,'symmetric);
                 wtl!* := delasc(x,wtl!*);
                 if flagp(x,'opfn)
                   then <<remflag(list x,'opfn); remd x>>;
                 rmsubs(); % since all kernel lists are gone.
                 return nil>>;
        if eqcar(x,'expt) and caddr x memq frlis!*
          then letexprn(u,v,w,!*k2q x,b,flg);
           % special case of a non-integer exponent match;
        x := simp0 x;
        return if not domainp numr x then letexprn(u,v,w,x,b,flg)
                else errpri1 u
   end;

symbolic procedure letexprn(u,v,w,x,b,flg);
   %replacement of scalar expressions;
   begin scalar y,z;
        if denr x neq 1
          then return let2(let!-prepf numr x,
                           list('times,let!-prepf denr x,v),w,b)
         else if red(x := numr x)
          then return let2(let!-prepf !*t2f lt x,
                           list('difference,v,let!-prepf red x),w,b)
         else if null (y := kernlp x)
          then <<y := term!-split x;
                 return let2(let!-prepf car y,
                            list('difference,v,let!-prepf cdr y),w,b)>>
         else if y neq 1
          then return let2(let!-prepf quotf!*(x,y),
                           list('quotient,v,let!-prepf y),w,b);
        x := klistt x;
        y := list(w . (if mcond!* then mcond!* else t),v,nil);
        if cdr x
          then return <<rmsubs(); !*match:= xadd!*(x . y,!*match,b)>>
         else if null w and cdar x=1    % ONEP
          then <<x := caar x;
                 if null flg
                   then <<if atom x
                            then if flagp(x,'used!*) then rmsubs()
                                  else nil
                           else if 'used!* memq cddr fkern x
                            then rmsubs();
                          setk1(x,v,b)>>
                  else if atom x then return errpri1 u
                  else <<if get(car x,'klist) then rmsubs();
                         put(car x,
                             'opmtch,
                           xadd!*(cdr x . y,get(car x,'opmtch),b))>>>>
         else <<rmsubs();
                if v=0 and null w and not flg
                  then <<asymplis!* := xadd(car x,asymplis!*,b);
                         powlis!*
                      := xadd(caar x . cdar x . y,powlis!*,'replace)>>
                 else if w or not cdar y eq t or frasc!*
                  then powlis1!* := xadd(car x . y,powlis1!*,b)
                 else if null b and (z := assoc(caar x,asymplis!*))
                    and z=car x
                  then asymplis!* := delasc(caar x,asymplis!*)
              else <<powlis!* := xadd(caar x . cdar x . y,powlis!*,b);
                   if b then asymplis!* := delasc(caar x,asymplis!*)>>>>
   end;

rlistat '(clear let match);

symbolic procedure term!-split u;
   % U is a standard form which is not a kernel list (i.e., kernlp
   % is false). Result is the dotted pair of the leading part of the
    % expression for which kernlp is true, and the remainder;
   begin scalar x;
      while null red u do <<x := lpow u . x; u := lc u>>;
      return tpowadd(x,!*t2f lt u) . tpowadd(x,red u)
   end;

symbolic procedure tpowadd(u,v);
   <<for each j in u do v := !*t2f(j .* v); v>>;

symbolic procedure simp0 u;
   begin scalar x,y,z;
        y := setkorder frlis!*;
        if eqcar(u,'!*sq) then return simp0 prepsq!* cadr u;
        x := subfg!* . !*sub2;
        subfg!* := nil;
        if atom u
           or idp car u 
              and (flagp(car u,'simp0fn) or get(car u,'rtype))
          then z := simp u
         else z := simpiden u;
        alglist!* := delasc(u,alglist!*);
        % Since we don't want to keep this value.
        subfg!* := car x;
        !*sub2 := cdr x;
        setkorder y;
        return z
   end;

flag('(cons difference eps expt minus plus quotient times),'simp0fn);

symbolic procedure let!-prepf u;
   subla(for each x in frasc!* collect (cdr x . car x),prepf u);

symbolic procedure match u;
   <<for each x in u do let2(cadr x,caddr x,t,t);
     frasc!* := mcond!* := nil>>;

symbolic procedure clear u;
   begin
      rmsubs();
      for each x in u do <<let2(x,nil,nil,nil); let2(x,nil,t,nil)>>;
      mcond!* := frasc!* := nil
   end;

symbolic procedure typelet(u,v,ltype,b,rtype);
   % General function for setting up rules for typed expressions.
   % LTYPE is the type of the left hand side U, RTYPE, that of RHS V.
   % B is a flag that is true if this is an update, nil for a removal.
   begin
        if null rtype then rtype := 'scalar;
        if ltype eq rtype then go to a
         else if null b then go to c
         else if ltype then typerr(list(ltype,u),rtype)
         else if not atom u
          then if arrayp car u then go to a else typerr(u,rtype);
        redmsg(u,rtype);
        put(u,'rtype,rtype);
        ltype := rtype;
    a:  if b and (not atom u or flagp(u,'used!*)) then rmsubs();
    c:  if not atom u
          then if arrayp car u
                 then setelv(u,if b then v else nil)
                else put(car u,'opmtch,xadd!*(cdr u .
                    list(nil . (if mcond!* then mcond!* else t),v,nil),
                        get(car u,'opmtch),b))
         else if null b
          then <<remprop(u,'rvalue);
                 remprop(u,'rtype);
                 if ltype eq 'array then remprop(u,'dimension)>>
         else if get(u,'avalue) then typerr(list("VARIABLE",u),rtype)
         else put(u,'rvalue,v)
   end;

symbolic procedure setk(u,v);
   begin scalar x;
      if not atom u 
         and idp car u
         and (x := get(car u,'rtype))
         and (x := get(x,'setelemfn))
        then apply2(x,u,v)
       else let2(u,v,nil,t);
      return v
   end;

symbolic procedure setk1(u,v,b);
   begin scalar x,y;
        if not atom u then go to c
         else if null b then go to b1
         else if (x := get(u,'avalue))
          then <<x := cdr x; go to a>>;
        x := nil . nil;
        put(u,'avalue,'scalar . x);
    a:  rplacd(rplaca(x,v),nil);
        return v;
    b1: if not get(u,'avalue) then msgpri(nil,u,"not found",nil,nil)
         else remprop(u,'avalue);
        return;
    c:  if not atom car u
          then rederr "Invalid syntax: improper assignment";
        u := car u . revlis cdr u;
        if null b then go to b2
         else if not (y := get(car u,'kvalue)) then go to e
         else if x := assoc(u,y) then go to d;
        x := nil . nil;
        aconc(y,u . x);
        go to a;
    d:  x := cdr x;
        go to a;
    e:  x := nil . nil;
        put(car u,'kvalue,list(u . x));
        go to a;
    b2: if not(y := get(car u,'kvalue)) or not (x := assoc(u,y))
          then msgpri(nil,u,"not found",nil,nil)
         else put(car u,'kvalue,delete(x,y));
        return;
   end;

symbolic procedure klistt u;
   if atom u then nil else caar u . klistt cdr carx(u,'list);

symbolic procedure kernlp u;
   % Returns leading domain coefficient if U is a monomial product 
   % of kernels, NIL otherwise.
   if domainp u then u else if null red u then kernlp lc u else nil;

symbolic procedure xadd(u,v,b);
   %adds replacement U to table V, with new rule at head;
   begin scalar x;
        x := assoc(car u,v);
        if null x
          then if b and not(b eq 'replace) then v := u . v else nil
         else if b
          then <<v := delete(x,v);
                 if not(b eq 'replace) then v := u . v>>
         else if cadr x=cadr u then v := delete(x,v);
        return v
   end;

symbolic procedure xadd!*(u,v,b);
   %adds replacement U to table V, with new rule at head;
   %also checks boolean part for equality;
   begin scalar x;
      x := v;
      while x and not(car u=caar x and cadr u=cadar x) do x := cdr x;
      if x then v := delete(car x,v);
      if b then v := u . v;
      return v
   end;


endmodule;


module rmsubs;   % Remove system wide standard quotient substitutions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(alglist!*);

global '(!*sqvar!*);

% Contains RPLACA update of *SQVAR*.

!*sqvar!*:= list 't;    %variable used by *SQ expressions to control
                        %resimplification;

symbolic procedure rmsubs;
   begin
        rplaca(!*sqvar!*,nil); !*sqvar!* := list t;
%       while kprops!* do
%          <<remprop(car kprops!*,'klist); %kprops!* := cdr kprops!*>>;
%       exlist!* := list '(!*);
        %This is too dangerous: someone else may have constructed a
        %standard form;
        alglist!* := nil
   end;

endmodule;


module algdcl;  % Various declarations.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

global '(frlis!* preclis!* ws);

symbolic procedure formopr(u,vars,mode);
   if mode eq 'symbolic
     then mkprog(nil,list list('flag,mkquote cdr u,mkquote 'opfn))
    else list('operator,mkarg(cdr u,vars));

put('operator,'formfn,'formopr);

symbolic procedure operator u; for each j in u do mkop j;

rlistat '(operator);

symbolic procedure remopr u;
   % Remove all operator related properties from id u.
   begin
      remprop(u,'alt);
      remprop(u,'infix);
      remprop(u,'op);
      remprop(u,'prtch);
      remprop(u,'simpfn);
      remprop(u,'unary);
      remflag(list u,'linear);
      remflag(list u,'nary);
      remflag(list u,'opfn);
      remflag(list u,'antisymmetric);
      remflag(list u,'symmetric);
      remflag(list u,'right);
      preclis!* := delete(u,preclis!*)
   end;

flag('(remopr),'eval);

symbolic procedure den u;
   mk!*sq (denr simp!* u ./ 1);

symbolic procedure num u;
   mk!*sq (numr simp!* u ./ 1);

flag('(den num max min),'opfn);

flag('(den num),'noval);

put('saveas,'formfn,'formsaveas);

symbolic procedure formsaveas(u,vars,mode);
   list('saveas,formclear1(cdr u,vars,mode));

symbolic procedure saveas u;
   let0 list list('equal,car u,
                  if eqcar(ws,'!*sq)
                     and smemql(for each x in frasc!* collect car x,
                                cadr ws)
                    then list('!*sq,cadr ws,nil)
                   else ws);

rlistat '(saveas);

endmodule;


end;

Added r33/alg2.red version [9bdab630b5].































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
module opmtch; % Functions that apply basic pattern matching rules.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

global '(frlis!* subfg!*);

symbolic procedure emtch u;
   if atom u then u else (lambda x; if x then x else u) opmtch u;

symbolic procedure opmtch u;
   begin scalar x,y,z;
        x := get(car u,'opmtch);
        if null x then return nil
         else if null subfg!* then return nil;  %null(!*sub2 := t);
        z := for each j in cdr u collect emtch j;
    a:  if null x then return nil;
        y := mcharg(z,caar x,car u);
    b:  if null y then go to c
         else if eval subla(car y,cdadar x)
          then return subla(car y,caddar x);
        y := cdr y;
        go to b;
    c:  x := cdr x;
        go to a
   end;

symbolic procedure mcharg(u,v,w);
   %procedure to determine if an argument list matches given template;
   %U is argument list of operator W;
   %V is argument list template being matched against;
   %if there is no match, value is NIL,
   %otherwise a list of lists of free variable pairings;
   if null u and null v then list nil
    else begin integer m,n;
        m := length u;
        n := length v;
        if flagp(w,'nary) and m>2
          then if m<6 and flagp(w,'symmetric)
                             then return mchcomb(u,v,w)
                else if n=2 then <<u := cdr mkbin(w,u); m := 2>>
                else return nil;   %we cannot handle this case;
        return if m neq n then nil
                else if flagp(w,'symmetric) then mchsarg(u,v,w)
                else if mtp v then list pair(v,u)
                else mcharg2(u,v,list nil,w)
   end;

symbolic procedure mchcomb(u,v,op);
   begin integer n;
      n := length u - length v +1;
      if n<1 then return nil
       else if n=1 then return mchsarg(u,v,op)
       else if not smemqlp(frlis!*,v) then return nil;
      return for each x in comb(u,n) join
        mchsarg((op . x) . setdiff(u,x),v,op)
   end;

symbolic procedure comb(u,n);
   %value is list of all combinations of N elements from the list U;
   begin scalar v; integer m;
        if n=0 then return list nil
         else if (m:=length u-n)<0 then return nil
         else for i := 1:m do
          <<v := nconc!*(v,mapcons(comb(cdr u,n-1),car u));
            u := cdr u>>;
        return u . v
   end;

symbolic procedure mcharg2(u,v,w,x);
   %matches compatible list U of operator X against template V.
   begin scalar y;
        if null u then return w;
        y := mchk(car u,car v);
        u := cdr u;
        v := cdr v;
        return for each j in y
           join mcharg2(u,updtemplate(j,v,x),msappend(w,j),x)
   end;

symbolic procedure msappend(u,v);
   % Mappend u and v with substitution.
   for each j in u collect append(v,sublis(v,j));

symbolic procedure updtemplate(u,v,w);
   begin scalar x,y;
      return for each j in v collect
        if (x := subla(u,j)) = j then j
         else if (y := reval!-without(x,w)) neq x then y
         else x
   end;

symbolic procedure reval!-without(u,v);
   % Evaluate U without rules for operator V.  This avoids infinite
   % recursion with statements like
   % for all a,b let kp(dx a,kp(dx a,dx b)) = 0; kp(dx 1,dx 2);
   begin scalar x;
      x := get(v,'opmtch);
      remprop(v,'opmtch);
      u := errorset(list('reval,mkquote u),t,t);
      put(v,'opmtch,x);
      if errorp u then error1() else return car u
   end;

symbolic procedure mchk(u,v);
   if u=v then list nil
    else if atom v
           then if v memq frlis!* then list list (v . u) else nil
    else if atom u      %special check for negative number match;
     then if numberp u and u<0 then mchk(list('minus,-u),v)
           else nil
    else if car u eq car v then mcharg(cdr u,cdr v,car u)
    else nil;

symbolic procedure mkbin(u,v);
   if null cddr v then u . v else list(u,car v,mkbin(u,cdr v));

symbolic procedure mtp v;
   null v or (car v memq frlis!* and not car v member cdr v
       and mtp cdr v);

symbolic procedure mchsarg(u,v,w);
   reversip!* if mtp v
     then for each j in permutations v collect pair(j,u)
    else for each j in permutations u join mcharg2(j,v,list nil,w);

symbolic procedure permutations u;
   if null u then list u
    else for each j in u join mapcons(permutations delete(j,u),j);

flagop antisymmetric,symmetric;

flag ('(plus times cons),'symmetric);

endmodule;


module prep; %Functions for converting canonical forms into prefix forms

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*intstr);

symbolic procedure prepsqxx u;
   % This is a top level conversion function.  It is not clear if we
   % need prepsqxx, prepsqx, prepsq!* and prepsq, but we keep them all
   % for the time being.
   negnumberchk prepsqx u;

symbolic procedure negnumberchk u;
   if eqcar(u,'minus) and numberp cadr u then - cadr u else u;

symbolic procedure prepsqx u;
   if !*intstr then prepsq!* u else prepsq u;

symbolic procedure prepsq u;
   if null numr u then 0 else sqform(u,function prepf);

symbolic procedure sqform(u,v);
   (lambda (x,y); if y=1 then x else list('quotient,x,y))
      (apply1(v,numr u),apply1(v,denr u));

symbolic procedure prepf u;
   replus prepf1(u,nil);

symbolic procedure prepf1(u,v);
   if null u then nil
    else if domainp u then list retimes(prepd u . exchk v)
    else nconc!*(prepf1(lc u,if mvar u eq 'k!* then v else lpow u . v),
                 prepf1(red u,v));

symbolic procedure prepd u;
   if atom u then if u<0 then list('minus,-u) else u
    else if apply1(get(car u,'minusp),u)
%    then list('minus,prepd1 !:minus u)
     then (if null x then 0 else list('minus,x))
          where x=prepd1 !:minus u
%   else if !:onep u then 1
    else apply1(get(car u,'prepfn),u);

symbolic procedure prepd1 u;
   if atom u then u else apply1(get(car u,'prepfn),u);

symbolic procedure exchk u; exchk1(u,nil,nil,nil);

symbolic procedure exchk1(u,v,w,x);
   % checks forms for kernels in EXPT. U is list of powers.  V is used
   % to build up the final answer. W is an association list of
   % previous non-constant (non foldable) EXPT's, X is an association
   % list of constant (foldable) EXPT arguments.
   if null u then exchk2(append(x,w),v)
    else if eqcar(caar u,'expt)
     then begin scalar y,z;
            y := simpexpon list('times,cdar u,caddar car u);
            if numberp cadaar u   % constant argument
              then <<z := assoc2(y,x);
                     if z then rplaca(z,car z*cadaar u) 
                      else x := (cadaar u . y) . x>>
             else <<z := assoc(cadaar u,w);
                    if z then rplacd(z,addsq(y,cdr z))
                     else w := (cadaar u . y) . w>>;
            return exchk1(cdr u,v,w,x)
        end
    else if cdar u=1 then exchk1(cdr u,sqchk caar u . v,w,x)
    else exchk1(cdr u,list('expt,sqchk caar u,cdar u) . v,w,x);

symbolic procedure exchk2(u,v);
   if null u then v
    else exchk2(cdr u,
                ((if eqcar(x,'quotient) and caddr x = 2
                   then if cadr x = 1 then list('sqrt,caar u)
                         else list('expt,list('sqrt,caar u),cadr x)
                  else if x=0.5 then list('sqrt,caar u)
                  else if x=1 then caar u
                  else list('expt,caar u,x)) where x = prepsqx cdar u)
                . v);

symbolic procedure assoc2(u,v);
   % Finds key U in second position of terms of V, or returns NIL.
   if null v then nil
    else if u = cdar v then car v
    else assoc2(u,cdr v);

symbolic procedure replus u;
   if atom u then u else if null cdr u then car u else 'plus . u;

symbolic procedure retimes u;
   % U is a list of prefix expressions. Value is prefix form for the
   % product of these;
   begin scalar bool,x;
      for each j in u do
         <<if j=1 then nil     % ONEP
            else if eqcar(j,'minus)
             then <<bool := not bool;
                    if cadr j neq 1 then x := cadr j . x>>     % ONEP
            else if numberp j and minusp j
             then <<bool := not bool;
                    if j neq -1 then x := (-j) . x>>
            else x := j . x>>;
        x := if null x then 1
                else if cdr x then 'times . reverse x else car x;
        return if bool then list('minus,x) else x
   end;

symbolic procedure sqchk u;
   if atom u then u
    else if car u eq '!*sq then prepsq cadr u
    else if car u eq 'expt and caddr u=1 then cadr u
    else if atom car u then u else prepf u;

endmodule;


module sqprint;   % Routines for printing standard forms and quotients.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

global '(!*eraise
         !*fort
         !*horner
         !*nat
         !*nero
         !*outp
         !*pri
         orig!*
         posn!*
         wtl!*
         ycoord!*
         ymax!*
         ymin!*);

deflist ('((!*sq !*sqprint)),'prifn);

symbolic procedure !*sqprint u; sqprint cadr u;

symbolic procedure printsq u;
   begin terpri!* t; sqprint u; terpri!* u; return u end;

symbolic procedure sqprint u;
   %mathprints the standard quotient U;
   begin scalar flg,z;
        z := orig!*;
        if !*nat and posn!*<20 then orig!* := posn!*;
        if !*pri or wtl!* then go to c
         else if cdr u neq 1 then go to b
         else xprinf(car u,nil,nil);
    a:  return (orig!* := z);
    b:  flg := not domainp numr u and red numr u;
        if flg then prin2!* "(";
        xprinf(car u,nil,nil);
        if flg then prin2!* ")";
        prin2!* " / ";
        flg := not domainp denr u and red denr u;
        if flg then prin2!* "(";
        xprinf(cdr u,nil,nil);
        if flg then prin2!* ")";
        go to a;
    c:  if null !*horner
           or errorp(!*outp:=errorset(list('horner,mkquote u),nil,nil))
          then !*outp := prepsq!* u
         else !*outp := prepsq car !*outp;
        maprin !*outp;
        go to a
   end;

symbolic procedure printsf u;
   begin prinsf u; terpri!* nil; return u end;

symbolic procedure prinsf u;
   if null u then prin2!* 0 else xprinf(u,nil,nil);

symbolic procedure xprinf(u,v,w);
   %U is a standard form.
   %V is a flag which is true if a term has preceded current form.
   %W is a flag which is true if form is part of a standard term;
   %Procedure prints the form and returns NIL;
   begin
    a:  if null u then return nil
         else if domainp u then return xprid(u,v,w);
        xprint(lt u,v);
        u := red u;
        v := t;
        go to a
   end;

symbolic procedure xprid(u,v,w);
   %U is a domain element.
   %V is a flag which is true if a term has preceded element.
   %W is a flag which is true if U is part of a standard term.
   %Procedure prints element and returns NIL;
   begin
        if minusf u then <<oprin 'minus; u := !:minus u>>
         else if v then oprin 'plus;
        if not w or u neq 1
          then if atom u then prin2!* u else maprin u
   end;

symbolic procedure xprint(u,v);
   %U is a standard term.
   %V is a flag which is true if a term has preceded this term.
   %Procedure prints the term and returns NIL;
   begin scalar flg,w;
        flg := not domainp tc u and red tc u;
        if not flg then go to a else if v then oprin 'plus;
        prin2!* "(";
    a:  xprinf(tc u,if flg then nil else v,not flg);
        if flg then prin2!* ")";
        if not atom tc u or not abs tc u=1 then oprin 'times;
        w := tpow u;
        if atom car w then prin2!* car w
         else if not atom caar w or caar w eq '!*sq then go to c
         else if caar w eq 'plus then maprint(car w,100)
         else maprin car w;
    b:  if cdr w=1 then return;
        if !*nat and !*eraise
          then <<ycoord!* := ycoord!*+1;
                 if ycoord!*>ymax!* then ymax!* := ycoord!*>>
         else prin2!* get('expt,'prtch);
        prin2!* if numberp cdr w and minusp cdr w then list cdr w 
                 else cdr w;
        if !*nat and !*eraise
          then <<ycoord!* := ycoord!*-1;
                 if ymin!*>ycoord!* then ymin!* := ycoord!*>>;
        return;
    c:  prin2!* "(";
        if not atom caar w then xprinf(car w,nil,nil)
         else sqprint cadar w;
        prin2!* ")";
        go to b
   end;

symbolic procedure varpri(u,v,w);
   begin scalar x;
   %U is expression being printed
   %V is the original form that was evaluated.
   %W is an id that indicates if U is the first, only or last element
   %  in the current set (or NIL otherwise).
    if null u then u := 0; 
    if !*nero and u=0 then return nil;
    v := setvars v;
    if (x := getrtype u) and flagp(x,'sprifn)
      then return if null v then apply1(get(get(x,'tag),'prifn),u)
               else maprin list('setq,car v,u);
    if w memq '(first only) then terpri!* t;
    if !*fort then return fvarpri(u,v,w);
    if v then u := 'setq . aconc(v,u);
    maprin u;
    if null w or w eq 'first then return nil
     else if not !*nat then prin2!* "$";
    terpri!*(not !*nat);
    return nil
   end;

symbolic procedure setvars u;
   if atom u then nil
    else if car u memq '(setel setk)
     then eval cadr u . setvars caddr u
    else if car u eq 'setq then cadr u . setvars caddr u
    else nil;

endmodule;


module mprint; % Basic output package for symbolic expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*list !*ratpri);

global '(!*eraise
         !*fort
         !*nat
         !*nero
         !*outp
         !*period
         !*pri
         !*revpri
         cardno!*
         fortwidth!*
         initl!*
         nat!*!*
         obrkp!*
         orig!*
         pline!*
         posn!*
         spare!*
         varnam!*
         wtl!*
         ycoord!*
         ymax!*
         ymin!*);

switch list,ratpri,revpri;

%Global variables initialized in this section;

% SPARE!* should be set in the system dependent code module.

!*eraise := t;
!*nat := nat!*!* := t;
cardno!*:=20;
fortwidth!* := 70;
obrkp!* := t;
orig!*:=0;
posn!* := 0;
varnam!* := 'ans;
ycoord!* := 0;
ymax!* := 0;
ymin!* := 0;

flag ('(cardno!* fortwidth!*),'share);

initl!* := append('(orig!* pline!*),initl!*);

put('orig!*,'initl,0);

flag('(linelength),'opfn);  %to make it a symbolic operator;

symbolic procedure mathprint l;
   begin terpri!* t; maprin l; terpri!* t end;

symbolic procedure maprin u;
   maprint(u,0);

symbolic procedure maprint(l,p);
   begin scalar x,y;
        if null l then return nil
         else if atom l then go to b
         else if stringp l then return prin2!* l
         else if not atom car l then maprint(car l,p)
%        else if x := get(car l,'specprn)
%         then return apply1(x,if flagp(x,'full) then l else cdr l)
         else if (x := get(car l,'prifn))
                 and not(apply1(x,l) eq 'failed)
          then return l
         else if x := get(car l,'infix) then go to a
         else prin2!* car l;
        prin2!* "(";
        obrkp!* := nil;
        if cdr l then inprint('!*comma!*,0,cdr l);
        obrkp!* := t;
    e:  prin2!* ")";
        return l;
    b:  if numberp l then go to d;
    c:  return prin2!* l;
    d:  if not l<0 or p<get('minus,'infix) then go to c;
        prin2!* "(";
        prin2!* l;
        go to e;
    a:  p := not x>p;
        if not p then go to g;
        y := orig!*;
        prin2!* "(";
        orig!* := if posn!*<18 then posn!* else orig!*+3;
    g:  if car l eq 'expt then exptpri(x,cdr l)
         else inprint(car l,x,cdr l);
        if not p then return l;
        prin2!* ")";
        orig!* := y;
        return l
   end;

symbolic procedure exptpri(p,l);
   % Prints expression in an exponent notation.
   begin scalar !*list,bool,x;
      bool := !*nat and !*eraise;
      if flatsizec car l+flatsizec cadr l
        >(linelength nil-spare!*)-posn!*
    then terpri!* t;   % to avoid breaking exponent over line.
     if bool and null atom car l and idp caar l
         and (x := get(caar l,'prifn))
         and (get(x,'expt) eq 'inbrackets)
       % to avoid mix up of indices and exponents.
       then<<prin2!* "("; maprint(car l,p); prin2!* ")">>
      else maprint(car l,p);
      if bool
    then <<ycoord!* := ycoord!*+1;
           if ycoord!*>ymax!* then ymax!* := ycoord!*>>
       else prin2!* get('expt,'prtch);
      % If you want brackets around exponents, replace 0 by p in next
      % line.
      begin scalar !*ratpri;
     l := cadr l;
     if eqcar(l,'quotient) and eqcar(cadr l,'minus)
       then l := list('minus,list(car l,cadadr l,caddr l))
      else l := negnumberchk l;
     maprint(l,if bool then 0 else p)
    end;
      if bool
    then <<ycoord!* := ycoord!*-1;
           if ymin!*>ycoord!* then ymin!* := ycoord!*>>
   end;

symbolic procedure inprint(op,p,l);
   begin scalar x,y;
        if op eq 'plus and !*revpri then l := reverse l;
           % print sum arguments in reverse order.
        if get(op,'alt) then go to a
         else if op eq 'setq and not atom (x := car reverse l)
            and idp car x and (y := getrtype x)
            and (y := get(get(y,'tag),'setprifn))
           then return apply2(y,car l,x);
         if null atom car l and idp caar l
             and !*nat and (x := get(caar l,'prifn))
             and (get(x,op) eq 'inbrackets)
           % to avoid mix up of indices and exponents.
           then<<prin2!* "("; maprint(car l,p); prin2!* ")">>
          else maprint(car l,p);
    a0: l := cdr l;
    a:  if null l then return nil
         else if atom car l or not(op eq get!*(caar l,'alt))
          then <<oprin op; maprint(negnumberchk car l,p)>>
        % difficult problem of negative numbers needing to be in
        % prefix form for pattern matching.
         else maprint(car l,p);
        go to a0
   end;

symbolic procedure flatsizec u;
   if null u then 0
    else if atom u then lengthc u
    else flatsizec car u + flatsizec cdr u + 1;

symbolic procedure oprin op;
   (lambda x;
         if null x then <<prin2!* " "; prin2!* op; prin2!* " ">>
          else if !*fort then prin2!* x
          else if !*list and obrkp!* and op memq '(plus minus)
           then <<terpri!* t; prin2!* x>>
          else if flagp(op,'spaced)
           then <<prin2!* " "; prin2!* x; prin2!* " ">>
          else prin2!* x)
   get(op,'prtch);

symbolic procedure prin2!* u;
   begin integer m,n;
        if !*fort then return fprin2 u;
        n := lengthc u;
        if n>(linelength nil-spare!*) then go to d;
        m := posn!*+n;
    a:  if m>(linelength nil-spare!*) then go to c
         else if not !*nat then prin2 u
         else pline!* := (((posn!* . m) . ycoord!*) . u) . pline!*;
    b:  return (posn!* := m);
    c:  terpri!* t;
        if (m := posn!*+n)<=(linelength nil-spare!*) then go to a;
    d:  %identifier longer than one line;
        if !*fort then rederr list(u,"too long for FORTRAN");
        %let LISP print the atom;
        terpri!* nil;
        prin2t u;
        m := remainder(n,(linelength nil-spare!*));
        go to b
   end;

symbolic procedure terpri!* u;
   begin integer n;
        if !*fort then return fterpri(u)
         else if not !*nat 
          then <<if u then terpri(); return nil>>
         else if not pline!* then go to b;
        n := ymax!*;
        pline!* := reverse pline!*;
    a:  scprint(pline!*,n);
        terpri();
        if n= ymin!* then go to b;
        n := n-1;
        go to a;
    b:  if u then terpri();
    c:  pline!* := nil;
        posn!* := orig!*;
        ycoord!* := ymax!* := ymin!* := 0
   end;

symbolic procedure scprint(u,n);
   begin scalar m;
        posn!* := 0;
    a:  if null u then return nil
         else if not(cdaar u=n) then go to b
         else if not((m:= caaaar u-posn!*)<0) then spaces m;
        prin2 cdar u;
        posn!* := cdaaar u;
    b:  u := cdr u;
        go to a
   end;

endmodule;


module ratprin;   % Printing standard quotients.

% Author: Eberhard Schruefer.

% Modifications by: Anthony C. Hearn.

fluid '(!*list !*mcd !*ratpri dmode!*);

global '(!*fort !*nat ycoord!* ymin!* ymax!* posn!* orig!* pline!*
         spare!*);

switch ratpri;

!*ratpri := t;   % default value if this module is loaded.

put('quotient,'prifn,'quotpri);

symbolic procedure quotpri u;
   % *mcd is included here since it uses rational domain elements.
   begin scalar dmode;
      if null !*ratpri or null !*nat or !*fort or !*list or null !*mcd
           then return 'failed
       else if flagp(dmode!*,'ratmode)
    then <<dmode := dmode!*; dmode!* := nil>>;
      u := ratfunpri1 u;
      if dmode then dmode!* := dmode;
      return u
   end;

symbolic procedure ratfunpri1 u;
   begin scalar pline,npline,dpline,x,y;
         integer ycoord,ymin,ymax,orig,posn,lenden,lennum,
                 hightnum,hightden,orgnum,orgden,offsnum,ll;
       ll := linelength nil - spare!* - 2;
       if ((x := chk!-printlength(cadr u,orig!*,ll)) eq 'failed)
          or ((y := chk!-printlength(caddr u,orig!*,ll)) eq 'failed)
          then go to doesntfit     %It does also not fit on a new line
        else if x>(ll-posn!*)
                or y>(ll-posn!*) then terpri!* t; %It fits on a new line
       ycoord := ycoord!*;
       ymin   := ymin!*;
       ymax   := ymax!*;
       posn   := posn!*;
       orig   := orig!*;
       pline  := pline!*;
       pline!* := nil;
       ycoord!* := ymin!* := ymax!* := posn!* := orig!* := 0;
       maprin cadr u;
       npline   := pline!*;
       lennum   := posn!*;
       offsnum  := 1 - ymin!*;
       hightnum := ymax!* - ymin!* + 1;
       pline!* := nil;
       ycoord!* := ymin!* := ymax!* := posn!* := orig!* := 0;
       maprin caddr u;
       dpline   := pline!*;
       lenden   := posn!*;
       hightden := ymax!* - ymin!* + 1;
       pline!* := nil;
       if lenden > lennum then
          orgnum := (lenden - lennum)/2
        else
          orgden := (lennum - lenden)/2;
       pline!* := append(update!-pline(orgnum + posn + 1,
                       offsnum + ycoord,npline),
                  append(update!-pline(orgden + posn + 1,
                        ycoord - ymax!* - 1,
                          dpline),pline));
       ymin!* := ycoord - hightden;
       ymax!* := ycoord + hightnum;
       if ymin!* > ymin then ymin!* := ymin;
       if ymax!* < ymax then ymax!* := ymax;
       ycoord!* := ycoord;
       posn!* := posn;
       orig!* := orig;
       for j := 1:(max(lenden,lennum)+2) do prin2!* "-";
       return;
       doesntfit:
            u :=  cdr u;
            maprint(car u,get('quotient,'infix));
            oprin 'quotient;
            maprint(negnumberchk cadr u,get('quotient,'infix))
         end;

symbolic procedure update!-pline(x,y,pline);
   for each j in pline collect
       (((caaar j + x) . (cdaar j + x)) . (cdar j + y)) . cdr j;

symbolic procedure chk!-printlength(u,m,n);
   %This one should better be table driven.
   begin scalar l;
     return
       if atom u then
          if (l := lengthc u + m) > n then 'failed
           else l
        else if car u eq 'expt
           then if null((l := chk!-printlength(cadr u,m,n))
                        eq 'failed) and l<n
                   then chk!-printlength(caddr u,l,n)
                 else 'failed
        else if car u eq 'minus
           then if atom cadr u then
                   if (l := 3 + lengthc cadr u + m) > n
                      then 'failed
                    else l
                 else chk!-printlength(cadr u,m+5,n)
      else if car u eq 'plus
           then begin u := cdr u;
                  if (l := chk!-printlength(car u,m,n))
                      eq 'failed
                     then return 'failed;
                  a: if null cdr(u := cdr u)
                       then
                        return chk!-printlength(
                            if eqcar(car u,'minus)
                               then cadar u else car u,3+l,n);
                     if ((l := chk!-printlength(
                            if eqcar(car u,'minus)
                               then cadar u else car u,3+l,n))
                         eq 'failed)
                       then return 'failed
                      else go to a
                  end
      else if car u eq 'times
           then begin u := cdr u;
                  if (l := chk!-printlength(car u,
                                     m+if eqcar(car u,'plus)
                                           then 2 else 0,n))
                      eq 'failed then return 'failed;
                  a: if null cdr(u := cdr u)
                        then return chk!-printlength(car u,
                                     l+if eqcar(car u,'plus)
                                            then 3 else 1,n);
                     if ((l := chk!-printlength(car u,
                                     l+if eqcar(car u,'plus)
                                            then 3 else 1,n))
                         eq 'failed)
                          then return 'failed
                            else go to a
                    end
      else if car u eq 'quotient
           then begin scalar ld;
                  u := cdr u;
                   if (l := chk!-printlength(car u,m+2,n))
                     eq 'failed then return 'failed
                   else if (ld := chk!-printlength(cadr u,m+2,n))
                     eq 'failed then return 'failed;
                   return max(l,ld)
                end
      else if car u eq 'difference
           then begin u := cdr u;
                  if (l := chk!-printlength(car u,m+3,n))
                      eq 'failed then return 'failed
                   else return chk!-printlength(cadr u,m+l,n)
                 end
      else if get(car u,'klist)
            then begin  l := lengthc car u+2;
                  u := cdr u;
                  if (l := chk!-printlength(car u,m+l,n))
                      eq 'failed
                     then return 'failed
                   else if null cdr u then return l;
                  a: if null cdr(u := cdr u)
                       then
                        return chk!-printlength(car u,1+l,n);
                     if ((l := chk!-printlength(car u,1+l,n))
                         eq 'failed)
                       then return 'failed
                      else go to a
                  end
      else if ((l := flatsizec u + m)) > n then 'failed else l
   end;

endmodule;


module fortpri; % FORTRAN output package for expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(scountr explis fbrkt fvar nchars svar);

global '(!*fort
         !*nat
         !*nero
         !*outp
         !*period
         !*pri
         cardno!*
         fortwidth!*
         initl!*
         nat!*!*
         obrkp!*
         orig!*
         pline!*
         posn!*
         spare!*
         varnam!*
         wtl!*
         ycoord!*
         ymax!*
         ymin!*);

%Global variables initialized in this section;

% SPARE!* should be set in the system dependent code module.

!*nat := nat!*!* := t;
cardno!*:=20;
fortwidth!* := 70;
obrkp!* := t;
orig!*:=0;
posn!* := 0;
varnam!* := 'ans;
ycoord!* := 0;
ymax!* := 0;
ymin!* := 0;

flag ('(cardno!* fortwidth!*),'share);

initl!* := append('(orig!* pline!*),initl!*);

put('orig!*,'initl,0);

symbolic procedure varname u;
   %sets the default variable assignment name;
   varnam!* := car u;

rlistat '(varname);

symbolic procedure flength(u,chars);
   if chars<0 then chars
    else if atom u
     then chars-if numberp u then if fixp u then flatsizec u+1
                                   else flatsizec u
                 else flatsizec((lambda x; if x then x else u)
                                   get(u,'prtch))
    else flength(car u,flenlis(cdr u,chars)-2);

symbolic procedure flenlis(u,chars);
   if null u then chars
    else if chars<0 then chars
    else if atom u then flength(u,chars)
    else flenlis(cdr u,flength(car u,chars));

symbolic procedure fmprint(l,p);
   begin scalar x;
        if null l then return nil
         else if atom l then go to b
         else if stringp l then return fprin2 l
         else if not atom car l then fmprint(car l,p)
%        else if x := get(car l,'specprn)
%         then return apply1(x,cdr l)
         else if (x := get(car l,'prifn))
            and not((x := apply1(x,l)) eq 'failed)
          then return x
         else if x := get(car l,'infix) then go to a
         else fprin2 car l;
        fprin2 "(";
        fbrkt := nil . fbrkt;
%       x := !*period; !*period := nil; % Turn off . inside an op exp
        if cdr l then fnprint('!*comma!*,0,cdr l);
%       !*period := x;
    e:  fprin2 ")";
        return fbrkt := cdr fbrkt;
    b:  if numberp l then go to d;
    c:  return fprin2 l;
    d:  if not l<0 then go to c;
        fprin2 "(";
        fbrkt := nil . fbrkt;
        fprin2 l;
        go to e;
    a:  p := not x>p;
        if p then <<fprin2 "("; fbrkt := nil . fbrkt>>;
        fnprint(car l,x,cdr l);
        if p then <<fprin2 ")"; fbrkt := cdr fbrkt>>
   end;

symbolic procedure fnprint(op,p,l);
   begin
        if op eq 'expt then return fexppri(p,l)
         else if get(op,'alt) then go to a;
        fmprint(car l,p);
    a0: l := cdr l;
    a:  if null l then return nil
         else if not atom car l and op eq get!*(caar l,'alt)
          then go to b;
        foprin op;
    b:  fmprint(car l,p);
        go to a0
   end;

symbolic procedure fexppri(p,l);
   begin scalar pperiod;
      fmprint(car l,p);
      foprin 'expt;
      pperiod := !*period;
      if numberp cadr l then !*period := nil else !*period := t;
      fmprint(cadr l,p);
      !*period := pperiod
   end;

symbolic procedure foprin op;
   (lambda x; if null x then fprin2 op else fprin2 x) get(op,'prtch);

symbolic procedure fvarpri(u,v,w);
   %prints an assignment in FORTRAN notation;
   begin integer scountr,llength,nchars; scalar explis,fvar,svar;
        llength := linelength nil;
        if not posintegerp cardno!*
          then typerr(cardno!*,"FORTRAN card number");
        if not posintegerp fortwidth!*
          then typerr(fortwidth!*,"FORTRAN line width");
        linelength fortwidth!*;
        if stringp u
          then return <<fprin2 u; 
                        if w eq 'only then fterpri(t);
                        linelength llength>>;
        if eqcar(u,'!*sq) then u := prepsq!* cadr u;
        scountr := 0;
        nchars := ((linelength nil-spare!*)-12)*cardno!*;
           %12 is to allow for indentation and end of line effects;
        svar := varnam!*;
        fvar := if null v then svar else car v;
        if posn!*=0 and w then fortpri(fvar,u,w)
         else fortpri(nil,u,w);
                % should mean expression preceded by a string.
        linelength llength
   end;

symbolic procedure fortpri(fvar,xexp,w);
   begin scalar fbrkt;
        if flength(xexp,nchars)<0
          then xexp := car xexp . fout(cdr xexp,car xexp,w);
        if fvar 
          then <<posn!* := 0;
                 fprin2 "      ";
                 fmprint(fvar,0);
                 fprin2 "=">>;
        fmprint(xexp,0);
        if w then fterpri(w)
   end;

symbolic procedure fout(args,op,w);
   begin integer ncharsl; scalar distop,x,z;
        ncharsl := nchars;
        if op memq '(plus times) then distop := op;
        while args do
         <<x := car args;
           if atom x and (ncharsl := flength(x,ncharsl))
              or (null cdr args or distop)
                and (ncharsl := flength(x,ncharsl))>0
             then z := x . z
            else if distop and flength(x,nchars)>0
             then <<z := fout1(distop . args,w) . z;
                    args := list nil>>
            else <<z := fout1(x,w) . z;
                   ncharsl := flength(op,ncharsl)>>;
           ncharsl := flength(op,ncharsl);
           args := cdr args>>;
        return reversip!* z
   end;

symbolic procedure fout1(xexp,w);
   begin scalar fvar;
      fvar := genvar();
      explis := (xexp . fvar) . explis;
      fortpri(fvar,xexp,w);
      return fvar
   end;

symbolic procedure fprin2 u;
   % FORTRAN output of U;
   begin integer m,n;
        n := flatsizec u;
        m := posn!*+n;
        if numberp u and fixp u and !*period then m := m+1;
        if m<(linelength nil-spare!*) then posn!* := m
         else <<terpri(); spaces 5; prin2 ". "; posn!* := n+7>>;
        prin2 u;
        if numberp u and fixp u and !*period then prin2 "."
   end;

symbolic procedure fterpri(u);
   <<if not posn!*=0 and u then terpri();
     posn!* := 0>>;

symbolic procedure genvar;
   intern compress append(explode svar,explode(scountr := scountr + 1));

endmodule;


module gint;  % Support for gaussian integers (complex numbers).

% Author: Eberhard Schruefer.

global '(domainlist!*);

fluid '(!*complex);

switch complex;

domainlist!* := union('(!:gi!:),domainlist!*);

symbolic procedure setcmpxmode(u,bool);
   % Sets polynomial domain mode in complex case.
   begin scalar x,y;
      x := get(u,'tag);
      if u eq 'complex
        then if null dmode!*
               then return if null bool then nil
                            else <<put('i,'idvalfn,'mkdgi);
                                   setdmode1('complex,bool)>>
              else if null bool
               then return if null !*complex then nil
                     else if get(dmode!*,'dname) eq 'complex
                      then <<remprop('i,'idvalfn);
                             setdmode1('complex,nil)>>
                     else <<remprop('i,'idvalfn);
                           setdmode1(get(get(dmode!*,'realtype),'dname),
                                       t)>>
              else if dmode!* eq '!:gi!: then return nil
              else if not (y := get(dmode!*,'cmpxtype))
               then dmoderr(dmode!*,x)
              else <<put('i,'idval,get(car y,'ivalue));
                     return setdmode1(get(car y,'dname),bool)>>
       else if null bool
        then <<put('i,'idvalfn,'mkdgi);
               return setdmode1('complex,t)>>
       else <<u := get(u,'tag);
              y := get(u,'cmpxtype);
              if null y then dmoderr(u,'!:gi!:);
              put('i,'idvalfn,get(car y,'ivalue));
              return setdmode1(get(car y,'dname),bool)>>
   end;

put('complex,'tag,'!:gi!:);
put('!:gi!:,'dname,'complex);
put('!:gi!:,'i2d,'!*i2gi);
put('!:gi!:,'minusp,'giminusp!:);
put('!:gi!:,'zerop,'gizerop!:);
put('!:gi!:,'onep,'gionep!:);
put('!:gi!:,'plus,'giplus!:);
put('!:gi!:,'difference,'gidifference!:);
put('!:gi!:,'times,'gitimes!:);
put('!:gi!:,'quotient,'giquotient!:);
put('!:gi!:,'divide,'gidivide!:);
put('!:gi!:,'gcd,'gigcd!:);
put('!:gi!:,'factorfn,'gifactor!:);
put('!:gi!:,'rationalizefn,'girationalize!:);
put('!:gi!:,'prepfn,'giprep!:);
put('!:gi!:,'intequivfn,'gintequiv!:);
put('!:gi!:,'specprn,'giprn!:);
put('!:gi!:,'prifn,'giprn!:);
put('!:gi!:,'cmpxfn,'mkgi);

put('!:gi!:,'units,'(((!:gi!: 0 . 1) . (!:gi!: 0 . -1))
                     ((!:gi!: 0 . -1) . (!:gi!: 0 . 1))));

symbolic procedure !*i2gi u; '!:gi!: . (u . 0);

symbolic procedure giminusp!: u;
   %*** this is rather a test for u being in a canonical form! ***;
   if cddr u = 0 then minusp cadr u else minusp cddr u;

symbolic procedure gizerop!: u;
   cadr u = 0 and cddr u = 0;

symbolic procedure gionep!: u;
   cadr u=1 and cddr u=0;

symbolic procedure gintequiv!: u;
   if cddr u=0 then cadr u else nil;

symbolic procedure mkdgi u;
   ('!:gi!: . (0 . 1)) ./ 1;

symbolic procedure mkgi(re,im);
   '!:gi!: . (re . im);

symbolic procedure giplus!:(u,v);
   mkgi(cadr u+cadr v,cddr u+cddr v);

symbolic procedure gidifference!:(u,v);
   mkgi(cadr u-cadr v,cddr u-cddr v);

symbolic procedure gitimes!:(u,v);
   (lambda r1,i1,r2,i2;
       mkgi(r1*r2-i1*i2,r1*i2+r2*i1))
    (cadr u,cddr u,cadr v,cddr v);

symbolic procedure giquotient!:(u,v);
   begin integer r1,i1,r2,i2,d; scalar rr,ii;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     d := r2*r2+i2*i2;
     rr := divide(r1*r2+i1*i2,d);
     ii := divide(i1*r2-i2*r1,d);
     return if cdr ii=0 and cdr rr=0 then mkgi(car rr,car ii)
             else '!:gi!: . (0 . 0)
   end;

symbolic procedure gidivide!:(u,v);
   begin integer r1,i1,r2,i2,d,rr,ir,rq,iq;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     d := r2*r2+i2*i2;
     rq := r1*r2+i1*i2;
     iq := i1*r2-i2*r1;
     rq := car divide(2*rq+if rq<0 then -d else d,2*d);
     iq := car divide(2*iq+if iq<0 then -d else d,2*d);
     rr := r1-(rq*r2-iq*i2);
     ir := i1-(iq*r2+rq*i2);
     return mkgi(rq,iq) . mkgi(rr,ir)
   end;

symbolic procedure giremainder(u,v);
   begin integer r1,i1,r2,i2,d,rr,ir,rq,iq;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     d := r2*r2+i2*i2;
     rq := r1*r2+i1*i2;
     iq := i1*r2-i2*r1;
     rq := car divide(2*rq+if rq<0 then -d else d,2*d);
     iq := car divide(2*iq+if iq<0 then -d else d,2*d);
     rr := r1-(rq*r2-iq*i2);
     ir := i1-(iq*r2+rq*i2);
     return '!:gi!: . (rr . ir)
   end;

symbolic procedure gigcd!:(u,v);
   % Straightforward Euclidean algorithm.
   if gizerop!: v then fqa u else gigcd!:(v,giremainder(u,v));

symbolic procedure fqa u;
   %calculates the unique first-quadrant associate of u;
   if cddr u=0 then abs cadr u
    else if cadr u=0 then '!:gi!: . (0 . abs cddr u)
    else if (cadr u*cddr u)>0 then
            '!:gi!: . (abs cadr u . abs cddr u)
    else '!:gi!: . (abs cddr u . abs cadr u);

symbolic procedure gifactor!: u;
   % B. Trager's algorithm.
   begin scalar x,y,norm,aftrs,ifctr,ftrs,mvu,dmode!*,!*exp,w,z;
     !*exp := t;
     ifctr := factorf fd2f u;
     dmode!* := '!:gi!:;
     w := car ifctr;
     if null(ifctr := cdr ifctr) then return list w;
     for each f in ifctr do
       begin integer s; %calculate a square free norm;
             scalar l;
         go to b;
         a: l := list(mvu . prepf addf(!*k2f mvu,multd(s,!*k2f 'i)));
         b: y := numr subf1(car f,l);
            if domainp y then <<w := multd(y,w); return>>;
            mvu := mvar y;
            if realp y then <<s := s-1; go to a>>;
            norm := multf(y,conj y);
            if not sqfrp norm then <<s := s-1; go to a>>;
            dmode!* := nil;
            ftrs := factorf norm;
            dmode!* := '!:gi!:;
            l := if s=0 then nil
                  else list(mvu . prepf addf(!*k2f mvu,
                                             negf multd(s,!*k2f 'i)));
            for each j in cdr ftrs do
              <<x := gcdf!*(car j,y);
                y := quotf!*(y,x);
                z := if l then numr subf1(x,l) else x;
                aftrs := (z . cdr f) . aftrs>>
         end;
         return multd(car ftrs,w) . aftrs
       end;

symbolic procedure gaussfactorize u;
   begin scalar ftrs,x,y,!*exp; integer n;
     !*exp := t;
     x := gifactor!: expnd !*a2f car u;
     y := if null cdr u then 'gfactor else cadr u;
     ftrs := (0 . car x) . nil;
     for each j in cdr x do
       for k := 1:cdr j do
         ftrs := ((n:=n+1) . mk!*sq(car j ./ 1)) . ftrs;
     return multiple!-result(ftrs,y)
   end;

put('gfactorize,'simpfn,'gaussfactorize);

symbolic procedure realp u;
   if domainp u
     then atom u
        or not get(car u,'cmpxfn)
        or cddr u = cddr apply1(get(car u,'i2d),1)
    else realp lc u and realp red u;

symbolic procedure fd2f u;
   if atom u then u
    else if car u eq '!:gi!:
            then addf(!*n2f cadr u,multf(!*k2f 'i,!*n2f cddr u))
    else addf(multf(!*p2f lpow u,fd2f lc u),fd2f red u);


symbolic procedure sqfrp u;
   domainp gcdf!*(u,diff(u,mvar u));

symbolic procedure giprep!: u;  %giprep1 cdr u;
   prepsq!* addsq(!*n2f cadr u ./ 1,
                  multsq(!*n2f cddr u ./ 1, !*k2q 'i));

symbolic procedure giprep1 u;  %not used now;
   if cdr u=0 then car u
    else if car u=0 then retimes list(cdr u,'i)
    else begin scalar gn;
           gn := gcdn(car u,cdr u);
           return retimes list(gn,
                       replus list(car u/gn,retimes list(cdr u/gn,'i)))
         end;

symbolic procedure giprn!: v;
   (lambda u;
    if atom u or (car u eq 'times) then maprin u
     else <<prin2!* "("; maprin u; prin2!* ")" >>) giprep!: v;

symbolic procedure girationalize!: u;
   %Rationalizes standard quotient u over the gaussian integers.
   begin scalar x,y,z;
      y := denr u;
      z := conj y;
      if y=z then return u;
      x := multf(numr u,z);
      y := multf(y,z);
      return x ./ y
   end;


%*** some utility functions ***;

symbolic procedure repart u;
   begin scalar x;
      return if atom u then u
              else if domainp u and (x := get(car u,'cmpxfn))
               then apply2(x,cadr u,0)
              else addf(multpf(lpow u,repart lc u),repart red u)
   end;

symbolic procedure impart u;
   begin scalar x;
      return if atom u then nil
              else if domainp u and (x := get(car u,'cmpxfn))
               then apply2(x,cddr u,0)
              else addf(multpf(lpow u,impart lc u),impart red u)
   end;

symbolic procedure conj u;
   begin scalar x;
      return if atom u then u
              else if domainp u and (x := get(car u,'cmpxfn))
               then apply2(x,cadr u,!:minus cddr u)
              else addf(multpf(lpow u,conj lc u),conj red u)
   end;

deflist('((repart repart) (impart impart) (conj conj)),'polyfn);

initdmode 'complex;

endmodule;


module gfloat; % Support for gaussian floats.

% Authors: Barbara Gates and Eberhard Schruefer.

global '(domainlist!* e!-value!* pi!-value!*);

fluid '(!*complex!_float);

% This module needs gint to be loaded too.

domainlist!*:=union('(!:gf!:),domainlist!*);

put('complex!_float,'tag,'!:gf!:);
put('!:gf!:,'dname,'complex!_float);
put('!:gf!:,'i2d,'!*i2gf);
put('!:gf!:,'minusp,'gfminusp!:);
put('!:gf!:,'zerop,'gfzerop!:);
put('!:gf!:,'onep,'gfonep!:);
put('!:gf!:,'plus,'gfplus!:);
put('!:gf!:,'difference,'gfdifference!:);
put('!:gf!:,'times,'gftimes!:);
put('!:gf!:,'quotient,'gfquotient!:);
put('!:gf!:,'prepfn,'gfprep!:);
put('!:gf!:,'prifn,'gfprn!:);
put('!:gf!:,'rationalizefn,'girationalize!:);
put('!:rn!:,'!:gf!:,'rn2gf);
put('!:ft!:,'!:gf!:,'ft2gf);
put('!:gf!:,'!:ft!:,'gf2f);
put('!:gf!:,'cmpxfn,'mkgf);
put('!:gf!:,'ivalue,'mkdgf);
put('!:gf!:,'realtype,'!:ft!:);
flag('(!:gf!:),'field);

symbolic procedure mkdgf u;
   ('!:gf!: . (0.0 . 1.0)) ./ 1;

smacro procedure mkgf(rp,ip);
   '!:gf!: . (rp . ip);

symbolic procedure !*i2gf u;
   '!:gf!: . (float u .  0.0);

symbolic procedure rn2gf u; mkgf(cdr !*rn2ft u,0.0);

symbolic procedure ft2gf u; mkgf(cdr u,0.0);

symbolic procedure gf2f u;
%  if cddr u=0.0 then '!:ft!: . cadr u else
   if zerop cddr u then '!:ft!: . cadr u else
    rederr "Conversion to float requires zero imaginary part";

symbolic procedure gfminusp!: u;
   % This doesn't make much sense.
%  if abs cddr u<0.000001 then cadr u<0.0 else cddr u<0.0;
   if abs cddr u<0.000001 then minusp cadr u else minusp cddr u;

symbolic procedure gfzerop!: u;
%  cadr u=0.0 and cddr u=0.0;
   zerop cadr u and zerop cddr u;

symbolic procedure gfonep!: u;
%cddr u =0.0 and ftonep!:('!:ft!: . cadr u); %this is too restrictive;
   ftonep!:('!:ft!: . (cadr u+cddr u)) and
   ftonep!:('!:ft!: . cadr u);

symbolic procedure gfplus!:(u,v);
   mkgf(cadr u+cadr v,cddr u+cddr v);

symbolic procedure gfdifference!:(u,v);
   mkgf(cadr u-cadr v,cddr u-cddr v);

symbolic procedure gftimes!:(u,v);
   begin scalar r1,i1,r2,i2,rr,ii;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     rr := r1*r2-i1*i2;
     ii := r1*i2+r2*i1;
     return mkgf(rr,ii)
   end;

symbolic procedure gfquotient!:(u,v);
   begin scalar r1,i1,r2,i2,rr,ii,d;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     d := r2*r2+i2*i2;
     rr := r1*r2+i1*i2;
     ii := i1*r2-i2*r1;
     return mkgf(rr/d,ii/d)
   end;

symbolic procedure gfprep!: u; gfprep1 cdr u;
%begin scalar dmode!*;
%dmode!*:='!:ft!:;
%return
%prepsq!* addsq(('!:ft!: . cadr u) ./ 1,
%               multsq(('!:ft!: . cddr u) ./ 1,!*k2q 'i))
%end;

symbolic procedure gfprep1 u;
%  if cdr u=0.0 then car u
   if zerop cdr u then car u
%   else if car u=0.0 then if ftonep!:('!:ft!: . cdr u) then 'i
    else if zerop car u then if ftonep!:('!:ft!: . cdr u) then 'i
                            else list('times,cdr u,'i)
    else list('plus,car u,if ftonep!:('!:ft!: . cdr u) then 'i
                           else list('times,cdr u,'i));

symbolic procedure gfprn!: u;
(lambda v; if atom v or car v eq 'times
           or car v memq domainlist!* then maprin v
     else <<prin2!* "("; maprin v; prin2!* ")">>) gfprep1 cdr u;


% *** Elementary functions.

deflist('((e egf!*) (pi pigf!*)),'!:gf!:);

symbolic procedure egf!*; mkgf(e!-value!*,0.0);

symbolic procedure pigf!*; mkgf(pi!-value!*,0.0);

deflist('((expt gfexpt) (sin gfsin) (cos gfcos) (tan gftan)
          (asin gfasin) (acos gfacos) (atan gfatan)
          (log gflog)),'!:gf!:);


symbolic procedure gfexpt(u,v);
   begin scalar re1,im1,re2,im2,norm,ang,angr;
     re1 := cadr u; im1 := cddr u;
     re2 := cadr v; im2 := cddr v;
     norm := sqrt(re1*re1+im1*im1);
     ang := ftarg!: u;
     angr := im2*log norm+re2*ang;
     norm := exp(log norm*re2-im2*ang);
     return mkgf(norm*cos angr,norm*sin angr)
   end;


symbolic procedure ftarg!: u;
%Returns ftarg u in the range (-pi,+pi);
% (lambda x,y; if y=0.0 then if x<0.0 then pi!-value!*
 (lambda x,y; if zerop y then if minusp x then pi!-value!*
                                    else 0.0 else
%            if x=0.0 then if y<0.0 then -pi!-value!*/2 else
             if zerop x then if minusp y then -pi!-value!*/2 else
                                          pi!-value!*/2 else
%            if x<0.0 and y<0.0 then atan(y/x)-pi!-value!*
             if minusp x and minusp y then atan(y/x)-pi!-value!*
%               else if x<0.0 and not(y<0.0) then
                else if minusp x and not minusp y then
                                     atan(y/x)+pi!-value!*
              else atan(y/x)) (cadr u,cddr u);

put('ftarg!:,'!:gf!:,'ftarg!:);

symbolic procedure gfsin u;
   mkgf(sin cadr u*cosh cddr u,cos cadr u*sinh cddr u);

symbolic procedure gfcos u;
   mkgf(cos cadr u*cosh cddr u,-sin cadr u*sinh cddr u);

symbolic procedure gftan u;
   begin scalar v;
     v := cos(2.0*cadr u)+cosh(2.0*cddr u);
     return mkgf(sin(2.0*cadr u)/v,sinh(2.0*cddr u)/v)
   end;

symbolic procedure gfasin u;
   begin scalar a,b,c;
     a := 0.5*sqrt(expt(cadr u+1.0,2)+cddr u*cddr u);
     b := 0.5*sqrt(expt(cadr u-1.0,2)+cddr u*cddr u);
     c := a+b;
     b := a-b;
     a := c;
     c := a+sqrt(a*a-1.0);
     return mkgf(asin b,log c)
   end;

symbolic procedure gfacos u;
   begin scalar a,b,c;
     a := 0.5*sqrt(expt(cadr u+1.0,2)+cddr u*cddr u);
     b := 0.5*sqrt(expt(cadr u-1.0,2)+cddr u*cddr u);
     c := a+b;
     b := a-b;
     a := c;
     c := a+sqrt(a*a-1.0);
     return mkgf(acos b,-1.0*log c)
   end;

symbolic procedure gfatan u;
   gftimes!:(gflog(gfquotient!:(
                   gfplus!:(!*i2gf 1,gftimes!:(mkgf(0.0,-1.0),u)),
                   gfplus!:(!*i2gf 1,gftimes!:(mkgf(0.0,1.0),u)))),
             mkgf(0.0,0.5));


symbolic procedure gflog u;
   begin scalar norm;
     norm := sqrt(cadr u*cadr u+cddr u*cddr u);
     return mkgf(log norm,ftarg!: u)
   end;

symbolic procedure sinh u; 0.5*(exp u-exp(-u));

symbolic procedure cosh u; 0.5*(exp u+exp(-u));

initdmode 'complex!_float;

endmodule;


module modular; % *** Tables for modular integers ***.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

global '(domainlist!*);

fluid '(!*modular current!-modulus alglist!* dmode!*);

switch modular;

domainlist!* := union('(!:mod!:),domainlist!*);

put('modular,'tag,'!:mod!:);
put('!:mod!:,'dname,'modular);
flag('(!:mod!:),'field);
flag('(!:mod!:),'convert);
put('!:mod!:,'i2d,'!*i2mod);
put('!:mod!:,'!:bf!:,'modcnv);
put('!:mod!:,'!:ft!:,'modcnv);
put('!:mod!:,'!:rn!:,'modcnv);
put('!:mod!:,'minusp,'modminusp!:);
put('!:mod!:,'plus,'modplus!:);
put('!:mod!:,'times,'modtimes!:);
put('!:mod!:,'difference,'moddifference!:);
put('!:mod!:,'quotient,'modquotient!:);
put('!:mod!:,'divide,'moddivide!:);
put('!:mod!:,'gcd,'modgcd!:);
put('!:mod!:,'zerop,'modzerop!:);
put('!:mod!:,'onep,'modonep!:);
put('!:mod!:,'factorfn,'factormod!:);
put('!:mod!:,'prepfn,'modprep!:);
put('!:mod!:,'prifn,'prin2);

symbolic procedure !*i2mod u;
   %converts integer U to modular form;
%  if (u := general!-modular!-number u)=0 then nil else '!:mod!: . u;
   '!:mod!: . general!-modular!-number u;

symbolic procedure modcnv u;
   rederr list("Conversion between modular integers and",
                get(car u,'dname),"not defined");

symbolic procedure modminusp!: u; nil;   %what else can one do?;

symbolic procedure !*modular2f u;
%  if u=0 then nil else if u=1 then 1 else '!:mod!: . u;
   '!:mod!: . u;

symbolic procedure modplus!:(u,v);
   !*modular2f general!-modular!-plus(cdr u,cdr v);

symbolic procedure modtimes!:(u,v);
   !*modular2f general!-modular!-times(cdr u,cdr v);

symbolic procedure moddifference!:(u,v);
   !*modular2f general!-modular!-difference(cdr u,cdr v);

symbolic procedure moddivide!:(u,v); !*i2mod 0 . u;

symbolic procedure modgcd!:(u,v); !*i2mod 1;

symbolic procedure modquotient!:(u,v);
   !*modular2f general!-modular!-times(cdr u,
                                   general!-modular!-reciprocal cdr v);

symbolic procedure modzerop!: u; cdr u=0;

symbolic procedure modonep!: u; cdr u=1;

symbolic procedure factormod!: u;
   begin scalar alglist!*,dmode!*;
      % 1 is needed since factorize expects first factor to be a number.
      return pfactor(!*q2f resimp(u ./ 1),current!-modulus)
   end;

symbolic procedure modprep!: u; cdr u;

initdmode 'modular;


% Modular routines are defined in the GENMOD module with the exception
% of the following:

symbolic procedure setmod u;
   % Returns value of CURRENT!-MODULUS on entry unless an error
   % occurs.  It crudely distinguishes between prime moduli, for which
   % division is possible, and others, for which it possibly is not.
   % The code should really distinguish prime powers and composites as
   % well.
   begin scalar dmode!*;
      u := reval u;  % dmode* is NIL, so this won't be reduced wrt
                     % current modulus.
      if fixp u and u>0
        then <<if primep u then flag('(!:mod!:),'field)
                else remflag('(!:mod!:),'field);
               return set!-general!-modulus u>>
      else if u=0 or null u then return current!-modulus
       else typerr(u,"modulus")
   end;

flag('(setmod),'opfn);   %to make it a symbolic operator;

flag('(setmod),'noval);

%A more general definition of general-modular-number.

%symbolic procedure general!-modular!-number m;
   %returns normalized M;
%   (lambda n; %if n<0 then n+current!-modulus else n)
%   if atom m then remainder(m,current!-modulus)
%    else begin scalar x;
%       x := dcombine(m,current!-modulus,'divide);
%        return cdr x
%     end;

endmodule;


module facform;  % Factored form representation for standard form polys.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*gcd dmode!*);

global '(!*factor);

comment In this module, we consider the manipulation of factored forms.
        These have the structure
        
           <monomial> . <form-power-list>

        where the monomial is itself a standard form (satisfying the
        KERNLP test) and a form-power is a dotted pair whose car is a 
        standard form and cdr an integer>0. We have thus represented the
        form as a product of a monomial and powers of non-monomial
        factors;

symbolic smacro procedure facmerge(u,v);
   %Returns the merge of the form_power_lists U and V;
   append(u,v);

symbolic procedure fctrf u;
   %U is a standard form. Value is a standard factored form;
   %The function FACTORF is an assumed entry point to a more complete
   %factorization module which itself returns a form power list;
   begin scalar mv,x,y,!*gcd;
      !*gcd := t;
      if domainp u then return list u
       else if !*factor
        then return if dmode!* and (x := get(dmode!*,'factorfn))
                      then apply1(x,u)
                     else factorf u;
      mv := mvar u;
      x := comfac u;
      u := quotf(u,comfac!-to!-poly x);
      y := fctrf cdr x;   % factor the content.
      if car x then y := multpf(car x,car y) . cdr y; % merge monomials
      if domainp u then return multf(u,car y) . cdr y
       else if not(mvar u eq mv)
        then return car y . facmerge(fctrf1 u,cdr y)
       else if minusf u
        then <<u := negf u; y := negf car y . cdr y>>;
      return car y . facmerge(factor!-prim!-f u,cdr y);
   end;

symbolic procedure fctrf1 u; 1 . factor!-prim!-f u;

symbolic procedure factor!-prim!-f u;
   %U is a non-trivial form which is primitive in all its variables
   %and has a positive leading numerical coefficient. Result is a
   %form power list.
   (for each x in v conc factor!-prim!-sqfree!-f(car x,cdr x))
      where v = sqfrf u;

symbolic procedure factor!-prim!-sqfree!-f(u,n);
   for each x in prsqfrfacf u collect (x . n);

symbolic procedure sqfrf u;
   %U is a non-trivial form which is primitive in all its variables
   %and has a positive leading numerical coefficient.
   %SQFRF performs square free factorization on U and returns a 
   %form power list;
   begin integer k,n; scalar !*gcd,v,w,x,y,z;
      n := 1;
      x := mvar u;
      !*gcd := t;
   a: v := gcdf(u,diff(u,x));
      k := degr(v,x);
      if k>0 then <<u := quotf(u,v);
                    if flagp(dmode!*,'field) and ((y := lnc u) neq 1)
                     then <<u := multd(!:recip y,u);
                            v := multd(y,v)>>>>;
      if w
        then <<if u neq w
                 then z := facmerge(list(quotf(w,u) . n),z);
               n := n+1>>;
      if k=0 then return facmerge(list(u . n),z);
      w := u;
      u := v;
      go to a
   end;

symbolic procedure diff(u,v);
   %a polynomial differentation routine which does not check
   %indeterminate dependences;
   if domainp u then nil
    else addf(addf(multpf(lpow u,diff(lc u,v)),
                multf(lc u,diffp1(lpow u,v))),
              diff(red u,v));

symbolic procedure diffp1(u,v);
   if not car u eq v then nil
    else if cdr u=1 then 1
    else multd(cdr u,!*p2f(car u .** (cdr u-1)));

endmodule;


module primfac;   % Primitive square free polynomial factorization.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(dmode!* kernlist!*);

symbolic procedure prsqfrfacf u;
   %U is a non-trivial form which is primitive in all its variables,
   %is square free, and has a positive leading numerical coefficient. 
   % Result is a list of factors of u.
   % We order kernels in increasing powers unless kernlist!* has a
   % non-NIL value in which case we use that order (needed by SOLVE).
   % NOTE: For the time being, we bypass this code if the coefficient
   % domain is other than integer.
   begin scalar b,bool,v,w;
      if dmode!* then return list u;
      v := if kernlist!* then kernlist!* 
            else reverse kernord!-sort powers u;
      % order highest power first.
      if cdr v
       then <<w := setkorder v;
              b := t;
              u := reorder u;
              if minusf u then <<bool := t; u := negf u>>>>;
      u := factor!-ordered!-sqfree!-prim!-f u; 
      if b then <<setkorder w;
                  u := for each x in u collect
                          begin
                             v := reorder x;
                             if bool and minusf v
                               then <<v := negf v; bool := nil>>;
                             return v
                          end>>;
      if bool then errach list("factor confusion",u);
      return u
   end;

symbolic procedure factor!-ordered!-sqfree!-prim!-f pol;
   % U is a non-trivial form which is primitive in all its variables,
   % is square free, has a positive leading numerical coefficient,
   % and has a main variable of lowest degree in the form.
   % Result is a form power list.
   begin integer n; scalar q,res,w;
      if ldeg pol = 1 then return list factor!-coeffs pol
       else if univariatep pol
        then <<while car(q := linfacf pol) do 
                <<res := car q . res; pol := cdr q>>;
               while car(q := quadfacf pol) do 
                <<res := car q . res; pol := cdr q>>>>;
      if null pol then return res
       else if length(w := special!-case!-factor pol)>1
        then return nconc!*(res,
                            for each x in w conc 
                               factor!-ordered!-sqfree!-prim!-f x)
       else if ldeg pol < 4 or (n := degreegcd pol) = 1 
          then return pol . res;
      w := cdr sort(dfactors n,function lessp);
      % 1 is always first factor.
   a: if null w then return pol . res
       else if length (q := factor!-ordered!-sqfree!-prim!-f 
                               downpower(pol,car w))>1
        then return nconc!*(res,for each x in q 
                                  conc factor!-ordered!-sqfree!-prim!-f
                                           uppower(x,car w));
      w := cdr w;
      go to a
   end;

symbolic procedure downpower(pol,n);
    % Reduce the power of each term in pol wrt main variable by factor
    %n.
   downpower1(pol,mvar pol,n);

symbolic procedure downpower1(pol,mv,n);
   if domainp pol or not(mvar pol eq mv) then pol
    else (mv .** (ldeg pol/n)) .* lc pol .+ downpower1(red pol,mv,n);

symbolic procedure uppower(pol,n);
    % Raise the power of each term in pol wrt main variable by factor
    %n.
   uppower1(pol,mvar pol,n);

symbolic procedure uppower1(pol,mv,n);
   if domainp pol or not(mvar pol eq mv) then pol
    else (mv .** (ldeg pol*n)) .* lc pol .+ downpower1(red pol,mv,n);

symbolic procedure univariatep pol;
   % True if pol is not a domain element and is univariate with respect 
   % to its main variable.
   not domainp pol and univariatep1(pol,mvar pol);

symbolic procedure univariatep1(pol,mv);
   domainp pol 
      or mvar pol eq mv and domainp lc pol and univariatep1(red pol,mv);

symbolic procedure special!-case!-factor pol;
   (if degree = 2 then quadraticf pol
     else if degree= 3 then cubicf pol
       else if degree = 4 then quarticf pol
       else list pol) 
    where degree = ldeg pol;

symbolic procedure degreegcd pol;
   % Returns gcd of degrees of pol with respect to main variable.
   begin integer n; scalar mv;
      mv := mvar pol;
      n := ldeg pol;
      while n>1 and not domainp(pol := red pol) and mvar pol eq mv
         do n := gcdn(n,ldeg pol);
      return n
   end;
        
symbolic procedure factor!-coeffs u;
   % factor the primitive, square free polynomial U wrt main variable.
   % dummy for now.
   u;

endmodule;


module specfac;   % splitting of low degree polynomials.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

exports cubicf,quadraticf,quarticf;

symbolic procedure coeffs pol;
% extract coefficients of polynomial wrt its main variable and leading 
% degree. Result is a list of coefficients.
    begin integer degree,deg1; scalar cofs,mv;
      mv := mvar pol;
      degree := ldeg pol;
      while not domainp pol and mvar pol eq mv do
       <<deg1 := ldeg pol;
         for i:= 1:(degree-deg1-1) do cofs := 0 . cofs;
         cofs := lc pol . cofs;
         pol := red pol;
         degree := deg1>>;
      for i:=1:degree-1 do cofs := 0 . cofs;
      if null pol then pol := 0;
      return reversip(pol . cofs)
   end;

symbolic procedure shift!-pol pol;
% Shifts main variable, mv, of square free nth degree polynomial pol so 
% that coefficient of mv**(n-1) is zero.
% Does not assume pol is univariate.
   begin scalar lc1,ld,mv,pol1,redp,shift,x;
      mv := mvar pol;
      ld := ldeg pol;
      redp := red pol;
      if domainp redp or not(mvar redp eq mv) or ldeg redp<(ld-1)
        then return list(pol,1,nil ./ 1);
      lc1 := lc pol;
      x := lc redp;
      shift := quotsq(!*f2q x,!*f2q multd(ld,lc1));
      pol1 := subf1(pol,list(mv . mk!*sq addsq(!*k2q mv,negsq shift)));
      return list(numr pol1,denr pol1,shift)
   end;

symbolic procedure quadraticf pol;
% Finds factors of square free quadratic polynomial pol (if they exist).
% Does not assume pol is univariate.
%   quadraticf2(car w,cadr w,caddr w,mvar pol) where w = coeffs pol;
   (if x eq 'failed then list pol
    else list(y .* car x .+ cadr x,y .* caddr x .+ cadddr x)
       where y = (mvar pol .** 1))
    where x = quadraticf1(car w,cadr w,caddr w) where w = coeffs pol;

symbolic procedure quadraticf1(a,b,c);
   begin scalar a1,denom,discrim,w;
      if b=0 then b := nil;
      discrim := addf(exptf(b,2),multd(-4,multf(a,c)));
      if null discrim then errach "discrim=0 in quadratic"
       else if minusf discrim then return 'failed;
      discrim:=rootxf(discrim,2);
      if discrim='failed then return discrim;
      denom := multd(4,a);
      a := multd(2,a);
      w := addf(b,discrim);
      c := addf(b,negf discrim);
      b := w;
      if (w := gcdf(a,b)) neq 1 
        then <<a1 := quotf(a,w); b := quotf(b,w); 
               denom := quotf(denom,w)>>;
      if (w := gcdf(a,denom)) neq 1 and (w := gcdf(c,denom))
        then <<a := quotf(a,w);
               c := quotf(c,w);
               denom := quotf(denom,w)>>;
      if denom neq 1 then errach "denominator not 1 in quadratic";
      return list(a1,b,a,c)
    end;

symbolic procedure rootxf(u,n);
   % find polynomial nth root of u or return "failed".
   begin scalar x,y,z;
      if domainp u 
        then return if fixp u and (y := irootn(u,n))**n=u then y
                     else 'failed;
      x := comfac u;
      u := quotf(u,comfac!-to!-poly x);
      z := 1;
      if car x then if cdr(y := divide(cdar x,n)) = 0 
        then z := multpf(caar x .** car y,z)
       else return 'failed;
      x := cdr x;
      if domainp x then if fixp x and (y := irootn(x,n))**n=x
        then z := multd(y,z)
            else return 'failed
       else if (y := rootxf(x,n)) eq 'failed then return y
       else z := multf(y,z);
      if u=1 then return z;
      x := sqfrf u;
   c: if null x then return z
       else if cdr(y := divide(cdar x,n)) = 0 
        then <<z := multf(exptf(caar x,car y),z); x := cdr x>>
       else return 'failed;
      go to c
   end;

symbolic procedure cubicf pol;
% split the cubic pol if a change of origin puts it in the form 
% (x-a)**3-b=0.
    begin scalar a,a0,b,neg,pol1;
       pol1 := shift!-pol pol;
       a := coeffs car pol1;
%      if cadr a neq 0 then rederr list(pol,"not correctly shifted")
       % cadr a neq 0 probably means there are some surds in the
       % coefficients that don't reduce to 0.
       if cadr a neq 0 then return list pol
        else if caddr a neq 0 then return list pol;  
       % factorization not possible by this method
       a0 := cadddr a;     
       a := car a;
       if minusf a0 
         then <<neg := t; a0 := negf a0>>;
       if (a := rootxf(a,3)) eq 'failed
          or (a0 := rootxf(a0,3)) eq 'failed
         then return list pol;
       if neg then a0 := negf a0;
       %now numr (a*(mv+shift)+a0) is a factor of pol;
       a := numr addsq(multsq(!*f2q a,addsq(!*k2q mvar pol,caddr pol1)),
                       !*f2q a0);
       if null(b := quotf(pol,a)) 
         then errach list(pol,"doesn't factor properly"); 
       return a . quadraticf b
    end;

symbolic procedure quarticf pol;
%splits quartics that can be written in the form (x-a)**4+b*(x-a)**2+c.
   begin scalar a,a2,a0,b,pol1,x;
      pol1 := shift!-pol pol;     
      a := coeffs car pol1;
      if cadr a neq 0 then rederr list(pol,"not correctly shifted")
        else if cadddr a neq 0 then return list pol;  
       % factorization not possible by this method
      a2 := cddr a;
      a0 := caddr a2;
      a2 := car a2;
      a := car a; 
      x := quadraticf1(a,a2,a0);
      if x eq 'failed then return list pol;
      a := exptsq(addsq(!*k2q mvar pol,caddr pol1),2);  % (x+shift)**2
      b := numr quotsq(addsq(multsq(!*f2q car x,a),!*f2q cadr x),
                       !*f2q cadr pol1);
           % should be one factor;
      a := quotf(pol,b);
      if null a then errach list(pol,"doesn't factor properly"); 
      return append(quadraticf a,quadraticf b)
   end;

endmodule;


module kronf;   % Kronecker factorization of univariate forms.

% Author: Anthony C. Hearn.

% Based on code first written by Mary Ann Moore and Arthur C. Norman.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

exports linfacf,quadfacf;

imports zfactor;

% Note that only linear and quadratic factors are found here.

symbolic procedure linfacf u; trykrf(u,'(0 1));

symbolic procedure quadfacf u; trykrf(u,'(-1 0 1));

symbolic procedure trykrf(u,points);
   % Look for factor of u by evaluation at points and interpolation.
   % Return (fac . cofac), with fac = nil if none found,
   % and cofac = nil if nothing worthwhile is left.
   begin scalar attempt,mv,values;
      if null u then return nil . nil
       else if length points > ldeg u then return u . nil;
      mv := mvar u;
      values := for each j in points collect subuf(j,u);
      if 0 member values
        then <<attempt := ((mv .** 1) .* 1) . -1;   % mv - 1
               return attempt . quotf(u,attempt)>>;
      values := for each j in values collect dfactors j;
      values := for each j in values
                   collect append(j,for each k in j collect !:minus k);
      attempt := search4facf(u,values,nil);
      if null attempt then attempt := nil . u;
      return attempt
   end;

symbolic procedure subuf(u,v);
   % Substitute integer u for main variable in univariate polynomial v.
   % Return an integer or a structured domain element.
   begin scalar z;
      if u=0 then u := nil;
      z := nil;
      while v do
         if domainp v then <<z := adddm!*(v,z); v := nil>>
          else <<if u then z := adddm!*(multdm!*(u**ldeg v,lc v),z);
                 % we should do better here.
                 v := red v>>;
      return if null z then 0 else z
   end;

symbolic procedure adddm!*(u,v);
   % Adds two domain elements u and v, returning a standard form.
   if null u then v else if null v then u else adddm(u,v);

symbolic procedure multdm!*(u,v);
   % Multiplies two domain elements u and v, returning a standard form.
   if null u or null v then nil else multdm(u,v);

symbolic procedure dfactors n;
   % produces a list of all (positive) factors of the domain element n.
   begin scalar x;
      if n=0 then return list 0
       else if !:minusp n then n := !:minus n;
      return if not atom n 
        then if (x := get(car n,'factorfn))
               then combinationtimes apply1(x,n)
              else list n
       else combinationtimes zfactor n
   end;

symbolic procedure combinationtimes fl;
   if null fl then list 1
    else begin scalar n,c,res,pr;
        n := caar fl; 
        c := cdar fl;
        pr := combinationtimes cdr fl;
        while c>=0 do <<res := putin(expt(n,c),pr,res); c := c-1>>;
        return res
    end;

symbolic procedure putin(n,l,w);
   if null l then w else putin(n,cdr l,(n*car l) . w);

symbolic procedure search4facf(u,values,cv);
   % combinatorial search for factors. cv gets current value set.
   if null values then tryfactorf(u,cv)
    else begin scalar q,w;
      w := car values;
 loop: if null w then return nil;   % no factor found
      q := search4facf(u,cdr values,car w . cv);
      if null q then <<w := cdr w; go to loop>>;
      return q
    end;

symbolic procedure tryfactorf(u,cv);
   % Tests if cv represents a factor of u.
   % For the time being, does not work on structured domain elements.
   begin scalar w;
      if null atomlis cv then return nil;
      if null cddr cv then w := linethroughf(cadr cv,car cv,mvar u)
       else w := quadthroughf(caddr cv,cadr cv,car cv,mvar u);
      if w eq 'failed or null (u := quotf(u,w)) then return nil
       else return w . u
   end;

symbolic procedure linethroughf(y0,y1,mv);
   begin scalar x;
      x := y1-y0;
      if x=0 then return 'failed
       else if x<0 then <<x:= -x; y0 := -y0>>;
       return if y0 = 0 or gcdn(x,y0) neq 1 then 'failed
               else (mv .** 1) .* x .+ y0
   end;

symbolic procedure quadthroughf(ym1,y0,y1,mv);
   begin scalar x,y,z;
      x := divide(ym1+y1,2);
      if cdr x=0 then x := car x-y0 else return 'failed;
      if x=0 then return 'failed;
      z := y0;
      y := divide(y1-ym1,2);
      if cdr y=0 then y := car y else return 'failed;
      if gcdn(x,gcdn(y,z)) neq 1 then return 'failed;
      if x<0 then <<x := -x; y := -y; z := -z>>;
      if z=0 then return 'failed
       else if y=0 then return ((mv .** 2) .* x) .+ z
       else return ((mv .** 2) .* x) .+ (((mv .** 1) .* y) .+ z)
   end;

endmodule;


module conj;  % Rationalize denoms of standard quotients by conjugate
              % computation.

% Author: Anthony C. Hearn.

% Modifications by: Eberhard Schruefer.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*rationalize dmode!* kord!*);

put('rationalize,'simpfg,'((t (rmsubs)) (nil (rmsubs))));

symbolic smacro procedure subtrf(u,v);
   % Returns u - v for standard forms u and v.
   addf(u,negf v);

symbolic procedure rationalizesq u;
   % Rationalize the standard quotient u.
   begin scalar x;
      if x := get(dmode!*,'rationalizefn) then u := subs2 apply1(x,u);
      % We need the subs2 to get rid of surd powers.
      return if domainp denr u then u
             else if (x := rationalizef denr u) neq 1
              then rationalizesq subs2q(multf(numr u,x)
                                          ./ multf(denr u,x))
             else u
   end;

symbolic procedure rationalizef u;
   % Look for I and sqrts, cbrts, quartics at present.
   begin scalar x,y;
      x := kernels u;
   a: if null x then return 1;
      y := car x;
      if y eq 'i or eqcar(y,'expt) and caddr y = '(quotient 1 2)
        then return conjquadratic(mkmain(u,y),y)
       else if eqcar(y,'expt) and caddr y = '(quotient 1 3)
        then return conjcubic(mkmain(u,y),y)
       else if eqcar(y,'expt) and caddr y = '(quotient 1 4)
        then return conjquartic(mkmain(u,y),y);
      x := cdr x;
      go to a
   end;

symbolic procedure conjquadratic(u,v);
   if ldeg u = 1
      then subtrf(multf(!*k2f v,reorder lc u),reorder red u)
    else errach list(ldeg u,"invalid power in rationalizef");

symbolic procedure conjcubic(u,v);
   begin scalar c1,c2,c3;
     if ldeg u = 2 then <<c1 := reorder lc u;
                           if degr(red u,v) = 1
                              then <<c2 := reorder lc red u;
                                     c3 := reorder red red u>>
                            else c3 := reorder red u>>
      else <<c2 := reorder lc u;
             c3 := reorder red u>>;
     return addf(multf(exptf(!*k2f v,2),
                       subtrf(exptf(c2,2),multf(c1,c3))),
                 addf(multf(!*k2f v,subtrf(multf(!*q2f simp cadr v,
                                                 exptf(c1,2)),
                                           multf(c2,c3))),
                      subtrf(exptf(c3,2),multf(!*q2f simp cadr v,
                                               multf(c1,c2)))))
  end;

symbolic procedure conjquartic(u,v);
   begin scalar c1,c3,c4,q1,q2,q3,q4;
     if ldeg u = 3
        then <<c1 := reorder lc u;
               if degr(red u,v) = 1
                  then <<c3 := reorder lc red u;
                         c4 := reorder red red u>>
                else c4 := reorder red u>>
      else if ldeg u = 1
              then <<c3 := reorder lc u;
                     c4 := reorder red u>>;
     q1 := subtrf(addf(exptf(c3,3),multf(c1,exptf(c4,2))),
                  multf(!*q2f simp cadr v,multf(c3,exptf(c1,2))));
     q2 := negf addf(multf(!*q2f simp cadr v,multf(c4,exptf(c1,2))),
                     multf(exptf(c3,2),c4));
     q3 := addf(multf(c3,exptf(c4,2)),
                subtrf(multf(exptf(!*q2f simp cadr v,2),exptf(c1,3)),
                       multf(!*q2f simp cadr v,multf(c1,exptf(c3,2)))));
     q4 := subtrf(multf(!*q2f simp cadr v,
                        multf(multd(2,c1),multf(c3,c4))),
                  exptf(c4,3));
     return addf(multf(exptf(!*k2f v,3),q1),
                 addf(multf(exptf(!*k2f v,2),q2),
                      addf(multf(!*k2f v,q3),q4)))
    end;

symbolic procedure mkmain(u,var);
   % Make kernel var the main variable of u.
   begin scalar kord!*; kord!* := list var; return reorder u end;

endmodule;


module diff; % Differentiation package.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

global '(frlis!* mcond!* powlis!* subfg!* wtl!*);

% Contains a reference to RPLACD (a table update), commented out.

symbolic procedure simpdf u;
   %U is a list of forms, the first an expression and the remainder
   %kernels and numbers.
   %Value is derivative of first form wrt rest of list;
   begin scalar v,x,y;
        if null subfg!* then return mksq('df . u,1);
        v := cdr u;
        u := simp!* car u;
    a:  if null v or null numr u then return u;
        x := if null y or y=0 then simp!* car v else y;
        if null kernp x then typerr(prepsq x,"kernel");
        x := caaaar x;
        v := cdr v;
        if null v then go to c;
        y := simp!* car v;
        if null numr y then <<v := cdr v; y := nil; go to a>>
         else if not denr y=1 or not numberp numr y then go to c;
        v := cdr v;
    b:  for i:=1:car y do u := diffsq(u,x);
        y := nil;
        go to a;
    c:  u := diffsq(u,x);
        go to a
   end;

put('df,'simpfn,'simpdf);

symbolic procedure diffsq(u,v);
   %U is a standard quotient, V a kernel.
   %Value is the standard quotient derivative of U wrt V.
   %Algorithm: df(x/y,z)= (x'-(x/y)*y')/y;
   multsq(addsq(difff(numr u,v),negsq multsq(u,difff(denr u,v))),
          1 ./ denr u);

symbolic procedure difff(u,v);
   %U is a standard form, V a kernel.
   %Value is the standard quotient derivative of U wrt V;
   if domainp u then nil ./ 1
    else addsq(addsq(multpq(lpow u,difff(lc u,v)),
                        multsq(diffp(lpow u,v),lc u ./ 1)),
               difff(red u,v));

symbolic procedure diffp(u,v);
   %U is a standard power, V a kernel.
   %Value is the standard quotient derivative of U wrt V;
   begin scalar n,w,x,y,z; integer m;
        n := cdr u;     %integer power;
        u := car u;     %main variable;
        if u eq v and (w := 1 ./ 1) then go to e
         else if atom u then go to f
         %else if (x := assoc(u,dsubl!*)) and (x := atsoc(v,cdr x))
%               and (w := cdr x) then go to e   %deriv known;
             %DSUBL!* not used for now;
         else if (not atom car u and (w:= difff(u,v)))
                  or (car u eq '!*sq and (w:= diffsq(cadr u,v)))
          then go to c  %extended kernel found;
         else if (x:= get!*(car u,'dfn)) then nil
         else if car u eq 'plus and (w:=diffsq(simp u,v))
          then go to c
         else go to h;  %unknown derivative;
        y := x;
        z := cdr u;
    a:  w := diffsq(simp car z,v) . w;
        if caar w and null car y then go to h;  %unknown deriv;
        y := cdr y;
        z := cdr z;
        if z and y then go to a
         else if z or y then go to h;  %arguments do not match;
        y := reverse w;
        z := cdr u;
        w := nil ./ 1;
    b:  %computation of kernel derivative;
        if caar y
          then w := addsq(multsq(car y,simp subla(pair(caar x,z),
                                                   cdar x)),
                          w);
        x := cdr x;
        y := cdr y;
        if y then go to b;
    c:  %save calculated deriv in case it is used again;
        %if x := atsoc(u,dsubl!*) then go to d
        %else x := u . nil;
        %dsubl!* := x . dsubl!*;
    d:  %rplacd(x,xadd(v . w,cdr x,t));
    e:  %allowance for power;
        %first check to see if kernel has weight;
        if (x := atsoc(u,wtl!*))
          then w := multpq('k!* .** (-cdr x),w);
        m := n-1;
        return if n=1 then w
                else if flagp(dmode!*,'convert)
                     and null(n := int!-equiv!-chk
                                           apply1(get(dmode!*,'i2d),n))
                 then nil ./ 1
                else multsq(!*t2q((u .** m) .* n),w);
    f:  %check for possible unused substitution rule;
        if not depends(u,v)
           and (not (x:= atsoc(u,powlis!*))
                 or not car diffsq(simp cadddr x,v))
          then return nil ./ 1;
        w := list('df,u,v);
        go to j;
    h:  %final check for possible kernel deriv;
        if car u eq 'df
          then if depends(cadr u,v)
                 then if assoc(w := list('df,cadr u,v),
                               get('df,'kvalue))
                          then <<w := mksq(w,1);
                                 x := cddr u;
                                 while x do
                                   <<if cdr x and numberp cadr x
                                         then <<for i := 1:cadr x do
                                                   w := diffsq(w,car x);
                                                x := cdr x>>
                                       else w := diffsq(w,car x);
                                      x := cdr x>>;
                                 go to e>>
                       else w := 'df . cadr u . derad(v,cddr u)
                else return nil ./ 1
         else if depends(u,v) then w := list('df,u,v)
         else return nil ./ 1;
    j:  w := if x := opmtch w then simp x else mksq(w,1);
        go to e
   end;

symbolic procedure derad(u,v);
   if null v then list u
    else if numberp car v then car v . derad(u,cdr v)
    else if u=car v then if cdr v and numberp cadr v
                           then u . (cadr v + 1) . cddr v
                          else u . 2 . cdr v
    else if ordp(u,car v) then u . v
    else car v . derad(u,cdr v);

symbolic procedure letdf(u,v,w,x,b);
   begin scalar y,z;
        if atom cadr x then go to b
         else if not idp caadr x then typerr(caadr x,"operator")
         else if not get(caadr x,'simpfn)
          then <<redmsg(caadr x,"operator"); mkop caadr x>>;
        rmsubs();
        if not mcond!* eq 't
                or not frlp cdadr x
                or null cddr x
                or cdddr x
                or not frlp cddr x
                or not idlistp cdadr x
                or repeats cdadr x
                or not caddr x member cdadr x
         then go to b;
        z := lpos(caddr x,cdadr x);
        if not get(caadr x,'dfn)
            then put(caadr x,
                     'dfn,
                     nlist(nil,length cdadr x));
        w := get(caadr x,'dfn);
        if length w neq length cdadr x
          then rederr list("Incompatible DF rule argument length for",
                           caadr x);
   a:   if null w or z=0 then return errpri1 u
         else if z neq 1
          then <<y := car w . y; w := cdr w; z := z-1; go to a>>
         else if null b then y := append(reverse y,nil . cdr w)
         else y := append(reverse y,(cdadr x . v) . cdr w);
        return put(caadr x,'dfn,y);
   b:   %check for dependency;
        if caddr x memq frlis!* then return nil
         else if idp cadr x and not(cadr x memq frlis!*) 
           then depend1(cadr x,caddr x,t)
         else if not atom cadr x and idp caadr x and frlp cdadr x
          then depend1(caadr x,caddr x,t);
        return nil
   end;

symbolic procedure frlp u;
   null u or (car u memq frlis!* and frlp cdr u);

symbolic procedure lpos(u,v);
   if u eq car v then 1 else lpos(u,cdr v)+1;


endmodule;


module subs2q;  % Routines for substituting for powers.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*mcd !*structure !*sub2 alglist!* dmode!*);

global '(!*resubs frlis!* powlis!* powlis1!* simpcount!*
         simplimit!*);

comment If STRUCTURE is ON, then expressions like (a**(b/2))**2 are not
simplified, to allow some attempt at a structure theorem use, especially
in the integrator;

symbolic procedure subs2q u;
   % Perform power substitutions on u. Check whether substitions
   % on numerator and denominator change these before doing   
   % quotient (to avoid undoing rationalization of denominator).
   ((if denr x=1 and denr y=1 and numr x=v and numr y=w then u
      else quotsq(x,y))
     where x=subs2f v, y=subs2f w)
    where v=numr u, w=denr u;

symbolic procedure subs2f u;
   begin scalar x;
        if simpcount!*>simplimit!*
         then <<simpcount!* := 0;
                rederr "Simplification recursion too deep">>;
        simpcount!* := simpcount!*+1;
        !*sub2 := nil;
        x := subs2f1 u;
        if (!*sub2 or powlis1!*) and !*resubs
           then if numr x=u and denr x=1 then !*sub2 := nil
                else x := subs2q x;
        simpcount!* := simpcount!*-1;
        return x
   end;

symbolic procedure subs2f1 u;
   if domainp u then !*d2q u
    else begin scalar kern,v,w,x,y,z;
        kern := mvar u;
        z := nil ./ 1;
    a:  if null u or degr(u,kern)=0 then go to a1;
        y := lt u .+ y;
        u := red u;
        go to a;
    a1: x := powlis!*;
    a2: if null x then go to b
         else if caaar y = caar x
          then <<w := subs2p(caar y,cadar x,cadddr car x); go to e1>>
%        else if eqcar(kern,'sqrt) and cadr kern = caar x
%         then <<w := raddsq(subs2p(cadr kern . cdaar y,
%                            cadar x,cadddr car x),2);% go to e1>>;
         else if eqcar(kern,'expt)
                and cadr kern = caar x
                and eqcar(caddr kern,'quotient)
                and cadr caddr kern = 1
                and numberp caddr caddr kern
          then <<v := divide(cdaar y,caddr caddr kern);
%       if car v neq 0 then w := mksq(cadr kern,car v)
        % Use simp/exptsq to make sure I converted in complex mode.
        if car v neq 0 then w := exptsq(simp cadr kern,car v)
                  else w := 1 ./ 1;
                 if cdr v neq 0
                   then <<begin scalar alglist!*,dmode!*;
                          % We must do exponent arithmetic in integer
                          % mode.
                             v := cancel(cdr v.caddr caddr kern)
                          end;
                         w := multsq(raddsq(subs2p(cadr kern . car v,
                                        cadar x,cadddr car x),
                                cdr v),w)>>;
                 go to e1>>;
        x := cdr x;
        go to a2;
    b:  x := powlis1!*;
    l2: if null x then go to l3
         else if w:= mtchp(caar y,caar x,caddar x,caadar x,cdadar x)
          then go to e1;
        x := cdr x;
        go to l2;
    l3: if eqcar(kern,'expt) and not !*structure then go to l1;
        z := addsq(multpq(caar y,subs2f1 cdar y),z);
    c:  y := cdr y;
        if y then go to a1;
    d:  return addsq(z,subs2f1 u);
    e1: z := addsq(multsq(w,subs2f1 cdar y),z);
        go to c;
    l1: if cdaar y=1 and not eqcar(cadr kern,'expt)     % ONEP
          then w := mksq(kern,1)
         else w := simpexpt list(cadr kern,
                                 list('times,caddr kern,cdaar y));
        z := addsq(multsq(w,subs2f1 cdar y),z);
        y := cdr y;
        if y then go to l1 else go to d;
    end;

symbolic procedure subs2p(u,v,w);
   %U is a power, V an integer, and W an algebraic expression, such
   %that CAR U**V=W. Value is standard quotient for U with this
   %substitution;
   begin 
      v := divide(cdr u,v);
      if car v=0 then return !*p2q u;
      w := exptsq(simp w,car v);
      return if cdr v=0 then w else multpq(car u .** cdr v,w)
   end;

symbolic procedure raddsq(u,n);
   %U is a standard quotient, N and integer. Value is sq for U**(1/N);
   simpexpt list(mk!*sq u,list('quotient,1,n));

symbolic procedure mtchp(u,v,w,flg,bool);
   %U is a standard power, V a power to be matched against.
   %W is the replacement expression.
   %FLG is a flag which is T if an exact power match required.
   %BOOL is a boolean expression to be satisfied for substitution.
   %Value is the substitution standard quotient if a match found,
   %NIL otherwise;
   begin scalar x;
        x := mtchp1(u,v,flg,bool);
    a:  if null x then return nil
         else if eval subla(car x,bool) then go to b;
        x := cdr x;
        go to a;
    b:  v := divide(cdr u,subla(car x,cdr v));
        w := exptsq(simp subla(car x,w),car v);
        if cdr v neq 0 then w := multpq(car u .** cdr v,w);
        return w
   end;

symbolic procedure mtchp1(u,v,flg,bool);
   %U is a standard power, V a power to be matched against.
   %FLG is a flag which is T if an exact power match required.
   %BOOL is a boolean expression to be satisfied for substitution.
   %Value is a list of possible free variable pairings which
   %match conditions;
   begin scalar x;
        if u=v then return list nil
         else if not (x:= mchk!*(car u,car v)) then return nil
         else if cdr v memq frlis!*
          then if cdr u=1 then return nil
             % do not match a free power to 1
                else return mapcons(x,cdr v . cdr u)
         else if (flg and not cdr u=cdr v)
                or (if !*mcd then cdr u<cdr v
                     else (cdr u*cdr v)<0 or
                        %implements explicit sign matching;
                            abs cdr u<abs cdr v)
          then return nil
         else return x
   end;

symbolic procedure mchk!*(u,v);
   begin scalar x;
      if x := mchk(u,v) then return x
       else if !*mcd or not (sfp u and sfp v) then return nil
       else return mchk(prepf u,prepf v)
   end;

endmodule;


module subs3q; % Routines for matching products.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*mcd !*sub2);

global '(!*match !*resubs mchfg!* powlis1!*);

symbolic procedure subs3q u;
   %U is a standard quotient.
   %Value is a standard quotient with all product substitutions made;
   begin scalar x;
        x := mchfg!*;   %save value in case we are in inner loop;
        mchfg!* := nil;
        u := quotsq(subs3f numr u,subs3f denr u);
        mchfg!* := x;
        return u
   end;

symbolic procedure subs3f u;
   %U is a standard form.
   %Value is a standard quotient with all product substitutions made;
   subs3f1(u,!*match,t);

symbolic procedure subs3f1(u,l,bool);
   %U is a standard form.
   %L is a list of possible matches.
   %BOOL is a boolean variable which is true if we are at top level.
   %Value is a standard quotient with all product substitutions made;
   begin scalar x,z;
        z := nil ./ 1;
    a:  if null u then return z
         else if domainp u then return addsq(z,u ./ 1)
         else if bool and domainp lc u then go to c;
        x := subs3t(lt u,l);
        if not bool                             %not top level;
         or not mchfg!* then go to b;           %no replacement made;
        mchfg!* := nil;
        if numr x = u and denr x = 1 then <<x := u ./ 1; go to b>>
         % also shows no replacement made (sometimes true with non
         % commuting expressions)
         else if null !*resubs then go to b
         else if !*sub2 or powlis1!* then x := subs2q x;
           %make another pass;
        x := subs3q x;
    b:  z := addsq(z,x);
        u := cdr u;
        go to a;
    c:  x := list lt u ./ 1;
        go to b
   end;

symbolic procedure subs3t(u,v);
   % U is a standard term, V a list of matching templates.
   % Value is a standard quotient for the substituted term.
   begin scalar bool,w,x,y,z;
        x := mtchk(car u,if domainp cdr u then sizchk(v,1) else v);
        if null x then go to a                  %lpow doesn't match;
         else if null caar x then go to b;      %complete match found;
        y := subs3f1(cdr u,x,nil);              %check tc for match;
        if mchfg!* then return multpq(car u,y);
    a:  return list u . 1;                      %no match;
    b:  x := cddar x;           %list(<subst value>,<denoms>);
        z := caadr x;           %leading denom;
        mchfg!* := nil;         %initialize for tc check;
        y := subs3f1(cdr u,!*match,nil);
        mchfg!* := t;
        if car z neq caar u then go to e
         else if z neq car u    %powers don't match;
          then y := multpq(caar u .** (cdar u-cdr z),y);
    b1: y := multsq(simpcar x,y);
        x := cdadr x;
        if null x then return y;
        z := 1;                 %unwind remaining denoms;
    c:  if null x then go to d;
        w:= if atom caar x or sfp caar x then caar x else revop1 caar x;
        % In the non-commutative case we have to be very careful about
        % order of terms in a product. Introducing negative powers
        % solves this problem.
        if noncomp w or not !*mcd then bool := t;
        z := list(mksp(w,if null bool then cdar x else -cdar x) . z);
        % kernel CAAR X is not unique here. Earlier versions used just
        % CAAR X, but this leads to sums of terms in the wrong order.
        % The code here is probably still not correct in all cases, and
        % may lead to unbounded calculations. Maybe SIMP should be used
        % instead of REVOP1, with appropriate adjustments in the code
        % to construct Z.
        x := cdr x;
        go to c;
    d:  return if not bool then car y . multf(z,cdr y)
                else multf(z,car y) . cdr y;
    e:  if simp car z neq simp caar u then errach list('subs3t,u,x,z);
        %maybe arguments were in different order, otherwise it's fatal;
        if cdr z neq cdar u
          then y:= multpq(caar u .** (cdar u-cdr z),y);
        go to b1
   end;

symbolic procedure sizchk(u,n);
   if null u then nil
    else if length caar u>n then sizchk(cdr u,n)
    else car u . sizchk(cdr u,n);

symbolic procedure mtchk(u,v);
   %U is a standard power, V a list of matching templates.
   %If a match is made, value is of the form:
   %list list(NIL,<boolean form>,<subst value>,<denoms>),
   %otherwise value is an updated list of templates;
   begin scalar flg,v1,w,x,y,z;
        flg := noncomp car u;
    a0: if null v then return z;
        v1 := car v;
        w := car v1;
    a:  if null w then go to d;
        x := mtchp1(u,car w,caadr v1,cdadr v1);
    b:  if null x then go to c
         else if car (y := subla(car x,delete(car w,car v1))
                                . list(subla(car x,cadr v1),
                                      subla(car x,caddr v1),
                                      subla(car x,car w)
                                          . cadddr v1))
          then z := y . z
         else if eval subla(car x,cdadr v1) then return list y;
        x := cdr x;
        go to b;
    c:  if null flg then <<w := cdr w; go to a>>
         else if cadddr v1 and nocp w then go to e;
    d:  z := append(z,list v1);
    e:  v := cdr v;
        go to a0
   end;

symbolic procedure nocp u;
   null u or (noncomp caar u and nocp cdr u);

endmodule;


module extout; % Extended output package for expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*mcd kord!*);

global '(!*allfac
         !*div
         !*pri
         !*rat
         dnl!*
         factors!*
         ordl!*
         upl!*
         wtl!*);

switch allfac,div,pri,rat;

!*allfac := t;          %factoring option for this package;
!*pri := t;             %to activate this package;

% dnl!* := nil;         %output control flag: puts powers in denom;
% factors!* := nil;     %list of output factors;
% ordl!* := nil;        %list of kernels introduced by ORDER statement;
% upl!* := nil;         %output control flag: puts denom powers in
                        %numerator;
% !*div := nil;         %division option in this package;
% !*rat := nil;         %flag indicating rational mode for output;


symbolic procedure factor u;
   factor1(u,t,'factors!*);

symbolic procedure factor1(u,v,w);
   begin scalar x,y;
        y := eval w;
        for each j in u do
         <<x := !*a2k j;
           if v then y := aconc!*(delete(x,y),x)
            else if not x member y
             then msgpri(nil,j,"not found",nil,nil)
            else y := delete(x,y)>>;
        set(w,y)
   end;

symbolic procedure remfac u;
   factor1(u,nil,'factors!*);

rlistat '(factor remfac);

symbolic procedure order u;
   <<rmsubs();   % Since order of terms in an operator argument can
                 % affect simplification.
     if u and null car u and null cdr u then (ordl!* := nil)
      else for each x in u do
        <<if (x := !*a2k x) member ordl!*
            then ordl!* := delete(x,ordl!*);
          ordl!* := aconc!*(ordl!*,x)>>>>;

rlistat '(order);

symbolic procedure up u;
   factor1(u,t,'upl!*);

symbolic procedure down u;
   factor1(u,t,'dnl!*);

% RLISTAT '(UP DOWN);  % omitted since not documented;

symbolic procedure formop u;
   if domainp u then u
    else raddf(multop(lpow u,formop lc u),formop red u);

symbolic procedure multop(u,v);
   if null kord!* then multpf(u,v)
    else if car u eq 'k!* then v
    else rmultpf(u,v);

symbolic smacro procedure lcx u;
   %returns leading coefficient of a form with zero reductum, or an
   %error otherwise;
   cdr carx(u,'lcx);

symbolic procedure quotof(p,q);
   %P is a standard form, Q a standard form which is either a domain
   %element or has zero reductum.
   %returns the quotient of P and Q for output purposes;
   if null p then nil
    else if p=q then 1
    else if q=1 then p
    else if domainp q then quotofd(p,q)
    else if domainp p
     then mksp(mvar q,-ldeg q) .* quotof(p,lcx q) .+ nil
    else (lambda (x,y);
          if car x eq car y
              then (lambda (n,w,z);
                 if n=0 then raddf(w,z)
                  else ((car y .** n) .* w) .+ z)
              (cdr x-cdr y,quotof(lc p,lcx q),quotof(red p,q))
           else if ordop(car x,car y)
              then (x .* quotof(lc p,q)) .+ quotof(red p,q)
           else mksp(car y,- cdr y) .* quotof(p,lcx q) .+ nil)
       (lpow p,lpow q);

symbolic procedure quotofd(p,q);
   %P is a form, Q a domain element. Value is quotient of P and Q
   %for output purposes;
   if null p then nil
    else if domainp p then quotodd(p,q)
    else (lpow p .* quotofd(lc p,q)) .+ quotofd(red p,q);

symbolic procedure quotodd(p,q);
   %P and Q are domain elements. Value is domain element for P/Q;
   if atom p and atom q then mkrn(p,q) else lowest!-terms(p,q);

symbolic procedure lowest!-terms(u,v);
   %reduces compatible domain elements U and V to a ratio in lowest
   %terms.  Value as a rational may contain domain arguments rather than
   %just integers;
   if u=v then 1
    else if flagp(dmode!*,'field) or not atom u and flagp(car u,'field)
       or not atom v and flagp(car v,'field)
     then multdm(u,!:recip v)
     else begin scalar x;
      x := dcombine!*(u,v,'gcd);
      u := dcombine!*(u,x,'quotient);
      v := dcombine!*(v,x,'quotient);
      return if v=1 then u else '!:rn!: . (u . v)    % :ONEP
   end;

symbolic procedure dcombine!*(u,v,w);
   if atom u and atom v then apply2(w,u,v) else dcombine(u,v,w);

symbolic procedure ckrn u;
   if flagp(dmode!*,'field)
     then begin scalar x;
       x := lnc u;
       return multf(x,ckrn1 quotfd(u,x))
      end
    else ckrn1 u;

symbolic procedure ckrn1 u;
   begin scalar x;
        if domainp u then return u;
    a:  x := gck2(ckrn1 cdar u,x);
        if null cdr u
          then return if noncomp mvar u then x else list(caar u . x)
         else if domainp cdr u or not caaar u eq caaadr u
          then return gck2(ckrn1 cdr u,x);
        u := cdr u;
        go to a
   end;

symbolic procedure gck2(u,v);
   %U and V are domain elements or forms with a zero reductum.
   %Value is the gcd of U and V;
   if null v then u
    else if u=v then u
    else if domainp u
     then if domainp v then if flagp(dmode!*,'field) then 1
                             else gcddd(u,v)
        else gck2(u,cdarx v)
    else if domainp v then gck2(cdarx u,v)
    else (lambda (x,y);
        if car x eq car y
          then list((if cdr x>cdr y then y else x) .
                    gck2(cdarx u,cdarx v))
         else if ordop(car x,car y) then gck2(cdarx u,v)
         else gck2(u,cdarx v))
    (caar u,caar v);

symbolic procedure cdarx u;
   cdr carx(u,'cdar);

symbolic procedure prepsq!* u;
   begin scalar x;
        if null numr u then return 0
         else if minusf numr u
          then return list('minus,prepsq!*(negf numr u ./ denr u));
        x := kord!*;
        kord!* := append((for each j in factors!*
                     join if not idp j then nil
                           else for each k in get(j,'klist)
                                     collect car k),
                   append(factors!*,ordl!*));
        if kord!* neq x or wtl!*
          then u := formop numr u . formop denr u;
        u := if !*rat or (not flagp(dmode!*,'field) and !*div)
                      or upl!* or dnl!*
               then replus prepsq!*1(numr u,denr u,nil)
              else sqform(u,function(lambda j;
                            replus prepsq!*1(j,1,nil)));
        kord!* := x;
        return u
   end;

symbolic procedure prepsq!*0(u,v);
   %U is a standard quotient, but not necessarily in lowest terms.
   %V a list of factored powers;
   %Value is equivalent list of prefix expressions (an implicit sum);
   begin scalar x;
      return if null numr u then nil
              else if (x := gcdf(numr u,denr u)) neq 1
        then prepsq!*1(quotf(numr u,x),quotf(denr u,x),v)
       else prepsq!*1(numr u,denr u,v)
   end;

symbolic procedure prepsq!*1(u,v,w);
   %U and V are the numerator and denominator expression resp,
   %in lowest terms.
   %W is a list of powers to be factored from U;
   begin scalar x,y,z;
        %look for "factors" in the numerator;
        if not domainp u and (mvar u member factors!* or (not
                atom mvar u and car mvar u member factors!*))
          then return nconc!*(
               if v=1 then prepsq!*0(lc u ./ v,lpow u . w)
                else (begin scalar n,v1,z1;
                %see if the same "factor" appears in denominator;
                n := ldeg u;
                v1 := v;
                z1 := !*k2f mvar u;
                while (z := quotfm(v1,z1)) do <<v1 := z; n := n-1>>;
                return
                  prepsq!*0(lc u ./ v1,
                            if n>0 then (mvar u .** n) . w
                             else if n<0
                              then mksp(list('expt,mvar u,n),1) . w
                             else w)
                   end),
                        prepsq!*0(red u ./ v,w));
        %now see if there are any remaining "factors" in denominator
        %(KORD!* contains all potential kernel factors);
        if not domainp v
         then for each j in kord!* do
           begin integer n; scalar z1;
                n := 0;
                z1 := !*k2f j;
                while z := quotfm(v,z1) do <<n := n-1; v := z>>;
                if n<0 then w := mksp(list('expt,j,n),1) . w
           end;
        %now all "factors" have been removed;
        if kernlp u then <<u := mkkl(w,u); w := nil>>;
        if dnl!*
          then <<x := if null !*allfac then 1 else ckrn u;
                 z := ckrn!*(x,dnl!*);
                 x := quotof(x,z);
                 u := quotof(u,z);
                 v := quotof(v,z)>>;
        y := ckrn v;
        if upl!*
          then <<z := ckrn!*(y,upl!*);
                 y := quotof(y,z);
                 u := quotof(u,z);
                 v := quotof(v,z)>>;
        if null !*div then y := 1;
        u := canonsq (u . quotof(v,y));
%       if !*gcd then u := cancel u;
        u := quotof(numr u,y) ./ denr u;
        if null !*allfac then x := 1 else x := ckrn numr u;
        if null x then x := 1;
        % Probably means a large float whose inverse appears as 0.
        if !*allfac and x neq car u then go to b
         else if w then <<w := exchk w; go to c>>;
    d:  u := prepsq u;
        return if eqcar(u,'plus) then cdr u else list u;
    b:  if x=1 and null w then go to d;   % ONEP
        u := quotof(numr u,x) ./ denr u;
        w := prepf mkkl(w,x);
        if u = (1 ./ 1) then return list w
         else if eqcar(w,'times) then w := cdr w
         else w := list w;
    c:  return list retimes aconc!*(w,prepsq u)
   end;

symbolic procedure ckrn!*(u,v);
   if null u then errach 'ckrn!*
    else if domainp u then 1
    else if caaar u member v
       then list (caar u . ckrn!*(cdr carx(u,'ckrn),v))
    else ckrn!*(cdr carx(u,'ckrn),v);

symbolic procedure mkkl(u,v);
   if null u then v else mkkl(cdr u,list (car u . v));

symbolic procedure quotfm(u,v);
   begin scalar !*mcd; !*mcd := t; return quotf(u,v) end;

endmodule;


module depend; % Defining and checking expression dependency.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

global '(depl!* frlis!*);

% DEPL* is a list of dependencies among kernels;

symbolic procedure depend u;
   for each x in cdr u do depend1(car u,x,t);

symbolic procedure nodepend u;
   <<rmsubs(); for each x in cdr u do depend1(car u,x,nil)>>;

rlistat '(depend nodepend);

symbolic procedure depend1(u,v,bool);
   begin scalar y,z;
      u := !*a2k u;
      v := !*a2k v;
      if u eq v then return nil;
      y := assoc(u,depl!*);
%     if y then if bool then rplacd(y,union(list v,cdr y))
%                else if (z := delete(v,cdr y)) then rplacd(y,z)
      if y then if bool
                 then depl!*:= repasc(car y,union(list v,cdr y),depl!*)
                 else if (z := delete(v,cdr y))
                  then depl!* := repasc(car y,z,depl!*)
                 else depl!* := delete(y,depl!*)
       else if null bool
         then lprim list(u,"has no prior dependence on",v)
       else depl!* := list(u,v) . depl!*
   end;

symbolic procedure depends(u,v);
   if null u or numberp u or numberp v then nil
    else if u=v then u
    else if atom u and u memq frlis!* then t
      %to allow the most general pattern matching to occur;
    else if (lambda x; x and ldepends(cdr x,v)) assoc(u,depl!*)
     then t
    else if not atom u and idp car u and get(car u,'dname) then nil
    else if not atom u
      and (ldepends(cdr u,v) or depends(car u,v)) then t
    else if atom v or idp car v and get(car v,'dname) then nil
    % else dependsl(u,cdr v);
    else nil;

symbolic procedure ldepends(u,v);
   % Allow for the possibility that U is an atom.
   if null u then nil
    else if atom u then depends(u,v)
    else depends(car u,v) or ldepends(cdr u,v);

symbolic procedure dependsl(u,v);
   v and (depends(u,car v) or dependsl(u,cdr v));

symbolic procedure freeof(u,v);
   not(smember(v,u) or v member assoc(u,depl!*));

symbolic operator freeof;

flag('(freeof),'boolean);

% infix freeof;

% precedence freeof,lessp;   %put it above all boolean operators;

endmodule;


module str;  % Routines for structuring expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(scountr svar svarlis);

global '(!*fort !*nat !*savestructr varnam!*);

switch savestructr;

% ***** two essential uses of RPLACD occur in this module.

symbolic procedure structr u;
   begin scalar scountr,fvar,svar,svarlis;
      %SVARLIS is a list of elements of form:
      %(<unreplaced expression> . <newvar> . <replaced exp>);
      scountr :=0;
      fvar := svar := varnam!*;
      if cdr u
        then <<fvar := svar := cadr u; if cddr u then fvar := caddr u>>;
      u := aeval car u;
      if flagpcar(u,'struct)
        then u := car u .
           (for each j in cdr u collect for each k in j collect
                                 struct!*sq k)
       else if getrtype u then typerr(u,"STRUCTR argument")
       else u := struct!*sq u;
      if null !*fort
        then <<varpri(u,nil,'only);
               if not flagpcar(u,'struct) then terpri();
               if scountr=0 then return nil
                else <<if null !*nat then terpri();
                       prin2t "   where">>>>
       else svarlis := reversip!* svarlis;
      for each x in svarlis do
         <<terpri!* t;
           if null !*fort then prin2!* "      ";
             varpri(cddr x,list('setq,cadr x,mkquote cddr x),t)>>;
      if !*fort then fvarpri(u,list fvar,t);
      if !*savestructr
        then <<if arrayp svar
                 then <<put(svar,'array,
                            mkarray(list(scountr+1),'algebraic));
                        put(svar,'dimension,list(scountr+1))>>;
               for each x in svarlis do
                  setk2(cadr x,mk!*sq !*k2q car x)>>
   end;

rlistat '(structr);

symbolic procedure setk2(u,v);
   if atom u then setk1(u,v,t) else setelv(u,v);

symbolic procedure struct!*sq u;
   if eqcar(u,'!*sq)
     then mk!*sq(structf numr cadr u ./ structf denr cadr u)
    else u;

symbolic procedure structf u;
   if null u then nil
    else if domainp u then u
    else begin scalar x,y;
        x := mvar u;
        if sfp x then if y := assoc(x,svarlis) then x := cadr y
                else x := structk(prepsq!*(structf x ./ 1),
                                  structvar(),x)
         else if not atom x and not atomlis cdr x
          then if y := assoc(x,svarlis) then x := cadr y
                else x := structk(x,structvar(),x);
        return x .** ldeg u .* structf lc u .+ structf red u
     end;

symbolic procedure structk(u,id,v);
   begin scalar x;
      if x := subchk1(u,svarlis,id)
        then rplacd(x,(v . id . u) . cdr x)
       else if x := subchk2(u,svarlis)
        then svarlis := (v . id . x) . svarlis
       else svarlis := (v . id . u) . svarlis;
      return id
   end;

symbolic procedure subchk1(u,v,id);
   begin scalar w;
      while v do
       <<smember(u,cddar v)
            and <<w := v; rplacd(cdar v,subst(id,u,cddar v))>>;
         v := cdr v>>;
      return w
   end;

symbolic procedure subchk2(u,v);
   begin scalar bool;
      for each x in v do
       smember(cddr x,u)
          and <<bool := t; u := subst(cadr x,cddr x,u)>>;
      if bool then return u else return nil
   end;

symbolic procedure structvar;
   begin
      scountr := scountr + 1;
      return if arrayp svar then list(svar,scountr)
       else intern compress append(explode svar,explode scountr)
   end;

endmodule;


module coeff;  % Routines for finding coefficients of forms.

% Author: Anthony C. Hearn.

% Modifications by: F. Kako (including introduction of COEFFN).

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

global '(!*ratarg hipow!* lowpow!* wtl!*);

switch ratarg;

flag ('(hipow!* lowpow!*),'share);

symbolic procedure coeffeval u;
   begin integer n;
      n := length u;
      if n<2 or n>3
        then rederr "COEFF called with wrong number of arguments"
       else return coeff1(car u,cadr u,
                         if null cddr u then nil else caddr u)
      end;

put('coeff,'psopfn,'coeffeval);

symbolic procedure coeff1(u,v,w);
   % Finds the coefficients of V in U and returns results in W;
   begin scalar bool,x,y,z;
        v := !*a2k v;
        u := simp!* u;
        bool := !*ratarg or freeof(prepf denr u,v);
        if null bool then u := !*q2f u;
        x := setkorder list v;
        if null bool then <<y := reorder u; u := 1>>
         else <<y := reorder numr u; u := denr u>>;
        setkorder x;
        if null y then go to a;
        while not domainp y and mvar y=v
           do <<z := (ldeg y . !*ff2a(lc y,u)) . z; y := red y>>;
        if null y then go to b;
    a:  z := (0 . !*ff2a(y,u)) . z;
    b:  lowpow!* := caar z;
        z := reverse z;
        hipow!* := caar z;
        z := multiple!-result(z,w);
        return if null w then z else hipow!*
   end;

symbolic procedure coeffn(u,v,n);
   % Returns n-th coefficient of U.
   begin scalar bool,x,y;
      n := reval n;
      if not fixp n or minusp n then typerr(n,"COEFFN index");
      v := !*a2k v;
      u := simp!* u;
      bool := !*ratarg or freeof(prepf denr u,v);
      if null bool then u := !*q2f u;
      x := setkorder list v;
      if null bool then <<y := reorder u; u := 1>>
       else <<y := reorder numr u; u := denr u>>;
      setkorder x;
      if null y then return nil;
   b: if domainp y or mvar y neq v
        then return if n=0 then !*ff2a(y,u) else 0
       else if n=ldeg y then return !*ff2a(lc y,u)
       else if n>ldeg y then return 0
       else <<y := red y; go to b>>
   end;

flag('(coeffn),'opfn);

flag('(coeffn),'noval);

endmodule;


module weight; % Asymptotic command package.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(asymplis!*);

global '(wtl!*);

flag('(k!*),'reserved);

% Asymptotic list and weighted variable association lists.

symbolic procedure weight u;
   begin scalar y,z;
        rmsubs();
        for each x in u do
           if not eqexpr x then errpri2(x,'hold)
            else <<y := !*a2k cadr x;
                   z := reval caddr x;
                   if not (numberp z and fixp z and z>0)
                     then typerr(z,"weight");
                   wtl!* :=  (y . z) . delasc(y,wtl!*)>>
   end;

symbolic procedure wtlevel u;
   begin integer n; scalar x;
        n := reval car u;
        if not(numberp n and fixp n and not n<0)
          then errpri2(n,'hold);
        n := n+1;
        x := atsoc('k!*,asymplis!*);
        if n=cdr x then return nil else if n<=cdr x then rmsubs();
        asymplis!* := ('k!* . n) . delasc('k!*,asymplis!*)
   end;

rlistat '(weight wtlevel);

algebraic let k!***2=0;

endmodule;


module linop; % Linear operator package.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*intstr);

symbolic procedure linear u;
   for each x in u do
    if not idp x then typerr(x,'operator) else flag(list x,'linear);

rlistat '(linear);

put('linear,'simpfg,'((rmsubs)));

symbolic procedure formlnr u;
   begin scalar x,y,z;
      x := car u;
      if null cdr u or null cddr u
        then rederr list("Linear operator",
                         x,"called with too few arguments");
      y := cadr u;
      z := !*a2k caddr u . cdddr u;
      return if y = 1 then u
       else if not depends(y,car z)
        then list('times,y,x . 1 . z)
       else if atom y then u
       else if car y eq 'plus
        then 'plus . for each j in cdr y collect formlnr(x . j. z)
       else if car y eq 'minus
        then list('minus,formlnr(x . cadr y . z))
       else if car y eq 'difference
        then list('difference,formlnr(x . cadr y . z),
                              formlnr(x . caddr y . z))
       else if car y eq 'times then formlntms(x,cdr y,z,u)
       else if car y eq 'quotient then formlnquot(x,cdr y,z,u)
       else if car y eq 'recip and not depends(cadr y,car z)
        then list('quotient,x . 1 . z,cadr y)
       else if y := expt!-separate(y,car z)
        then list('times,car y,x . cdr y . z)
       else u
   end;

symbolic procedure formseparate(u,v);
   %separates U into two parts, and returns a dotted pair of them: those
   %which are not commutative and do not depend on V, and the remainder;
   begin scalar w,x,y;
      for each z in u do
        if not noncomp z and not depends(z,v) then x := z . x
         else if (w := expt!-separate(z,v))
        then <<x := car w . x; y := cdr w . y>>
         else y := z . y;
      return reversip!* x . reversip!* y
   end;

symbolic procedure expt!-separate(u,v);
   %determines if U is an expression in EXPT that can be separated into
   %two parts, one that does not depend on V and one that does,
   %except if there is no non-dependent part, NIL is returned;
   if not eqcar(u,'expt) or depends(cadr u,v)
           or not eqcar(caddr u,'plus)
     then nil
    else expt!-separate1(cdaddr u,cadr u,v);

symbolic procedure expt!-separate1(u,v,w);
   begin scalar x;
      x := formseparate(u,w);
      return if null car x then nil
              else list('expt,v,replus car x) .
                   if null cdr x then 1 else list('expt,v,replus cdr x)
   end;

symbolic procedure formlntms(u,v,w,x);
   %U is a linear operator, V its first argument with TIMES removed,
   %W the rest of the arguments and X the whole expression.
   %Value is the transformed expression;
   begin scalar y;
      y := formseparate(v,car w);
      return if null car y then x
              else 'times . aconc!*(car y,
                if null cddr y then formlnr(u . cadr y . w)
                      else u . ('times . cdr y) . w)
   end;

symbolic procedure formlnquot(fn,quotargs,rest,whole);
   %FN is a linear operator, QUOTARGS its first argument with QUOTIENT
   %removed, REST the remaining arguments, WHOLE the whole expression.
   %Value is the transformed expression;
   begin scalar x;
      return if not depends(cadr quotargs,car rest)
         then list('quotient,formlnr(fn . car quotargs . rest),
                   cadr quotargs)
        else if not depends(car quotargs,car rest)
               and car quotargs neq 1
         then list('times,car quotargs,
                   formlnr(fn . list('recip,cadr quotargs) . rest))
        else if eqcar(car quotargs,'plus)
         then 'plus . for each j in cdar quotargs
                collect formlnr(fn . ('quotient . j . cdr quotargs)
                                 . rest)
        else if eqcar(car quotargs,'minus)
         then list('minus,formlnr(fn .
                        ('quotient . cadar quotargs . cdr quotargs)
                            . rest))
        else if eqcar(car quotargs,'times)
                and car(x := formseparate(cdar quotargs,car rest))
         then 'times . aconc!*(car x,
                formlnr(fn . list('quotient,mktimes cdr x,
                             cadr quotargs) . rest))
        else if eqcar(cadr quotargs,'times)
                and car(x := formseparate(cdadr quotargs,car rest))
         then list('times,list('recip,mktimes car x),
                formlnr(fn . list('quotient,car quotargs,mktimes cdr x)
                         . rest))
        else if x := expt!-separate(car quotargs,car rest)
         then list('times,car x,formlnr(fn . list('quotient,cdr x,cadr
                                                     quotargs) . rest))
        else if x := expt!-separate(cadr quotargs,car rest)
         then list('times,list('recip,car x),
                   formlnr(fn . list('quotient,car quotargs,cdr x)
                              . rest))
        else if (x := reval!* cadr quotargs) neq cadr quotargs
         then formlnquot(fn,list(car quotargs,x),rest,whole)
        else whole
   end;

symbolic procedure mktimes u;
   if null cdr u then car u else 'times . u;

symbolic procedure reval!* u;
   %like REVAL, except INTSTR is always ON;
   begin scalar !*intstr;
      !*intstr := t;
      return reval u
   end;

endmodule;


module polyop; % Functions for algebraic mode operations on polynomials.

% Author: Anthony C. Hearn.

% Modified by: F. Kako.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

global '(!*ratarg);

symbolic procedure deg(u,kern);
   begin scalar x,y;
      u := simp!* u;
      y := denr u;
      tstpolyarg(y,u);
      u := numr u;
      kern := !*a2k kern;
      if domainp u then return 0
       else if mvar u eq kern then return !*f2a ldeg u;
      x := setkorder list kern;
      u := reorder u;
      if not(mvar u eq kern) then u := nil else u := ldeg u;
      setkorder x;
      return !*f2a u
   end;

symbolic procedure lcof(u,kern);
   begin scalar x,y;
      u := simp!* u;
      y := denr u;
      tstpolyarg(y,u);
      u := numr u;
      kern := !*a2k kern;
      if domainp u then return u
       else if mvar u eq kern
        then return !*ff2a(lc u,y);
      x := setkorder list kern;
      u := reorder u;
      if mvar u eq kern then u := lc u;
      setkorder x;
      return if null u then 0 else !*ff2a(u,y)
   end;

symbolic procedure lterm(u,kern);
   begin scalar x,y;
      u := simp!* u;
      y := denr u;
      tstpolyarg(y,u);
      u := numr u;
      kern := !*a2k kern;
      if domainp u then return nil
       else if mvar u eq kern
        then return !*ff2a(lt u .+ nil,y);
      x := setkorder list kern;
      u := reorder u;
      if not(mvar u eq kern) then u := nil
       else u := lt u .+ nil;
      setkorder x;
      u := reorder u;
      return if null u then 0 else !*ff2a(u,y)
   end;

symbolic procedure !*lterm u; lt u .+ nil;

symbolic procedure mainvar u;
   if domainp(u := numr simp!* u) then 0
    else if sfp(u := mvar u) then prepf u
    else u;

symbolic procedure reduct(u,kern);
   begin scalar x,y;
      u := simp!* u;
      y := denr u;
      tstpolyarg(y,u);
      u := numr u;
      kern := !*a2k kern;
      if domainp u then return !*ff2a(u,y)
       else if mvar u eq kern
        then return !*ff2a(cdr u,y);
      x := setkorder list kern;
      u := reorder u;
      if mvar u eq kern then u := cdr u else u := nil;
      setkorder x;
      u := reorder u;
      return !*ff2a(u,y)
   end;

symbolic procedure tstpolyarg(y,u);
   null !*ratarg and y neq 1 and typerr(prepsq u,"polynomial");

symbolic operator deg,lcof,lterm,mainvar,reduct;

endmodule;


module elem; % Simplification rules for elementary functions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*!*sqrt !*keepsqrts);

global '(e!-value!* pi!-value!* subfg!*);

% No references to RPLAC-based functions in this module.

algebraic;

comment RULE FOR I**2;

remflag('(i),'reserved);

let i**2= -1;

flag('(e i nil pi t),'reserved);

comment LOGARITHMS;

operator log;

let log(e)= 1,
    log(1)= 0;

for all x let log(e**x)=x;

% The next set of rules are not implemented yet.

%for all x,y let log(x*y) = log x + log y, log(x/y) = log x - log y;

for all x let df(log(x),x) = 1/x;

comment TRIGONOMETRICAL FUNCTIONS;

symbolic procedure simptrig u;
   % This is a basic simplification function for trigonometrical
   % functions. The prefix expression U is of the form (<trig-function>
   %  <argument>). It is assumed that the trig-function is either even
   % or odd, with even the default (and the odd case a flag "odd").
   % The value is a standard quotient for the simplified expression.
   % Note: we must use PREPSQXX and not PREPSQ* here, since the REVOP1
   % in SUBS3T uses PREPSQXX, and terms must be consistent to prevent a
   % loop in the pattern matcher.
   begin scalar bool,fn,x,z;
      fn := car u;
      u := cdr u;
      if null u or cdr u
        then rederr list("Wrong number of arguments to",fn);
      u := simp!* car u;
      if null numr u and flagp(fn,'odd) and not flagp(fn,'nonzero)
        then return nil ./ 1;
      x := list(fn,prepsqxx u);
      if subfg!* and (z := opmtch x) then return simp z
       else if minusf numr u
          and (flagp(fn,'odd) and (bool := t)
               or flagp(fn,'even))
        then <<x := list(fn,prepsqxx(u := (negf numr u ./ denr u)));
               if subfg!* and (z := opmtch x)
                 then <<x := simp z;
                        return if bool then negsq x else x>>>>;
      if z := domainvalchk(fn,list u) then x := z
       else x := mksq(x,1);
      return if bool then negsq x else x
   end;

deflist('((acos simptrig) (asin simptrig) (atan simptrig)
          (acosh simptrig) (asinh simptrig) (atanh simptrig)
          (cos simptrig) (sin simptrig) (tan simptrig)
          (sec simptrig) (csc simptrig)
          (cot simptrig)(acot simptrig)(coth simptrig)(acoth simptrig)
          (cosh simptrig) (sinh simptrig) (tanh simptrig)
   ),'simpfn);

% The following declaration causes the simplifier to pass the full
% expression (including the function) to SIMPTRIG.

flag ('(acos asin atan acosh asinh atanh cos sin tan cosh sinh tanh
        csc sec cot acot coth acoth),
      'full);

flag('(asin atan asinh atanh sin tan csc sinh tanh cot coth),
      'odd);

flag('(cos sec cosh acosh),'even);

flag('(cot coth),'nonzero);

%flag('(asin atan asinh atanh sin tan sinh tanh cot acot coth acoth),
%      'odd);

%flag('(cos sec),'even);

%flag('(cot),'nonzero);

% In the following rules, it is not necessary to let f(0)=0, when f
% is odd, since SIMPTRIG already does this.

let cos(0)= 1,
    cos(pi/6)=sqrt 3/2,
    sin(pi/6)= 1/2,
    cos(pi/4)=sqrt 2/2,
    sin(pi/4)=sqrt 2/2,
    cos(pi/3) = 1/2,
    sin(pi/3) = sqrt(3)/2,
    cos(pi/2)= 0,
    sin(pi/2)= 1,
    sin(pi)= 0,
    cos(pi)=-1,
    cosh 0=1,
    acos(0)= pi/2,
    acos(1)=0;

for all x let cos acos x=x, sin asin x=x, tan atan x=x,
           cosh acosh x=x, sinh asinh x=x, tanh atanh x=x,
           cot acot x=x, coth acoth x=x;

for all x let acos(-x)=pi-acos(x);

for all n such that numberp n and fixp n
    let sin(n*pi)=0,
        cos(n*pi) = (-1)**n;

for all n such that numberp n and fixp n let cos((n*pi)/2)= 0;

for all n such that numberp n and fixp n
   let sin((n*pi)/2) = if remainder(abs n,4)<2 then 1 else -1;

for all n such that numberp n and fixp n
   let cos((n*pi)/3)= 
       (if n=4 or remainder(abs n+2,6)>3 then -1 else 1)/2;

for all n such that numberp n and fixp n
   let sin((n*pi)/3)=
        (if remainder(abs n,6)<3 then 1 else -1)*sqrt(3)/2;

for all n such that numberp n and fixp n
   let cos((n*pi)/4)=
       (if remainder(abs n+2,8)<4 then 1 else -1)*sqrt(2)/2;

for all n such that numberp n and fixp n
   let sin((n*pi)/4)=
        (if remainder(abs n,8)<4 then 1 else -1)*sqrt(2)/2;

for all n such that numberp n and fixp n
   let cos((n*pi)/6)=
        (if remainder(abs n+2,12)<6 then 1 else -1)*sqrt(3)/2;

for all n such that numberp n and fixp n
   let sin((n*pi)/6)=
        (if remainder(abs n,12)<6 then 1 else -1)/2;

% ***** Differentiation rules *****.

for all x let df(acos(x),x)= -sqrt(1-x**2)/(1-x**2),
              df(asin(x),x)= sqrt(1-x**2)/(1-x**2),
              df(atan(x),x)= 1/(1+x**2),
              df(acosh(x),x)= sqrt(x**2-1)/(x**2-1),
              df(asinh(x),x)= sqrt(x**2+1)/(x**2+1),
              df(atanh(x),x)= 1/(1-x**2),
              df(cos x,x)= -sin(x),
              df(sin(x),x)= cos(x),
              df(tan x,x)=1+tan x**2,
              df(sinh x,x)=cosh x,
              df(cosh x,x)=sinh x,
              df(tanh x,x)=1-tanh x**2,
              df(cot x,x)=-1-cot x**2,
              df(coth x,x)=1-coth x**2;

let   e**(i*pi/2) = i,
      e**(i*pi) = -1,
      e**(3*i*pi/2)=-i;

%for all x let e**log x=x;   % Requires every power to be checked.

for all x,y let df(x**y,x)= y*x**(y-1),
                df(x**y,y)= log x*x**y;

comment SQUARE ROOTS;

deflist('((sqrt simpsqrt)),'simpfn);

%for all x let sqrt x**2=x;

% !*!*sqrt:  used to indicate that SQRTs have been used.

% !*keepsqrts:  causes SQRT rather than EXPT to be used.

symbolic procedure mksqrt u;
   if not !*keepsqrts then list('expt,u,list('quotient,1,2))
    else <<if null !*!*sqrt then <<!*!*sqrt := t;
                              algebraic for all x let sqrt x**2=x>>;
      list('sqrt,u)>>;

for all x let df(sqrt x,x)=sqrt x/(2*x);

comment ERF, EXP, EXPINT AND DILOG;

operator erf,exp,expint,dilog;

let erf 0=0;

let dilog(0)=pi**2/6;

for all x let erf(-x)=-erf x;

for all x let df(erf x,x)=2*sqrt(pi)*e**(-x**2)/pi;

for all x let exp(x)=e**x;

for all x let df(expint(x),x)=e**x/x;

for all x let df(dilog x,x)=-log x/(x-1);

comment Supply missing argument and simplify 1/4 roots of unity;

let   e**(i*pi/2) = i,
      e**(i*pi) = -1,
      e**(3*i*pi/2)=-i;

symbolic;

% Floating point interface for elementary functions.
% Perhaps this belongs in the floating point module.        

deflist('((exp !*exp!*) (expt !*expt!*) (log !*log!*) (sin !*sin!*)
          (cos !*cos!*) (tan !*tan!*) (asin !*asin!*) (acos !*acos!*)
          (atan !*atan!*) (sqrt !*sqrt!*) (e !*e!*) (pi !*pi!*)),
        '!:ft!:);

symbolic procedure !*acos!* u; mkfloat acos cdr u;

symbolic procedure !*asin!* u; mkfloat asin cdr u;

symbolic procedure !*atan!* u; mkfloat atan cdr u;

symbolic procedure !*cos!* u; mkfloat cos cdr u;

symbolic procedure !*exp!* u; mkfloat exp cdr u;

symbolic procedure !*expt!*(u,v);
   mkfloat if fixp v then expt(u,v) else exp(cdr v*log cdr u);

symbolic procedure !*log!* u; mkfloat log cdr u;

symbolic procedure !*sin!* u; mkfloat sin cdr u;

symbolic procedure !*tan!* u; mkfloat tan cdr u;

symbolic procedure !*e!*; mkfloat e!-value!*;

symbolic procedure !*pi!*; mkfloat pi!-value!*;

endmodule;


module nssimp;  % Simplification functions for non-scalar quantities.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

global '(!*div frlis!* subfg!*);

% Several inessential uses of ACONC, NCONC, and MAPping "JOIN". Latter
% not yet changed.

symbolic procedure nssimp(u,v);
   %U is a prefix expression involving non-commuting quantities.
   %V is the type of U.  Result is an expression of the form
   % SUM R(I)*PRODUCT M(I,J) where the R(I) are standard
   %quotients and the M(I,J) non-commuting expressions;
   %N. B: the products in M(I,J) are returned in reverse order
   %(to facilitate, e.g., matrix augmentation);
   begin scalar w,x,y,z;
        u := dsimp(u,v);
    a:  if null u then return z;
        w := car u;
    c:  if null w then go to d
         else if numberp car w
                or not(eqcar(car w,'!*div) or getrtype car w eq v)
          then x := aconc!*(x,car w)
         else y := aconc!*(y,car w);
        w := cdr w;
        go to c;
    d:  if null y then go to er;
    e:  z := addns(((if null x then 1 ./ 1 else simptimes x) . y),z);
        u := cdr u;
        x := y:= nil;
        go to a;
    er: y := v;
        if idp car x
          then if not flagp(car x,get(y,'fn)) then redmsg(car x,y)
            else rederr list(y,x,"not set")
         else if w := get(get(y,'tag),'i2d)
          then <<y := list apply1(w,1); go to e>>
         %to allow a scalar to be a 1 by 1 matrix;
         else msgpri(list("Missing",y,"in"),car x,nil,nil,t);
        put(car x,y,y);
        y := list car x;
        x := cdr x;
        go to e
   end;

symbolic procedure dsimp(u,v);
   %result is a list of lists representing a sum of products;
   %N. B: symbols are in reverse order in product list;
   if numberp u then list list u
    else if atom u
     then (if x and subfg!* then dsimp(x,v)
            else if flagp(u,'share) then dsimp(eval u,v)
            else <<flag(list u,'used!*); list list u>>)
      where x= get(u,'rvalue)
    else if car u eq 'plus
     then for each j in cdr u join dsimp(j,v)
    else if car u eq 'difference
     then nconc!*(dsimp(cadr u,v),
                dsimp('minus . cddr u,v))
    else if car u eq 'minus
     then dsimptimes(list(-1,carx(cdr u,'dsimp)),v)
    else if car u eq 'times then dsimptimes(cdr u,v)
    else if car u eq 'quotient
     then dsimptimes(list(cadr u,list('recip,carx(cddr u,'dsimp))),v)
    else if not getrtype u eq v then list list u
    else if car u eq 'recip
     then list list list('!*div,carx(cdr u,'dsimp))
    else if car u eq 'expt then (lambda z;
       if not numberp z or not fixp z then errpri2(u,t)
        else if z<0
         then list list list('!*div,'times . nlist(cadr u,-z))
         else if z=0 then list list list('!*div,cadr u,1)
        else dsimptimes(nlist(cadr u,z),v))
      reval caddr u
    else if flagp!*!*(car u,'noncommuting) then list list u
    else if arrayp car u
       then dsimp(getelv u,v)
    else (lambda x; if x then dsimp(x,v)
                     else (lambda y; if y then dsimp(y,v)
                                          else list list u)
                                opmtch revop1 u)
        opmtch u;

symbolic procedure dsimptimes(u,v);
   if null u then errach 'dsimptimes
    else if null cdr u then dsimp(car u,v)
    else (lambda j;
          for each k in dsimptimes(cdr u,v) join mappend(j,k))
       dsimp(car u,v);

symbolic procedure addns(u,v);
   if null v then list u
    else if cdr u=cdar v
       then (lambda x; % if null car x then cdr v else;
                         (x . cdr u) . cdr v)
       addsq(car u,caar v)
    else if ordp(cdr u,cdar v) then u . v
    else car v . addns(u,cdr v);

symbolic procedure getelx u;
   %to take care of free variables in LET statements;
   if smemqlp(frlis!*,cdr u) then nil
    else if null(u := getelv u) then 0
    else reval u;

endmodule;


module camlsp; % Definitions needed to run Cambridge LISP modules
               % supported in REDUCE under Standard LISP.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

% remprop('error,'newnam);

% putd('!%error,'expr,cdr getd 'error);

% symbolic macro procedure !%error u;
%   if null cddr u then list('error,50,cadr u) else 'error . cdr u;

% put('error,'newnam,'!%error);

% remprop('errorset,'newnam);

% putd('!%errorset,'expr,cdr getd 'errorset);

% symbolic macro procedure !%errorset u;
%    if null cdddr u then list('errorset,cadr u,caddr u,'!*backtrace)
%     else 'errorset . cdr u;

% put('errorset,'newnam,'!%errorset);

smacro procedure gcd(u,v); gcdn(u,v);

% symbolic smacro procedure gensym1 u; gensym();

symbolic smacro procedure iadd1 u; add1 u;

infix iequal;

symbolic smacro procedure u iequal v; eqn(u,v);

infix irem;

symbolic smacro procedure u irem v; remainder(u,v);

symbolic smacro procedure isub1 u; sub1 u;

symbolic procedure printc u; prin2t u;
   % Cannot be smacro because of FUNCTION PRINTC in INTBASISREDUCTION
   % and NORMALBASIS in full integrator.

symbolic smacro procedure readclock; time();

symbolic smacro procedure reversewoc u; reversip u;

symbolic smacro procedure princ u; prin2 u;

symbolic procedure superprint u; prettyprint u;
   % Cannot be smacro because of FUNCTION SUPERPRINT in COATESMATRIX
   % and JHDSOLVE.

symbolic smacro procedure unglobal u; nil;

comment The following three smacros can be used if there is a reason
for not using actual vectors;

%smacro procedure mkvect n; %mknill(n+1);

%smacro procedure putv(u,n,v); %car rplaca(pnth(u,n+1),v);

%smacro procedure getv(u,n); %nth(u,n+1);

endmodule;


module part;  % Access and updates parts of an algebraic expression.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

symbolic procedure revalpart u;
   begin scalar !*intstr,expn,v;
      !*intstr := t;   % To make following result in output form.
      expn := reval car u;
      !*intstr := nil;
      v := cdr u;
      while v do
         begin scalar x,y;
           if atom expn then parterr(expn,car v)
            else if not numberp(x := reval car v)
             then msgpri("Invalid argument",car v,"to part",nil,t)
            else if x=0
             then return <<expn := car expn; v := nil>>
            else if x<0 then <<x := -x; y := reverse cdr expn>>
            else y := cdr expn;
           if length y<x then parterr(expn,car v)
            else expn := nth(y,x);
       v := cdr v
     end;
      return expn
   end;

put('part,'psopfn,'revalpart);

symbolic procedure revalsetpart u;
   %Simplifies a SETPART expression;
   begin scalar !*intstr,x,y;
      x := reverse cdr u;
      !*intstr := t;
      y := reval car u;
      !*intstr := nil;
      return  revalsetp1(y,reverse cdr x,reval car x)
   end;

symbolic procedure revalsetp1(expn,ptlist,rep);
   if null ptlist then rep
    else if atom expn
             then msgpri("Expression",expn,
                         "does not have part",car ptlist,t)
    else begin scalar x;
      if not numberp(x := reval car ptlist)
             then msgpri("Invalid argument",car ptlist,"to part",nil,t)
       else return 
        if x=0 then rep . cdr expn
         else if x<0
          then car expn . 
                reverse ssl(reverse cdr expn,
                            -x,cdr ptlist,rep,expn . car ptlist)
         else car expn . ssl(cdr expn,x,cdr ptlist,
                             rep,expn . car ptlist)
   end;

symbolic procedure ssl(expn,indx,ptlist,rep,rest);
   if null expn
     then msgpri("Expression",car rest,"does not have part",cdr rest,t)
    else if indx=1 then revalsetp1(car expn,ptlist,rep) . cdr expn
    else car expn . ssl(cdr expn,indx-1,ptlist,rep,rest);

put('part,'setqfn,'setpart!*);

put('setpart!*,'psopfn,'revalsetpart);

symbolic procedure arglength u;
   begin scalar !*intstr,x;
      if null u then return 0;
      !*intstr := t;
      x := reval u;
      return if atom x then -1 else length cdr x
   end;

flag('(arglength),'opfn);

flag('(arglength),'noval);

endmodule;


end;

Added r33/algint.red version [d4b67d0f80].















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
module afactor;

% Author: James H. Davenport.

fluid '(!*galois !*noextend !*sqfree afactorvar listofnewsqrts
        monicpart);

global '(!*trfield);

exports afactor;
imports exptf,ordop,!*multf,addf,makemainvar,algebraicsf,divsf,contents;
imports quotf!*,negf,sqfr!-norm2,prepf,gcdinonevar,algint!-subf,!*q2f;
imports jfactor,printsf;

% internal!-fluid '(monicpart);

symbolic procedure afactor(u,v);
  % Factorises U over the algebraics as a polynomial in V (=afactorvar).
begin
  scalar afactorvar,!*noextend,!*sqfree;
  % !*sqfree is known to be square free (from sqfr-norm).
  !*noextend:=t; % else we get recursion.
  afactorvar:=v;
  if !*trfield
    then <<
    princ "We must factorise the following over: ";
    for each u in listofnewsqrts do <<princ u; princ " " >>;
    terpri();
    printsf u >>;
  v:=algfactor u;
  if !*trfield then <<
    printc "factorises as ";
    mapc(v,function printsf) >>;
  return v
  end;


symbolic procedure algfactor2(f,a);
if null a
  then for each u in jfactor(f,mvar f) collect numr u
  else if algebraicsf f
    then algfactor3(f,a)
    else begin
      scalar w;
      if !*trfield then <<
        princ "to be factorized over ";
        for each u in a do << princ u; princ " " >>;
        terpri();
        printsf f >>;
      if  (!*galois neq 2) and
          (numberp red f) and
          (not numberp argof car a)
        then return algfactor2(f,cdr a);
        % assumes we need never express a root of a number in terms of
        % non-numbers.
      w:=algfactor2(f,nil);
      if null cdr w
        then return algfactor3(f,a)
        else return 'partial.w
      end;


symbolic procedure algfactor3(f,a);
begin
  scalar ff,w,gg,h,p;
  w:=sqfr!-norm2(f,mvar f,car a);
  !*sqfree:=car w;
  w:=cdr w;
  ff:=algfactor2(!*sqfree,cdr a);
  if car ff eq 'partial then <<
    p:='partial;
    ff:=cdr ff >>;
  if null cdr ff
    then return list f;
    %does not factor.
  a:=car a;
  gg:=cadr w;
  w:=list list(afactorvar,'plus,afactorvar,prepf car w);
  h:=for each u in ff
       collect (!*q2f algint!-subf(gcdinonevar(u,gg,afactorvar),w));
  if p eq 'partial
    then h:=p.h;
  return h
  end;

symbolic procedure algfactor u;
begin
  scalar a,aa,z,w,monicpart;
  z:= makemainvar(u,afactorvar);
  if ldeg z iequal 1
    then return list u;
  z:=lc z;
  if z iequal 1
    then go to monic;
  if algebraicsf z
    then u:=!*multf(u,numr divsf(1,z));
    % this de-algebraicises the top coefficient.
  u:=quotf!*(u,contents(u,afactorvar));
  z:=makemainvar(u,afactorvar);
  if lc z neq 1
    then if lc z iequal -1
      then u:=negf u
      else <<
        w:=lc z;
        u:=makemonic z >>;
monic:
  aa:=listofnewsqrts;
  if algebraicsf u
    then go to normal;
  a:=cdr aa;
  % we need not try for the first one, since algfactor2
  % will do this for us.
  z:=t;
  while a and z do begin
    scalar alg,v;
    alg:=car a;
    a:=cdr a;
    v:=algfactor3(u,list alg);
    if null cdr v
      then return;
    if car v eq 'partial
      then v:=cdr v;
      % we do not mind if the factorisation is only partial.
    a:=mapcan(v,function algfactor);
    z:=nil
    end;
  monicpart:=w;
  if null z
    then if null w
      then return a
      else return mapcar(a,function demonise);
normal:
  z:=algfactor2(u,aa);
  monicpart:=w;
  if null cdr z or (car z neq 'partial)
    then if null w
      then return z
      else return mapcar(z,function demonise);
  % does not factor.
  if null w
    then return mapcan(cdr z,function algfactor)
    else return for each u in z conc
                  algfactor demonise u;
  end;


symbolic procedure demonise u;
% Replaces afactorvar by afactorvar*monicpart in u.
if atom u
  then u
  else if afactorvar eq mvar u
    then addf(demonise red u,
              !*multf(lt u .+ nil,exptf(monicpart,ldeg u)))
    else if ordop(afactorvar,mvar u)
      then u
      else addf(demonise red u,
                !*multf(!*p2f lpow u,demonise lc u));


symbolic procedure makemonic u;
% U is a makemainvar'd polynomial.
begin
  scalar v,w,x,xx;
  v:=mvar u;
  x:=lc u;
  xx:=1;
  w:=!*p2f lpow u;% the monic term.
  u:=red u;
  for i:=(isub1 ldeg w) step -1 until 1 do begin
    if atom u
      then go to next;
    if mvar u neq v
      then go to next;
    if ldeg u iequal i
      then w:=addf(w,!*multf(lc u,
                     !*multf(!*p2f lpow u,xx)));
    u:=red u;
  next:
    xx:=!*multf(x,xx)
    end;
  w:=addf(w,!*multf(u,xx));
  return w
  end;

% unfluid '(monicpart);

endmodule;


module algfn;

% Author: James H. Davenport.

% Check if an expression is in a pure algebraic extension of
% Q(all "constants")(var).


exports algfnpl,algebraicsf;

imports simp,interr,dependsp,dependspl;

symbolic procedure algfnp(pf,var);
   if atom pf then t
    else if not atom car pf then interr "Not prefix form"
    else if car pf eq '!*sq then algfnsq(cadr pf,var)
      else if car pf eq 'expt
       then if not algint!-ratnump caddr pf
              then (not dependsp(cadr pf,var))
                and (not dependsp(caddr pf,var))
             else algfnp(cadr pf,var)
    else if not memq(car pf,'(minus plus times quotient sqrt))
           % JPff fiddle
     then not dependspl(cdr pf,var)
    else algfnpl(cdr pf,var);

symbolic procedure algfnpl(p!-list,var);
   null p!-list or algfnp(car p!-list,var) and algfnpl(cdr p!-list,var);

symbolic procedure algfnsq(sq,var);
   algfnsf(numr sq,var) and algfnsf(denr sq,var);

symbolic procedure algfnsf(sf,var);
   atom sf
 or algfnp(mvar sf,var) and algfnsf(lc sf,var) and algfnsf(red sf,var);

symbolic procedure algint!-ratnump q;
   if atom q then numberp q
    else car q eq 'quotient and (numberp cadr q) and (numberp caddr q);

symbolic procedure algebraicsf u;
   if atom u then nil
    else algebraicp mvar u or algebraicsf lc u or algebraicsf red u;

symbolic procedure algebraicp u;
   if atom u then nil
    else if car u eq 'expt then 1 neq denr simp caddr u
    else car u eq 'sqrt;

endmodule;


module algnums;

% Author: James H. Davenport.

exports denr!-algno;


symbolic procedure denr!-algno u;
% Returns the true denominator of the algebraic number u.
begin
  scalar sqlist,n,m,u!*!*j,d,isub1n;
  u!*!*j:=1 ./ 1;
  sqlist:=sqrtsinsq(u,nil);
  sqlist:=multbyallcombinations(list(1 ./ 1),
                               for each u in sqlist
                                 collect !*kk2q u);
  n:=0;
  sqlist:=for each u in sqlist collect
    (numr u) . (n:=iadd1 n);
    % format is of an associtaion list.
  n:=length sqlist;
  m:=mkvect n;
  isub1n:=isub1 n;
  for i:=0:n do
    putv(m,i,mkvect2(n,nil ./ 1));
  putv(getv(m,0),cdr assoc(1,sqlist),1 ./ 1);
  % initial matrix is now set up.
  for j:=1:n do begin
    scalar v,w;
    u!*!*j:=!*multsq(u!*!*j,u);
    dump!-sqrts!-coeffs(u!*!*j,sqlist,getv(m,j));
    v:=firstlinearrelation(m,n);
    if null v
      then return;
    if last!-non!-zero v > j
      then return;
    if (w:=getv(v,j)) neq (1 ./ 1)
      then <<
        w:=!*invsq w;
        for i:=0:j do
          putv(v,i,!*multsq(w,getv(v,i))) >>;
    m:=v;
    n:=j;
    return
    end;
  % Now m is a monic polynomial, minimal for u, of degree n.
  d:=1;
  for i:=0:isub1 n do begin
    scalar v,prime;
    v:=denr getv(m,i);
    prime:=2;
loop:
    if v = 1
      then return;
    if not zerop cdr divide(v,prime)
      then prime:=nextprime(prime)
      else <<
        d:=d*prime;
        for i:=0:n do
          putv(v,i,multsq(getv(v,i),1 ./ (prime ** (n-i)) )) >>;
    go to loop;
    end;
  return d;
  end;


symbolic procedure dump!-sqrts!-coeffs(u,sqlist,vec);
begin
  scalar w;
  dump!-sqrts!-coeffs2(numr u,sqlist,vec,1);
  u:=1 ./ denr u;
  if denr u neq 1
    then for i:=0:upbv vec do
      if numr(w:=getv(vec,i))
        then putv(vec,i,!*multsq(u,w));
  end;


symbolic procedure dump!-sqrts!-coeffs2(u,sqlist,vec,sqrtssofar);
if null u
  then nil
  else if numberp u
    then putv(vec,cdr assoc(sqrtssofar,sqlist),u)
    else <<
      dump!-sqrts!-coeffs2(red u,sqlist,vec,sqrtssofar);
      dump!-sqrts!-coeffs2(lc u,sqlist,vec,!*multf(sqrtssofar,
                                                   !*k2f mvar u)) >>;


symbolic procedure last!-non!-zero vec;
begin
  scalar n;
  for i:=0:upbv vec do
    if numr getv(vec,i)
      then n:=i;
  return n
  end;

endmodule;


module antisubs;

% Author: James H. Davenport.

exports antisubs;

imports purge,interr,dependsp;


symbolic procedure antisubs(place,x);
% Produces the inverse substitution to a substitution list.
begin
  scalar answer,w;
  while place and
        (x=caar place) do<<
    w:=cdar place;
    % w is the substitution rule.
    if atom w
      then if w neq x
        then interr "False atomic substitution"
        else nil
      else answer:=(x.anti2(w,x)).answer;
    place:=cdr place>>;
  if null answer
    then answer:=(x.x).answer;
  return answer
  end;


symbolic procedure anti2(eexpr,x);
%Produces the function inverse to the eexpr provided.
if atom eexpr
  then if eexpr eq x
    then x
    else interr "False atom"
  else if car eexpr eq 'plus
    then deplus(cdr eexpr,x)
    else if car eexpr eq 'minus
      then subst(list('minus,x),x,anti2(cadr eexpr,x))
      else if car eexpr eq 'quotient
        then if dependsp(cadr eexpr,x)
          then if dependsp(caddr eexpr,x)
            then interr "Complicated division"
            else subst(list('times,caddr eexpr,x),x,anti2(cadr eexpr,x))
          else if dependsp(caddr eexpr,x)
            then subst(list('quotient,cadr eexpr,x),x,
                       anti2(caddr eexpr,x))
            else interr "No division"
        else if car eexpr eq 'expt
          then if caddr eexpr iequal 2
            then subst(list('sqrt,x),x,anti2(cadr eexpr,x))
            else interr "Unknown root"
          else if car eexpr eq 'times
            then detimes(cdr eexpr,x)
            else if car eexpr eq 'difference
              then deplus(list(cadr eexpr,list('minus,caddr eexpr)),x)
              else interr "Unrecognised form in antisubs";



symbolic procedure detimes(p!-list,var);
% Copes with lists 'times.
begin
  scalar u,v;
  u:=deplist(p!-list,var);
  v:=purge(u,p!-list);
  if null v
    then v:=var
    else if null cdr v
      then v:=list('quotient,var,car v)
      else v:=list('quotient,var,'times.v);
  if (null u) or
     (cdr u)
    then interr "Weird multiplication";
  return subst(v,var,anti2(car u,var))
  end;


symbolic procedure deplist(p!-list,var);
% Returns a list of those elements of p!-list which depend on var.
if null p!-list
  then nil
  else if dependsp(car p!-list,var)
    then (car p!-list).deplist(cdr p!-list,var)
    else deplist(cdr p!-list,var);


symbolic procedure deplus(p!-list,var);
% Copes with lists 'plus.
begin
  scalar u,v;
  u:=deplist(p!-list,var);
  v:=purge(u,p!-list);
  if null v
    then v=var
    else if null cdr v
      then v:=list('plus,var,list('minus,car v))
      else v:=list('plus,var,list('minus,'plus.v));
  if (null u) or
     (cdr u)
    then interr "Weird addition";
  return subst(v,var,anti2(car u,var))
  end;

endmodule;


module coates;
 
% Author: James H. Davenport.
 
fluid '(intvar magiclist nestedsqrts previousbasis sqrt!-intvar
        taylorasslist thisplace);
 
global '(!*tra !*trmin coates!-fdi);
 
exports coates,makeinitialbasis,checkpoles,multbyallcombinations;
 
 
 
 
 
symbolic procedure coates(places,mults,x);
begin
  scalar u,tt;
  tt:=readclock();
  u:=coates!-hpfsd(places,mults);
  if !*tra or !*trmin then
    printc  list ('coates,'time,readclock()-tt,'milliseconds);
  return u
  end;
 
 
 
symbolic procedure coates!-real(places,mults);
begin
  scalar thisplace,u,v,save;
  if !*tra or !*trmin then <<
    princ "Find function with zeros of order:";
    printc mults;
    if !*tra then
      princ " at ";
    terpri!*(t);
    if !*tra then
      mapc(places,function printplace) >>;
%  v:=placesindiv places;
    % V is a list of all the substitutors in PLACES;
%  u:=mkunique sqrtsintree(v,intvar,nil);
%  if !*tra then <<
%    princ "Sqrts on this curve:";
%    terpri!*(t);
%    superprint u >>;
%  algnos:=mkunique mapcar(places,function basicplace);
%  if !*tra then <<
%    printc "Algebraic numbers where residues occur:";
%    superprint algnos >>;
  v:=mults;
  for each uu in places do <<
    if (car v) < 0
      then u:=(rfirstsubs uu).u;
    v:=cdr v >>;
  thisplace:=list('quotient,1,intvar);
  if member(thisplace,u)
    then <<
      v:= finitise(places,mults);
      % returns list (places,mults,power of intvar to remove.
      u:=coates!-real(car v,cadr v);
      if atom u
        then return u;
      return multsq(u,!*p2q mksp(intvar,caddr v)) >>;
% It is not sufficient to check the current value of U in FRACTIONAL...
% as we could have zeros over infinity JHD 18/8/86;
  for each uu in places do
    if rfirstsubs uu = thisplace
      then u:=append(u,mapcar(cdr uu,function car));
  coates!-fdi:=fractional!-degree!-at!-infinity u;
% Do we need to blow everything up by a factor of two (or more)
% to avoid fractional powers at infinity?
  if coates!-fdi iequal 1
    then return coatesmodule(places,mults,intvar);
  if !*tra
    then fdi!-print();
  places:=mapcar(places,function fdi!-upgrade);
  save:=taylorasslist;
  u:=coatesmodule(places,
    mapcar(mults,function (lambda u;u*coates!-fdi)),
                  intvar);
  taylorasslist:=save;
% u:=fdi!-revertsq u;
% That previous line is junk, I think (JHD 22.8.86)
% just because we blew up the places doesn't mean that
% we should deflate the function, because that has already been done.
  return u
  end;
 
 
 
symbolic procedure coatesmodule(places,mults,x);
begin
  scalar pzero,mzero,u,v,basis,sqrts,magiclist,mpole,ppole;
    % MAGICLIST holds the list of extra unknowns created in JHDSOLVE
    % which must be found in CHECKPOLES (calling FINDMAGIC).
  sqrts:=sqrtsinplaces places;
  if !*tra then <<
    princ "Sqrts on this curve:";
    superprint sqrts >>;
  u:=places;
  v:=mults;
  while u do <<
    if 0<car v
      then <<
        mzero:=(car v).mzero;
        pzero:=(car u).pzero >>
      else <<
        mpole:=(car v).mpole;
        ppole:=(car u).ppole >>;
    u:=cdr u;
    v:=cdr v >>;
  % ***time-hack-2***;
  if previousbasis then basis:=previousbasis
    else basis:=mkvec makeinitialbasis ppole;
  u:=completeplaces(ppole,mpole);
  basis:=integralbasis(basis,car u,cdr u,x);
  basis:=normalbasis(basis,x,0);
  u:=coatessolve(mzero,pzero,basis,nil);
    % The NIL is the list of special constraints needed
    % to force certain poles to occur in the answer.
  if atom u
    then return u;
  v:= checkpoles(list u,places,mults);
  if null v
    then return 'failed;
  if not magiclist
    then return u;
  u:=removecmsq substitutesq(u,v);
  % Apply the values from FINDMAGIC.
  if !*tra or !*trmin then <<
    printc "These values give the function";
    printsq u >>;
  magiclist:=nil;
  if checkpoles(list u,places,mults)
    then return u
    else interr "Inconsistent checkpoles"
  end;
 
 
 
symbolic procedure makeinitialbasis places;
begin
  scalar u;
  u:=multbyallcombinations(list(1 ./ 1),
                           for each u in getsqrtsfromplaces places
         collect !*kk2q u);
  if !*tra then <<
    printc "Initial basis for the space m(x)";
    mapc(u,function printsq) >>;
  return u
  end;
 
 
 
symbolic procedure multbyallcombinations(u,l);
% Produces a list of all elements of u,
% each multiplied by every combination of elements of l.
if null l
  then u
  else multbyallcombinations(nconc(multsql(car l,u),u),cdr l);
 
 
 
symbolic procedure checkpoles(basis,places,mults);
% Checks that the BASIS really does have all the
%  poles in (PLACES.MULTS).
begin
  scalar u,v,l;
  go to outer2;
outer:
  places:=cdr places;
  mults:=cdr mults;
outer2:
  if null places
    then return if magiclist
                  then findmagic l
                  else t;
  if 0 leq car mults
    then go to outer;
  u:=basis;
inner:
  if null u
    then <<
      if !*tra
        then <<
          princ "The answer from the linear equations did";
          printc " not have the poles at:";
          printplace car places >>;
      return nil >>;
  v:=taylorform xsubstitutesq(car u,car places);
  if taylorfirst v=car mults
    then <<
      if magiclist
        then l:=taylorevaluate(v,car mults) . l;
      go to outer >>;
  if taylorfirst v < car mults
    then interr "Extraneous pole introduced";
  u:=cdr u;
  go to inner
  end;
 
 
 
symbolic procedure coates!-hpfsd(oplaces,omults);
begin
  scalar mzero,pzero,mpole,ppole,fun,summzero,answer,places,mults;
  places:=oplaces;
  mults:=omults;
  % Keep originals in case need to use COATES!-REAL directly.
  summzero:=0;
    % holds the sum of all the mzero's.
  while places do <<
    if 0<car mults
      then <<
        summzero:=summzero + car mults;
        mzero:=(car mults).mzero;
        pzero:=(car places).pzero >>
      else <<
        mpole:=(car mults).mpole;
        ppole:=(car places).ppole >>;
    places:=cdr places;
    mults:=cdr mults >>;
  if summzero > 2 then begin
    % We want to combine a zero/pole pair
    % so as to reduce the total index before calling coates!-real
    % on the remaining zeros/poles.
    scalar nplaces,nmults,f,multiplicity,newpole,sqrts,fz,zfound,mult1;
    sqrts:=getsqrtsfromplaces ppole;
    if !*tra or !*trmin then <<
      princ "Operate on divisor:";
      printc append(mzero,mpole);
      printc "at";
      mapc(pzero,function printplace);
      mapc(ppole,function printplace) >>;
iterate:
    nplaces:=list car pzero;
    multiplicity:=car mzero;
    nmults:=list 1;
    if cdr ppole
      then <<
        nplaces:=(car ppole) . ( (cadr ppole) . nplaces);
        multiplicity:=min(multiplicity,- car mpole,- cadr mpole);
        nmults:=(-1) .((-1) . nmults) >>
      else <<
        nplaces:=(car ppole) . nplaces;
        multiplicity:=min(multiplicity,(- car mpole)/2);
        nmults:=(-2) . nmults >>;
    previousbasis:=nil;
    f:=coates!-real(nplaces,nmults);
    if atom f
      then <<
 if !*tra or !*trmin then
          printc "Failure: must try whole divisor";
 return coates!-real(oplaces,omults) >>;
%    newpole:=removezero(findzeros(f,sqrts),car pzero).
    fz:=findzeros(f,sqrts);
    zfound:=assoc(car pzero,fz);
    if not zfound
       then interr "Didn't seem to find the zeros we looked for";
    if cdr zfound > car mzero
       then interr "We found too many zeros";
    fz:=delete(zfound,fz);
    if !*tra or !*trmin then <<
      printc "Replaced by the pole";
      if fz then prettyprint fz
       else <<terpri(); prin2t "The zero we were already looking for">>;
      princ multiplicity;
      printc " times" >>;
    mult1:=car mzero - multiplicity * cdr zfound;
    if mult1 < 0
 then << printc "A zero has turned into a pole";
         multiplicity:= car mzero / cdr zfound ;
  mult1:=remainder(car mzero, cdr zfound); >>;
    if zerop mult1
      then <<
        mzero:=cdr mzero;
        pzero:=cdr pzero >>
      else rplaca(mzero,mult1);
    if null cdr ppole
      then <<
        if zerop (car mpole + 2*multiplicity)
          then <<
            ppole:=cdr ppole;
     mpole:=cdr mpole >>
          else rplaca(mpole,car mpole + 2 * multiplicity) >>
      else <<
        if zerop (cadr mpole + multiplicity)
          then <<
            ppole:=(car ppole) . (cddr ppole);
            mpole:=(car mpole) . (cddr mpole) >>
          else rplaca(cdr mpole,cadr mpole + multiplicity);
        if zerop (car mpole + multiplicity)
          then <<
            ppole:=cdr ppole;
            mpole:=cdr mpole >>
          else rplaca(mpole,car mpole + multiplicity) >>;
    while fz do <<
      newpole:=caar fz;
      mult1:=multiplicity*(cdar fz);
      if newpole member pzero
        then begin
          scalar m,p;
          while newpole neq car pzero do <<
            m:=(car mzero).m;
            mzero:=cdr mzero;
            p:=(car pzero).p;
            pzero:=cdr pzero >>;
          if mult1 < car mzero then <<
            mzero:=(car mzero - mult1) . cdr mzero;
            mzero:=nconc(m,mzero);
            pzero:=nconc(p,pzero);
            return >>;
          if mult1 > car mzero then <<
            ppole:=newpole.ppole;
            mpole:=(car mzero - mult1) . mpole >>;
          mzero:=nconc(m,cdr mzero);
          pzero:=nconc(p,cdr pzero)
          end
        else if newpole member ppole then begin
          scalar m,p;
          m:=mpole;
          p:=ppole;
          while newpole neq car p do <<
            p:=cdr p;
            m:=cdr m >>;
          rplaca(m,car m - mult1)
          end
        else <<
          mpole:=nconc(mpole,list(-mult1));
          ppole:=nconc(ppole,list newpole) >>;
      fz:=cdr fz >>;
    f:=mk!*sq f;
    if multiplicity > 1
      then answer:=list('expt,f,multiplicity).answer
      else answer:=f.answer;
    summzero:=0;
    for each x in mzero do summzero:=summzero+x;
    if !*tra then <<
      princ "Function is now: ";
      printc append(mzero,mpole);
      printc "at";
      mapc(pzero,function printplace);
      mapc(ppole,function printplace) >>;
    if summzero > 2
      then go to iterate;
    end;
  fun:=coates!-real(nconc(pzero,ppole),
                    nconc(mzero,mpole));
  if null answer
    then return fun
    else answer:=(mk!*sq fun).answer;
  return !*k2q('times.answer);
    % This is not valid, but we hope that it will be unpicked;
    % (e.g. by SIMPLOG) before too much damage is caused.
  end;
 
 
 
symbolic procedure removezero(l,place);
if place member l
  then (lambda u; if null cdr u
                    then car u
                    else interr "Removezero") delete(place,l)
  else interr "Error in removezeros";
 
 
 
symbolic procedure findzeros(sq,sqrts);
begin
  scalar u,potentials,answer,n;
  u:=denr sqrt2top invsq sq;
  potentials:=for each v in jfactor(u,intvar) collect begin
    scalar w,place;
    w:=makemainvar(numr v,intvar);
    if ldeg w neq 1
      then interr "Can't cope";
    if red w
      then place:=list(intvar,'plus,intvar,prepsq(negf red w ./ lc w))
      else place:=intvar . intvar;
      % This IF .. ELSE .. added JHD 3 Sept 1980.
    return place
    end;
  potentials:=list(intvar,'quotient,1,intvar).potentials;
  for each place in potentials do begin
    scalar slist,nestedsqrts;
    place:=list place;
    newplace place;
    u:=substitutesq(sq,place);
    while involvesq(u,sqrt!-intvar) do begin
      scalar z;
      z:=list list(intvar,'expt,intvar,2);
      place:=nconc(place,z);
      newplace place;
      u:=substitutesq(u,z);
      end;
    slist:=sqrtsinsq(u,intvar);
    for each v in sqrts do
      slist:=union(slist,sqrtsinsq(xsubstitutesq(!*kk2q v,place),
       intvar));
    slist:=sqrtsign(slist,intvar);
    for each s in slist do
      if (n:=taylorfirst taylorform substitutesq(u,s)) > 0
        then answer:=(append(place,s).n).answer;
    return answer;
    end;
  if null answer
    then interr "No zero found";
  return answer
  end;
 
endmodule;


module coatesid;
 
% Author: James H. Davenport.
 
fluid '(intvar magiclist nnn taylorasslist taylorvariable);
 
global '(!*tra);
 
exports coatessolve,vecprod,coates!-lineq;
 
imports !*invsq,!*multsq,negsq,!*addsq,swap,check!-lineq,non!-null!-vec,
 printsq,sqrt2top,mapvec,mksp,vecsort,addsq,mkilist,mkvec,mapply,
 taylorformp,xsubstitutesq,taylorform,taylorevaluate,multsq,
 invsq,removecmsq;
 
symbolic procedure coatessolve(mzero,pzero,basis,normals);
begin
  scalar m,n,rightside,nnn;
% if null normals
%   then normals:=list mkilist(basis,1 ./ 1);
%     This provides the default normalisation,
%     viz merely a de-homogenising constraint;
% No it doesn't - JHD May 1983 and August 1986.
% This may be precisely the wrong constraint, as can be seen from
% the example of SQRT(X**2-1).  Fixed 19/8/86 to amend COATESMATRIX
% to insert a normalising constraint if none is provided.
  nnn:=max(length normals,1);
  basis:=mkvec basis;
  m:=coatesmatrix(mzero,pzero,basis,normals);
  n:=upbv m;
  rightside:=mkvect n;
  for i:=0:n do
    putv(rightside,n-i,(if i < nnn
                       then 1
                       else nil) ./ 1);
  n:=coates!-lineq(m,rightside);
  if n eq 'failed
    then return 'failed;
  n:=removecmsq vecprod(n,basis);
  if !*tra then <<
    printc "Answer from linear equation solving is ";
    printsq n >>;
  return n
  end;
 
 
 
symbolic procedure coatesmatrix(mzero,pzero,basis,normals);
% NORMALS is a list of the normalising constraints
% that we must apply.  Thypically, this is NIL, and we have to
% invent one - see the code IF NULL NORMALS ...
begin
  scalar ans,n1,n2,j,w,save,nextflag,save!-taylors,x!-factors,
         normals!-ok,temp;
  save!-taylors:=mkvect isub1 length pzero;
  save:=taylorasslist;
  normals!-ok:=nil;
  n1:=upbv basis;
  n2:=isub1 mapply(function plus2,mzero) + max(length normals,1);
    % the number of constaints in all (counting from 0).
  taylorvariable:=intvar;
  if !*tra then <<
    printc "Basis for the functions with precisely the correct poles";
    mapvec(basis,function printsq) >>;
  ans:=mkvect n2;
  for i:=0:n2 do
    putv(ans,i,mkvect n1);
  for i:=0:n1 do begin
    scalar xmz,xpz,k;
    xmz:=mzero;
    k:=j:=0;
    xpz:=pzero;
    while xpz do <<
      newplace basicplace car xpz;
      if nextflag
        then w:=taylorformp list('binarytimes,
     getv(save!-taylors,k),
     getv(x!-factors,k))
 else if not !*tra
          then w:=taylorform xsubstitutesq(getv(basis,i),car xpz)
          else begin
            scalar flg,u,slists;
            u:=xsubstitutesq(getv(basis,i),basicplace car xpz);
            slists:=extenplace car xpz;
            for each w in sqrtsinsq(u,intvar) do
              if not assoc(w,slists)
                then flg:=w.flg;
            if flg then <<
              printc "The following square roots were not expected";
              mapc(flg,function superprint);
              printc "in the substitution";
              superprint car xpz;
              printsq getv(basis,i) >>;
            w:=taylorform xsubstitutesq(u,slists)
            end;
      putv(save!-taylors,k,w);
      k:=iadd1 k;
      for l:=0 step 1 until isub1 car xmz do <<
        astore(ans,j,i,taylorevaluate(w,l));
        j:=iadd1 j >>;
      if null normals and j=n2 then <<
 temp:=taylorevaluate(w,car xmz);
 astore(ans,j,i,temp);
 % The defaults normalising condition is that the coefficient
 % after the last zero be a non-zero.
 % Unfortunately this too may fail (JHD 21.3.87) - check for it later
 normals!-ok:=normals!-ok or numr temp >>;
      xpz:=cdr xpz;
      xmz:=cdr xmz  >>;
    nextflag:=(i < n1) and
       (getv(basis,i) = multsq(!*kk2q intvar,getv(basis,i+1)));
    if nextflag and null x!-factors then <<
      x!-factors:=mkvect upbv save!-taylors;
      xpz:=pzero;
      k:=0;
      xmz:=invsq !*kk2q intvar;
      while xpz do <<
 putv(x!-factors,k,taylorform xsubstitutesq(xmz,car xpz));
        xpz:=cdr xpz;
        k:=iadd1 k >> >>
    end;
  if null normals and null normals!-ok then <<
     if !*tra
       then printc "Our default normalisation condition was vacuous";
     astore(ans,n2,n1,1 ./ 1)>>;
  while normals do <<
    w:=car normals;
    for k:=0:n1 do <<
      astore(ans,j,k,car w);
      w:=cdr w >>;
    j:=iadd1 j;
    normals:=cdr normals >>;
  tayshorten save;
  return ans
  end;
 
 
symbolic procedure printmatrix(ans,n2,n1);
if !*tra
  then <<
    printc "Equations to be solved:";
    for i:=0:n2 do begin
      if null getv(ans,i)
        then return;
      princ "Row number ";
      princ i;
      for j:=0:n1 do
        printsq getv(getv(ans,i),j)
      end >>;
 
 
 
symbolic procedure vecprod(u,v);
begin
  scalar w,n;
  w:=nil ./ 1;
  n:=upbv u;
  for i:=0:n do
    w:=addsq(w,!*multsq(getv(u,i),getv(v,i)));
  return w
  end;
 
 
 
symbolic procedure coates!-lineq(m,rightside);
begin
  scalar nnn,n;
  nnn:=desparse(m,rightside);
  if nnn eq 'failed
    then return 'failed;
  m:=car nnn;
  if null m
    then <<
      n:=cddr nnn;
      goto vecprod >>;
  rightside:=cadr nnn;
  nnn:=cddr nnn;
  n:=check!-lineq(m,rightside);
  if n eq 'failed
    then return n;
  n:=jhdsolve(m,rightside,non!-null!-vec nnn);
  if n eq 'failed
    then return n;
  for i:=0:upbv n do
    if (m:=getv(nnn,i))
      then putv(n,i,m);
vecprod:
  for i:=0:upbv n do
    if null getv(n,i) then putv(n,i,nil ./ 1);
  return n
  end;
 
 
 
symbolic procedure jhdsolve(m,rightside,ignore);
% Returns answer to m.answer=rightside.
% Matrix m not necessarily square.
begin
  scalar n1,n2,ans,u,row,swapflg,swaps;
  % The SWAPFLG is true if we have changed the order of the
  % columns and need later to invert this via SWAPS.
  n1:=upbv m;
  for i:=0:n1 do
    if (u:=getv(m,i))
      then (n2:=upbv u);
  printmatrix(m,n1,n2);
  swaps:=mkvect n2;
  for i:=0:n2 do
    putv(swaps,i,n2-i);
    % We have the SWAPS vector, which should be a vector of indices,
    % arranged like this because VECSORT sorts in decreasing order.
  for i:=0:isub1 n1 do begin
    scalar k,v,pivot;
  tryagain:
    row:=getv(m,i);
    if null row
      then go to interchange;
    % look for a pivot in row.
    k:=-1;
    for j:=0:n2 do
      if numr (pivot:=getv(row,j))
        then <<
          k:=j;
          j:=n2 >>;
    if k neq -1
      then goto newrow;
    if numr getv(rightside,i)
      then <<
        m:='failed;
        i:=sub1 n1; %Force end of loop.
        go to finished >>;
    % now interchange i and last element.
interchange:
    swap(m,i,n1);
    swap(rightside,i,n1);
    n1:=isub1 n1;
    if i iequal n1
      then goto finished
      else goto tryagain;
  newrow:
    if i neq k
      then <<
        swapflg:=t;
        swap(swaps,i,k);
          % record what we have done.
        for l:=0:n1 do
          swap(getv(m,l),i,k) >>;
        % place pivot on diagonal.
    pivot:=sqrt2top negsq !*invsq pivot;
    for j:=iadd1 i:n1 do begin
      u:=getv(m,j);
      if null u
        then return;
      v:=!*multsq(getv(u,i),pivot);
      if numr v then <<
        putv(rightside,j,
     !*addsq(getv(rightside,j),!*multsq(v,getv(rightside,i))));
        for l:=0:n2 do
   putv(u,l,!*addsq(getv(u,l),!*multsq(v,getv(row,l)))) >>
      end;
  finished:
    end;
  if m eq 'failed
    then go to failed;
    % Equations were inconsistent.
  while null (row:=getv(m,n1)) do
    n1:=isub1 n1;
  u:=nil;
  for i:=0:n2 do
    if numr getv(row,i)
      then u:='t;
  if null u
    then if numr getv(rightside,n1)
      then go to failed
      else n1:=isub1 n1;
      % Deals with a last equation which is all zero.
  if n1 > n2
    then go to failed;
    % Too many equations to satisfy.
  ans:=mkvect n2;
  n2:=n2 - ignore;
  if n1 < n2 then <<
    if !*tra then <<
      printc "The equations do not completely determine the functions";
      printc "Matrix:";
      mapvec(m,function superprint);
      printc "Right-hand side:";
      superprint rightside >>;
    for i:=iadd1 n1:n2 do <<
      u:=gensym();
      magiclist:=u.magiclist;
      putv(ans,i,!*kk2q u) >>;
    if !*tra then printc "If in doubt consult an expert">>;
  % now to do the back-substitution.
  for i:=n1 step -1 until 0 do begin
    row:=getv(m,i);
    if null row
      then return;
    u:=getv(rightside,i);
    for j:=iadd1 i:n2 do
      u:=!*addsq(u,!*multsq(getv(row,j),negsq getv(ans,j)));
    putv(ans,i,!*multsq(u,sqrt2top !*invsq getv(row,i)))
    end;
  if swapflg
    then vecsort(swaps,list ans);
  return ans;
failed:
  if !*tra then printc "Unable to force correct zeroes";
  return 'failed
  end;
 
 
 
symbolic procedure desparse(matrx,rightside);
begin
  scalar vec,changed,n,m,zero,failed;
  zero := nil ./ 1;
  n:=upbv matrx;
  m:=upbv getv(matrx,0);
  vec:=mkvect m;
  % for i:=0:m do putv(vec,i,zero);   %%% initialize - ach
  changed:=t;
  while changed and not failed do begin
    changed:=nil;
    for i:=0:n do
      if changed or failed
        then i:=n   % and hence quit the loop.
        else begin
          scalar nzcount,row,pivot;
          row:=getv(matrx,i);
          if null row
            then return;
          nzcount:=0;
          for j:=0:m do
            if numr getv(row,j)
              then <<
                nzcount:=iadd1 nzcount;
                pivot:=j >>;
          if nzcount = 0
            then if null numr getv(rightside,i)
              then return putv(matrx,i,nil)
              else return (failed:='failed);
          if nzcount > 1
            then return nil;
          nzcount:=getv(rightside,i);
          if null numr nzcount
            then <<
              putv(vec,pivot,zero);
       go to was!-zero >>;
   nzcount:=!*multsq(nzcount,!*invsq getv(row,pivot));
          putv(vec,pivot,nzcount);
          nzcount:=negsq nzcount;
          for i:=0:n do
            if (row:=getv(matrx,i))
              then if numr (row:=getv(row,pivot))
  then putv(rightside,i,!*addsq(getv(rightside,i),
      !*multsq(row,nzcount)));
was!-zero:
          for i:=0:n do
            if (row:=getv(matrx,i))
              then putv(row,pivot,zero);
          changed:=t;
          putv(matrx,i,nil);
          swap(matrx,i,n);
          swap(rightside,i,n);
          end;
    end;
  if failed
    then return 'failed;
  changed:=t;
  for i:=0:n do
    if getv(matrx,i)
      then changed:=nil;
  if changed
    then matrx:=nil;
    % We have completely solved the equations by these machinations.
  return matrx.(rightside.vec)
  end;
 
 
symbolic procedure astore(a,i,j,val);
   putv(getv(a,i),j,val);
 
endmodule;


module findmagc;

% Author: James H. Davenport.

fluid '(magiclist);

global '(!*tra);

symbolic procedure findmagic l;
begin
  scalar p,n,pvec,m,intvec,mcount,temp;
  % L is a list of things which must be made non-zero by means of
%   a suitable choice of values for the variables in MAGICLIST;
  l:=for each u in l collect
     << mapc(magiclist,function (lambda v;
                                 if involvesf(denr u,v)
                                   then interr "Hard findmagic"));
        numr u >>;
  if !*tra then <<
    printc "We must make the following non-zero:";
    mapc(l,function printsf);
    princ "by suitable choice of ";
    printc magiclist >>;
  % Strategy is random choice in a space which has only finitely
%   many singular points;
  p:=0;
  n:=isub1 length magiclist;
  pvec:=mkvect n;
  putv(pvec,0,2);
  for i:=1:n do
    putv(pvec,i,nextprime getv(pvec,isub1 i));
  % Tactics are based on Godel (is this a mistake ??) and let P run
%   through numbers and take the prime factorization of them;
  intvec:=mkvect n;
loop:
  p:=iadd1 p;
  if !*tra then <<
    princ "We try the number ";
    printc p >>;
  m:=p;
  for i:=0:n do <<
    mcount:=0;
    while zerop cdr (temp:=divide(m,getv(pvec,i)) ) do <<
      mcount:=iadd1 mcount;
      m:=car temp >>;
    putv(intvec,i,mcount) >>;
  if m neq 1
    then go to loop;
  if !*tra then <<
    printc "which corresponds to ";
    superprint intvec >>;
  m:=nil;
  temp:=magiclist;
  for i:=0:n do <<
    m:=((car temp).getv(intvec,i)).m;
    temp:=cdr temp >>;
  % M is the list of substitutions corresponding to this value of P;
  temp:=l;
loop2:
  if null numr algint!-subf(car temp,m)
    then go to loop;
  temp:=cdr temp;
  if temp
    then go to loop2;
  if !*tra then <<
    printc "which corresponds to the values:";
    superprint m >>;
  return m
  end;

endmodule;


module findres;

% Author: James H. Davenport.

fluid '(!*gcd
        basic!-listofallsqrts
        basic!-listofnewsqrts
        intvar
        listofallsqrts
        listofnewsqrts
        nestedsqrts
        sqrt!-intvar
        taylorvariable);

global '(!*tra !*trmin);

exports find!-residue,findpoles;
imports sqrt2top,jfactor,prepsq,printplace,simpdf,involvesf,simp;
imports stt,interr,mksp,negf,multf,addf,let2,substitutesq,subs2q,quotf;
imports printsq,clear,taylorform,taylorevaluate,involvesf,!*multsq;
imports sqrtsave,sqrtsinsq,sqrtsign;

symbolic procedure find!-residue(simpdl,x,place);
  % evaluates residue of simpdl*dx at place given by x=place(y).
begin
  scalar deriv,nsd,poss,slist;
  listofallsqrts:=basic!-listofallsqrts;
  listofnewsqrts:=basic!-listofnewsqrts;
  deriv:=simpdf(list(place,x));
  if involvesf(numr deriv,intvar)
    then return residues!-at!-new!-point(simpdl,x,place);
  if eqcar(place,'quotient) and (cadr place iequal 1)
    then goto place!-correct;
  place:=simp list('difference,intvar,place);
  if involvesq(place,intvar)
    then interr "Place wrongly formatted";
  place:=list('plus,intvar,prepsq place);
place!-correct:
  if car place eq 'plus and caddr place = 0
    then place:=list(x.x)
    else place:=list(x.place);
  % the substitution required.
  nsd:=substitutesq(simpdl,place);
  deriv:=!*multsq(nsd,deriv);
  % differential is deriv * dy, where x=place(y).
  if !*tra then <<
    printc "Differential after first substitution is ";
    printsq deriv >>;
  while involvesq(deriv,sqrt!-intvar)
    do <<
      sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts,place);
      nsd:=list(list(x,'expt,x,2));
      deriv:=!*multsq(substitutesq(deriv,nsd),!*kk2q x);
      % derivative of x**2 is 2x, but there's a jacobian of 2 to
      % consider.
      place:=nconc(place,nsd) >>;
  % require coeff x**-1 in deriv.
  nestedsqrts:=nil;
  slist:=sqrtsinsq(deriv,x);
  if !*tra and nestedsqrts
    then printc "We have nested square roots";
  slist:=sqrtsign(slist,intvar);
  % The reversewoc is to ensure that the simpler sqrts are at
  % the front of the list.
  % Slist is a list of all combinations of signs of sqrts.
  taylorvariable:=x;
  for each branch in slist do <<
    nsd:=taylorevaluate(taylorform substitutesq(deriv,branch),-1);
    if numr nsd
      then poss:=(append(place,branch).nsd).poss >>;
  poss:=reversewoc poss;
  if null poss
    then go to finished;
  % poss is a list of all possible residues at this place.
  if !*tra
    then <<
      princ "Residues at ";
      printplace place;
      printc " are ";
      mapc(poss, function (lambda u; <<
                       printplace car u;
                       printsq cdr u >>)) >>;
finished:
  sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts,place);
  return poss
  end;


symbolic procedure residues!-at!-new!-point(func,x,place);
begin
  scalar place2,tempvar,topterm,a,b,xx;
  if !*tra then <<
    printc "Find residues at all roots of";
    superprint place >>;
  place2:=numr simp place;
  topterm:=stt(place2,x);
  if car topterm = 0
    then interr "Why are we here?";
  tempvar:=gensym();
  place2:=addf(place2,
               multf(!*p2f mksp(x,car topterm),negf cdr topterm));
  % The remainder of PLACE2.
  let2(list('expt,tempvar,car topterm),
       subst(tempvar,x,prepsq(place2 ./ cdr topterm)),
       nil,t);
  place2:=list list(x,'plus,x,tempvar);
  !*gcd:=nil;
    % No unnecessary work: only factors of X worry us.
  func:=subs2q substitutesq(func,place2);
  !*gcd:=t;
  xx:=!*k2f x;
  while (a:=quotf(numr func,xx)) and (b:=quotf(denr func,xx))
    do func:=a ./ b;
  if !*tra then <<
    printc "which gives rise to ";
    printsq func >>;
  if null a
    then b:=quotf(denr func,xx);
    % because B goes back to the last time round that WHILE loop.
  if b then go to hard;
  if !*tra then printc "There were no residues";
  clear tempvar;
  return nil;
  % *** thesis remark ***
%   This test for having an X in the denominator only works
%   because we are at a new place, and hence (remark of Trager)
%   if we have a residue at one place over this point, we must have one
%   at them all, since the places are indistinguishable;
hard:
  taylorvariable:=x;
  func:=taylorevaluate(taylorform func,-1);
  printsq func;
  interr "so far"
  end;


symbolic procedure findpoles(simpdl,x);
begin
  scalar simpdl2,poles;
  % finds possible poles of simpdl * dx.
  simpdl2:=sqrt2top simpdl;
  poles:=jfactor(denr simpdl2,x);
  poles:=mapcar(poles,function prepsq);
  % what about the place at infinity.
  poles:=list('quotient,1,x).poles;
  if !*tra or !*trmin
    then <<
      printc "Places at which poles could occur ";
      for each u in poles do
        printplace list(intvar.u) >>;
  return poles
  end;

endmodule;


module finitise;

% Author: James H. Davenport.

fluid '(intvar);

global '(!*tra);

exports finitise;
imports newplace,getsqrtsfromplaces,interr,completeplaces2,sqrtsign;
imports mkilist,extenplace;


symbolic procedure finitise(places,mults);
begin
  scalar placesmisc,multsmisc,m,n,sqrts;
  scalar places0,mults0,placesinf,multsinf;
  newplace list (intvar.intvar);
    % fix the disaster with 1/sqrt(x**2-1)
    % (but with no other 1/sqrt(x**2-k).
  sqrts:=getsqrtsfromplaces places;
  placesmisc:=places;
  multsmisc:=mults;
  n:=0;
  while placesmisc do <<
    if eqcar(rfirstsubs car placesmisc,'quotient)
        and (n > car multsmisc)
      then <<
        n:=car multsmisc;
        m:=multiplicity!-factor car placesmisc >>;
    placesmisc:=cdr placesmisc;
    multsmisc:=cdr multsmisc >>;
  if n = 0
    then interr "Why did we call finitise ??";
  % N must be corrected to allow for our representation of
  % multiplicities at places where X is not the local parameter.
  n:=divide(n,m);
  if not zerop cdr n and !*tra
    then printc
     "Cannot get the poles moved precisely because of ramification";
   if (cdr n) < 0
     then n:=(-1) + car n
     else n:=car n;
        % The above 3 lines (as a replacement for the line below)
        % inserted JHD 06 SEPT 80.
%  n:=car n;
% ***** not true jhd 06 sept 80 *****;
    % This works because, e.g., DIVIDE(-1,2) is -1 remainder 1.
    % Note that N is actually negative.
  % We now wish to divide by X**N, thus increasing
  % the degrees of all infinite places by N and
  % decreasing the degrees of all places lying over 0.
  while places do <<
    if atom rfirstsubs car places
      then <<
        places0:=(car places).places0;
        mults0:=(car mults).mults0 >>
      else if car rfirstsubs car places eq 'quotient
        then <<
          placesinf:=(car places).placesinf;
          multsinf:=(car mults).multsinf >>
        else <<
          placesmisc:=(car places).placesmisc;
          multsmisc:=(car mults).multsmisc >>;
    places:=cdr places;
    mults:=cdr mults >>;
  if places0
    then <<
      places0:=completeplaces2(places0,mults0,sqrts);
      mults0:=cdr places0;
      places0:=car places0;
      m:=multiplicity!-factor car places0;
      mults0:=for each u in mults0 collect u+n*m >>
    else <<
      places0:=for each u in sqrtsign(sqrts,intvar)
                 collect (intvar.intvar).u;
      mults0:=mkilist(places0,n * (multiplicity!-factor car places0))>>;
  placesinf:=completeplaces2(placesinf,
                             multsinf,
                             for each u in extenplace car placesinf
                               collect lsubs u);
  multsinf:=cdr placesinf;
  placesinf:=car placesinf;
  while placesinf do <<
    m:=multiplicity!-factor car placesinf;
    if (car multsinf) neq n*m
      then <<
        placesmisc:=(car placesinf).placesmisc;
        multsmisc:=(car multsinf -n*m).multsmisc >>;
      % This test ensures that we do not add places
      % with a multiplicity of zero.
    placesinf:=cdr placesinf;
    multsinf:=cdr multsinf >>;
  return list(nconc(places0,placesmisc),
              nconc(mults0,multsmisc),
              -n)
  end;


symbolic procedure multiplicity!-factor place;
begin
  scalar n;
  n:=1;
  for each u in place do
    if (lsubs u eq intvar) and
        eqcar(rsubs u,'expt)
      then n:=n*(caddr rsubs u);
  return n
  end;

endmodule;


module fixes;

% Author: James H. Davenport.

fluid '(!*nosubs asymplis!* dmode!*);

global '(ncmp!*);

% The standard version of SUBF messes with the order of variables before
% calling SUBF1, something we can't afford, so we define a new version.

symbolic procedure algint!-subf(a,b); algint!-subf1(a,b);

symbolic procedure algint!-subsq(u,v); 
   quotsq(algint!-subf(numr u,v),algint!-subf(denr u,v));

symbolic procedure algint!-subf1(u,l);
   %U is a standard form,
   %L an association list of substitutions of the form
   %(<kernel> . <substitution>).
   %Value is the standard quotient for substituted expression.
   %Algorithm used is essentially the straight method.
   %Procedure depends on explicit data structure for standard form;
   if domainp u
     then if atom u then if null dmode!* then u ./ 1 else simpatom u
          else if dmode!* eq car u then !*d2q u
          else simp prepf u
    else begin integer n; scalar kern,m,w,x,xexp,y,y1,z;
        z := nil ./ 1;
    a0: kern := mvar u;
        if m := assoc(kern,asymplis!*) then m := cdr m;
    a:  if null u or (n := degr(u,kern))=0 then go to b
         else if null m or n<m then y := lt u . y;
        u := red u;
        go to a;
    b:  if not atom kern and not atom car kern then kern := prepf kern;
        if null l then xexp := if kern eq 'k!* then 1 else kern
         else if (xexp := algint!-subsublis(l,kern)) = kern
                   and not assoc(kern,asymplis!*)
          then go to f;
    c:  w := 1 ./ 1;
        n := 0;
        if y and cdaar y<0 then go to h;
        if (x := getrtype xexp) then typerr(x,"substituted expression");
        x := simp xexp;
        % SIMP!* here causes problem with HE package;
        x := reorder numr x ./ reorder denr x;
        % needed in case substitution variable is in XEXP;
        if null l and kernp x and mvar numr x eq kern then go to f
         else if null numr x then go to e;   %Substitution of 0;
        for each j in y do
         <<m := cdar j;
           w := multsq(exptsq(x,m-n),w);
           n := m;
           z := addsq(multsq(w,algint!-subf1(cdr j,l)),z)>>;
    e:  y := nil;
        if null u then return z
         else if domainp u then return addsq(algint!-subf1(u,l),z);
        go to a0;
    f:  sub2chk kern;
        for each j in y do 
           z := addsq(multpq(car j,algint!-subf1(cdr j,l)),z);
        go to e;
    h:  %Substitution for negative powers;
        x := simprecip list xexp;
    j:  y1 := car y . y1;
        y := cdr y;
        if y and cdaar y<0 then go to j;
    k:  m := -cdaar y1;
        w := multsq(exptsq(x,m-n),w);
        n := m;
        z := addsq(multsq(w,algint!-subf1(cdar y1,l)),z);
        y1 := cdr y1;
        if y1 then go to k else if y then go to c else go to e
     end;

symbolic procedure algint!-subsublis(u,v);
   begin scalar x;
      return if x := assoc(v,u) then cdr x
              else if atom v then v
              else if car v eq '!*sq then
                      list('!*sq,algint!-subsq(cadr v,u),caddr v)
%    Previous two lines added by JHD 7 July 1982.
%    without them, CDRs in SQ expressions buried inside;
%    !*SQ forms are lost;
              else if flagp!*!*(car v,'subfn) 
               then algint!-subsubf(u,v)
              else for each j in v collect algint!-subsublis(u,j)
   end;

symbolic procedure algint!-subsubf(l,expn);
   %Sets up a formal SUB expression when necessary;
   begin scalar x,y;
      for each j in cddr expn do
         if (x := assoc(j,l)) then <<y := x . y; l := delete(x,l)>>;
      expn := sublis(l,car expn)
                 . for each j in cdr expn 
                       collect algint!-subsublis(l,j);
        %to ensure only opr and individual args are transformed;
      if null y then return expn;
      expn := aconc!*(for each j in reversip!* y
                     collect list('equal,car j,aeval cdr j),expn);
      return mk!*sq if l then algint!-simpsub expn
                     else !*p2q mksp('sub . expn,1)
   end;

symbolic procedure algint!-simpsub u;
   begin scalar !*nosubs,w,x,z;
    a:  if null cdr u
          then <<if getrtype car u or eqcar(car u,'equal) 
                   then typerr(car u,"scalar");
                 u := simp!* car u;
                 z := reversip!* z;   % to put replacements in same
                                      % order as input.
                 return quotsq(algint!-subf(numr u,z),
                               algint!-subf(denr u,z))>>;
        !*nosubs := t;  % We don't want left side of eqns to change.
        w := reval car u;
        !*nosubs := nil;
        if getrtype w eq 'list
          then <<u := append(cdr w,cdr u); go to a>>
         else if not eqexpr w then errpri2(car u,t); 
        x := cadr w;
        if null getrtype x then x := !*a2k x;
        z := (x . caddr w) . z;
        u := cdr u;
        go to a;
   end;

endmodule;


module fracdi;

% Author: James H. Davenport.

fluid '(basic!-listofallsqrts basic!-listofnewsqrts expsub intvar
        sqrt!-intvar);

global '(coates!-fdi);

exports fdi!-print,fdi!-revertsq,fdi!-upgrade,
   fractional!-degree!-at!-infinity;

% internal!-fluid '(expsub);

symbolic procedure fdi!-print();
<< princ "We substitute";
   princ intvar;
   princ "**";
   princ coates!-fdi;
   princ " for ";
   princ intvar;
   printc " in order to avoid fractional degrees at infinity" >>;


symbolic procedure fdi!-revertsq u;
if coates!-fdi iequal 1
  then u
  else (fdi!-revert numr u) ./ (fdi!-revert denr u);


symbolic procedure fdi!-revert u;
if not involvesf(u,intvar)
  then u
  else addf(fdi!-revert red u,
            !*multf(fdi!-revertpow lpow u,
                    fdi!-revert lc u));


symbolic procedure fdi!-revertpow pow;
if not dependsp(car pow,intvar)
  then (pow .* 1) .+ nil
  else if car pow eq intvar
    then begin
      scalar v;
      v:=divide(cdr pow,coates!-fdi);
      if zerop cdr pow
        then return (mksp(intvar,car pow) .* 1) .+ nil
        else interr "Unable to revert fdi";
      end
    else if eq(car pow,'sqrt)
      then simpsqrt2 fdi!-revert !*q2f simp argof car pow
      else interr "Unrecognised term to revert";


symbolic procedure fdi!-upgrade place;
begin
  scalar ans,u,expsub,n;
  n:=coates!-fdi;
  for each u in place do
    if eqcar(u:=rsubs u,'expt)
      then n:=n / caddr u;
      % if already upgraded, we must take account of this.
  if n = 1
    then return place;
  expsub:=list(intvar,'expt,intvar,n);
  ans:=nconc(basicplace place,list expsub);
  expsub:=list expsub; % this prevents later nconc from causing trouble.
  u:=extenplace place;
  while u do begin
    scalar v,w,rfu;
    v:=fdi!-upgr2 lfirstsubs u;
    if v iequal 1
      then return (u:=cdr u);
    if eqcar(rfu:=rfirstsubs u,'minus)
      then w:=argof rfu
      else if eqcar(rfu,'sqrt)
        then w:=rfu
        else interr "Unknown place format";
    w:=fdi!-upgr2 w;
    if w iequal 1
      then interr "Place collapses under rewriting";
    if eqcar(rfu,'minus)
      then ans:=nconc(ans,list list(v,'minus,w))
      else ans:=nconc(ans,list(v.w));
    u:=cdr u;
    return
    end;
  sqrtsave(basic!-listofallsqrts,
           basic!-listofnewsqrts,
           basicplace ans);
  return ans
  end;


symbolic procedure fdi!-upgr2 u;
begin
  scalar v,mv;
  v:=substitutesq(simp u,expsub);
  if denr v neq 1
    then goto error;
  v:=numr v;
loop:
  if atom v
    then return v;
  if red v
    then go to error;
  mv:=mvar v;
  if (not dependsp(mv,intvar)) or (mv eq intvar)
    then <<
      v:=lc v;
      goto loop >>;
  if eqcar(mv,'sqrt)
    then if sqrtsinsf(lc v,nil,intvar)
      then go to error
      else return mv
    else go to error;
error:
  printc "*** Format error ***";
  princ "unable to go x:=x**";
  printc coates!-fdi;
  superprint u;
  rederr "Failure to make integral at infinity"
  end;


symbolic procedure fractional!-degree!-at!-infinity sqrts;
if sqrts
  then lcmn(fdi2 car sqrts,fractional!-degree!-at!-infinity cdr sqrts)
  else 1;


symbolic procedure fdi2 u;
   % Returns the denominator of the degree of x at infinity
   % in the sqrt expression u.
begin
  scalar n;
  u:=substitutesq(simp u,list list(intvar,'quotient,1,intvar));
  n:=0;
  while involvesq(u,sqrt!-intvar) do <<
    n:=iadd1 n;
    u:=substitutesq(u,list list(intvar,'expt,intvar,2)) >>;
  return (2**n)
  end;


symbolic procedure lcmn(i,j);
  i*j/gcdn(i,j);

% unfluid '(expsub);

endmodule;


module genus;

% Author: James H. Davenport.

fluid '(!*galois
        gaussiani
        intvar
        listofallsqrts
        listofnewsqrts
        nestedsqrts
        previousbasis
        sqrt!-intvar
        sqrt!-places!-alist
        sqrtflag
        sqrts!-in!-integrand
        taylorasslist
        taylorvariable);

global '(!*tra !*trmin);

symbolic procedure simpgenus u;
begin
  scalar intvar,sqrt!-intvar,taylorvariable,taylorasslist;
  scalar listofnewsqrts,listofallsqrts,sqrt!-places!-alist;
  scalar list!-of!-all!-sqrts,list!-of!-new!-sqrts;
  scalar sqrtflag,sqrts!-in!-integrand,tt,u,simpfn;
  tt:=readclock();
  sqrtflag:=t;
  taylorvariable:=intvar:=car u;
  simpfn:=get('sqrt,'simpfn);
  put('sqrt,'simpfn,'proper!-simpsqrt);
  sqrt!-intvar:=mvar !*q2f simpsqrti intvar;
  listofnewsqrts:= list mvar gaussiani; % Initialise the SQRT world.
  listofallsqrts:= list (argof mvar gaussiani . gaussiani);
  u:=for each v in cdr u
            collect simp!* v;
  sqrts!-in!-integrand:=sqrtsinsql(u,intvar);
  u:=!*n2sq length differentials!-1 sqrts!-in!-integrand;
  put('sqrt,'simpfn,simpfn);
  printc list('time,'taken,readclock()-tt,'milliseconds);
  return u
  end;
put('genus,'simpfn,'simpgenus);

symbolic procedure differentials!-1 sqrtl;
begin
  scalar asqrtl,faclist,places,v,nestedsqrts,basis,
         u,n,hard!-ones,sqrts!-in!-problem;
    % HARD!-ONES  A list of all the factors of our equations which do
    % not factor, and therefore such that we can divide the whole of
    % our INTBASIS by their product in order to get the true INTBASIS,
    % since these ones can cause no complications.
  asqrtl:=for each u in sqrtl
            collect !*q2f simp argof u;
  if !*tra or !*trmin then <<
    printc
      "Find the differentials of the first kind on curve defined by:";
    mapc(asqrtl,function printsf) >>;
  for each s in asqrtl do <<
    faclist:=for each u in jfactor(s,intvar)
               collect numr u;
    if !*tra then <<
      princ intvar;
      printc " is not a local variable at the roots of:";
      mapc(faclist,function printsf) >>;
    for each uu in faclist do <<
      v:=stt(uu,intvar);
      if 1 neq car v
        then hard!-ones:=uu.hard!-ones
        else <<
          u:=addf(uu,(mksp(intvar,1) .* (negf cdr v)) .+ nil) ./ cdr v;
          % U is now the value at which this SQRT has a zero.
          u:=list(list(intvar,'difference,intvar,prepsq u),
                  list(intvar,'expt,intvar,2));
          for each w in sqrtsign(for each w in union(delete(s,asqrtl),
                                                     delete(uu,faclist))
         conc sqrtsinsq(simpsqrtsq
      multsq(substitutesq(w ./ 1,u),
      1 ./ !*p2f mksp(intvar,2)),
                                      intvar),
                                 intvar)
            do places:=append(u,w).places >> >> >>;
  sqrts!-in!-problem:=nconc(for each u in hard!-ones
                              collect list(intvar.intvar,
                                    (lambda u;u.u) list('sqrt,prepf u)),
                            places);
  basis:=makeinitialbasis sqrts!-in!-problem;
                  % Bodge in any extra SQRTS that we will require later.
%  u:=1 ./ mapply(function multf,
%                for each u in sqrtl collect !*kk2f u);
%  basis:=for each v in basis collect multsq(u,v);
  basis:=integralbasis(mkvec basis,places,mkilist(places,-1),intvar);
  if not !*galois
    then basis:=combine!-sqrts(basis,
                               getsqrtsfromplaces sqrts!-in!-problem);
  if hard!-ones
    then <<
      v:=upbv basis;
      u:=1;
      for each v in hard!-ones do
        u:=multf(u,!*kk2f list('sqrt,prepf v));
      hard!-ones:=1 ./ u;
      for i:=0:v do
        putv(basis,i,multsq(getv(basis,i),hard!-ones)) >>;
  if not !*galois
    then basis:=modify!-sqrts(basis,sqrtl);
  v:=fractional!-degree!-at!-infinity sqrtl;
  if v iequal 1
    then n:=2
    else n:=2*v-1;
    % N  is the degree of the zero we need at INFINITY.
  basis:=normalbasis(basis,intvar,n);
  previousbasis:=nil;
    % it might have been set before, and we have changed its meaning.
  if !*tra or !*trmin then <<
    printc "Differentials are:";
    mapc(basis,function printsq) >>;
  return basis;
  end;

endmodule;


module intbasis;

% Author: James H. Davenport.

fluid '(excoatespoles intvar previousbasis taylorasslist
        taylorvariable);

global '(!*tra !*trmin);

exports completeplaces,completeplaces2,integralbasis;


symbolic procedure deleteplace(a,b);
if null b
  then nil
  else if equalplace(a,car b)
    then cdr b
    else (car b).deleteplace(a,cdr b);


symbolic procedure completeplaces(places,mults);
begin
  scalar current,cp,cm,op,om,ansp,ansm;
  if null places then return nil;       %%% ACH
loop:
  current:=basicplace car places;
  while places do <<
    if current = (basicplace car places)
      then <<
        cp:=(car places).cp;
        cm:=(car mults ).cm >>
      else <<
        op:=(car places).op;
        om:=(car mults ).om >>;
    places:=cdr places;
    mults:=cdr mults >>;
  cp:=completeplaces2(cp,cm,sqrtsinplaces cp);
  ansp:=append(car cp,ansp);
  ansm:=append(cdr cp,ansm);
  places:=op;
  mults:=om;
  cp:=op:=cm:=om:=nil;
  if places
    then go to loop
    else return ansp.ansm
  end;


symbolic procedure completeplaces2(places,mults,sqrts);
  % Adds extra places with multiplicities of 0 as necessary.
begin scalar b,p;
  sqrts:=sqrtsign(sqrts,intvar);
  b:=basicplace car places;
  p:=places;
  while p do <<
    if not(b = (basicplace car p))
      then interr "Multiple places not supported";
    sqrts:=deleteplace(extenplace car p,sqrts);
    p:=cdr p >>;
  mults:=nconc(nlist(0,length sqrts),mults);
  places:=nconc(mappend(sqrts,b),places);
  return places.mults
  end;


symbolic procedure intbasisreduction(zbasis,places,mults);
begin
  scalar i,m,n,v,w,substn,basis;
  substn:=list(intvar.intvar);
    % The X=X substitution.
  n:=upbv zbasis;
  basis:=copyvec(zbasis,n);
  taylorvariable:=intvar;
  v:=sqrtsinplaces places;
  for i:=0:n do
    w:=union(w,sqrtsinsq(getv(basis,i),intvar));
  m:=intersect(v,w);
  v:=purge(m,v);
  w:=purge(m,w);
  for each u in v do <<
    if !*tra or !*trmin then <<
      printc u;
      printc "does not occur in the functions";
      mapvec(basis,function printsq) >>;
    m:=!*q2f simp argof u;
    i:=w;
    while i and not quotf(m,!*q2f simp argof car i)
      do i:=cdr i;
    if null i
      then interr
         "Unable to find equivalent representation of branches";
    i:=car i;
    w:=delete(i,w);
    places:=subst(i,u,places);
    if !*tra or !*trmin then <<
      printc "replaced by";
      printc i >> >>;
  if (length places) neq (iadd1 n) then <<
   if !*tra
      then printc "Too many functions";
    basis := shorten!-basis basis;
    n:=upbv basis >>;
  m:=mkvect n;
  for i:=0:n do
    putv(m,i,cl6roweval(basis.i,places,mults,substn));
reductionloop:
  if !*tra then <<
    printc "Matrix before a reduction step:";
    mapvec(m,function printc) >>;
  v:=firstlinearrelation(m,iadd1 n);
  if null v
    then return replicatebasis(basis,(iadd1 upbv zbasis)/(n+1));
  i:=n;
  while null numr getv(v,i) do
    i:=isub1 i;
  w:=nil ./ 1;
  for j:=0:i do
    w:=!*addsq(w,!*multsq(getv(basis,j),getv(v,j)));
  w:=removecmsq multsq(w,1 ./ !*p2f mksp(intvar,1));
  if null numr w
    then <<
      mapvec(basis,function printsq);
      printc iadd1 i;
      interr "Basis collapses" >>;
  if !*tra then <<
    princ "Element ";
    princ iadd1 i;
    printc " of the basis replaced by ";
    if !*tra then
      printsq w >>;
  putv(basis,i,w);
  putv(m,i,cl6roweval(basis.i,places,mults,substn));
  goto reductionloop
  end;


symbolic procedure integralbasis(basis,places,mults,x);
begin
  scalar z,save,points,p,m,princilap!-part,mm;
  if null places
    then return basis;
  mults:=mapcar(mults,function (lambda u;min(u,0)));
  % this makes sure that we impose constraints only on
  % poles, not on zeroes.
  points:=removeduplicates mapcar(places,function basicplace);
  if points = list(x.x)
    then basis:=intbasisreduction(basis,places,mults)
    else if cdr points
      then go complex
      else <<
        substitutevec(basis,car points);
        if !*tra then <<
          printc "Integral basis reduction at";
          printc car points >>;
        basis:=intbasisreduction(basis,
                                 mapcar(places,function extenplace),
                                 mults);
        substitutevec(basis,antisubs(car points,x)) >>;
join:
  save:=taylorasslist;
  % we will not need te taylorevaluates at gensym.
  z:=gensym();
  places:=mapcons(places,x.list('difference,x,z));
  z:=list(x . z);
%  basis:=intbasisreduction(basis,
%                          places,
%                          nlist(0,length places),
%                          x,z);
  taylorasslist:=save;
  % ***time-hack-2***;
  if not excoatespoles
    then previousbasis:=copyvec(basis,upbv basis);
    % Save only if in COATES/FINDFUNCTION, not if in EXCOATES.
  return basis;
complex:
  while points do <<
    p:=places;
    m:=mults;
    princilap!-part:=mm:=nil;
    while p do <<
    if (car points) = (basicplace car p)
      then <<
        princilap!-part:=(extenplace car p).princilap!-part;
        mm:=(car m).mm >>;
      p:=cdr p;
      m:=cdr m >>;
    substitutevec(basis,car points);
    if !*tra then <<
      printc "Integral basis reduction at";
      printc car points >>;
    basis:=intbasisreduction(basis,princilap!-part,mm);
    substitutevec(basis,antisubs(car points,x));
    points:=cdr points >>;
  go to join
  end;


symbolic procedure cl6roweval(basisloc,places,mults,x!-alpha);
% Evaluates a row of the matrix in coates lemma 6.
begin
  scalar i,v,w,save,basiselement,taysave,mmults,flg;
  i:=isub1 length places;
  v:=mkvect i;
  taysave:=mkvect i;
  i:=0;
  basiselement:=getv(car basisloc,cdr basisloc);
  mmults:=mults;
  while places do <<
    w:=substitutesq(basiselement,car places);
    w:=taylorform substitutesq(w,x!-alpha);
      % The separation of these 2 is essential since the x->x-a
      % must occur after the places are chosen.
    save:=taylorasslist;
    if not flg
      then putv(taysave,i,w);
    w:=taylorevaluate(w,car mmults);
    tayshorten save;
    putv(v,i,w);
    i:=iadd1 i;
    flg:=flg or numr w;
    mmults:=cdr mmults;
    places:=cdr places >>;
  if flg
    then return v;
    % There was a non-zero element in this row.
  save:=0;
loop:
  save:=iadd1 save;
  mmults:=mults;
  i:=0;
  while mmults do <<
    w:=taylorevaluate(getv(taysave,i),save + car mmults);
    flg:=flg or numr w;
    mmults:=cdr mmults;
    putv(v,i,w);
    i:=iadd1 i >>;
  if not flg
    then go to loop;
    % Another zero row.
  putv(car basisloc,cdr basisloc,multsq(basiselement,
                                        1 ./ !*p2f mksp(intvar,save)));
  return v
  end;


symbolic procedure replicatebasis(basis,n);
if n = 1
  then basis
  else if n = 2
    then begin
      scalar b,sqintvar,len;
      len:=upbv basis;
      sqintvar:=!*kk2q intvar;
      b:=mkvect(2*len+1);
      for i:=0:len do <<
        putv(b,i,getv(basis,i));
        putv(b,i+len+1,multsq(sqintvar,getv(basis,i))) >>;
      return b
      end
    else interr "Unexpected replication request";


symbolic procedure shorten!-basis v;
begin
  scalar u,n,sfintvar;
  sfintvar:=!*kk2f intvar;
  n:=upbv v;
  for i:=0:n do begin
    scalar uu;
    uu:=getv(v,i);
    if not quotf(numr uu,sfintvar)
      then u:=uu.u
    end;
  return mkvec u
  end;


endmodule;


module jhddiff;

% Author: James H. Davenport.

fluid '(dw);

% Differentiation routines for algebraic expressions;
symbolic procedure !*diffsq(u,v);
   %U is a standard quotient, V a kernel.
   %Value is the standard quotient derivative of U wrt V.
   %Algorithm: df(x/y,z)= (x'-(x/y)*y')/y;
   !*multsq(!*addsq(!*difff(numr u,v),
                    negsq !*multsq(u,!*difff(denr u,v))),
          1 ./ denr u);

symbolic procedure !*difff(u,v);
   %U is a standard form, V a kernel.
   %Value is the standard quotient derivative of U wrt V;
   if domainp u then nil ./ 1
    else !*addsq(!*addsq(multpq(lpow u,!*difff(lc u,v)),
                        !*multsq(lc u ./ 1,!*diffp(lpow u,v))),
               !*difff(red u,v));

symbolic procedure !*diffp(u,v);
%  Special treatment of SQRT's (JHD is not sure why,
%  but it seems to be necessary);
if atom (car u) then diffp(u,v)
  else if not (caar u) eq 'sqrt then diffp(u,v)
    else begin
           scalar w,dw;
           w:=simp argof car u;
           dw:= !*diffsq(w,v);
           if null numr dw then return dw;
           return !*multsq(!*multsq(dw,invsq w),
                           !*multf(cdr u,mksp(car u,1) .* 1 .+ nil)./ 2)
           end;

endmodule;


module jhdriver;

% Author: James H. Davenport.

fluid '(!*backtrace
        basic!-listofallsqrts
        basic!-listofnewsqrts
        expression
        gaussiani
        intvar
        listofallsqrts
        listofnewsqrts
        previousbasis
        sqrt!-intvar
        sqrtflag
        sqrts!-in!-integrand
        sqrts!-mod!-prime
        taylorasslist
        varlist
        zlist);

global '(!*algint !*coates !*noacn !*tra !*trmin btrlevel tryharder);

switch algint,coates,noacn,tra,trmin;

exports algebraiccase,doalggeom,coates!-multiple;

!*algint := t;   % Assume algebraic integration wanted if this module
                 % is loaded.

symbolic procedure operateon(reslist,x);
begin
  scalar u,v,answer,save;
  scalar sqrts!-mod!-prime;
  u:=zmodule(reslist);
  v:=answer:=nil ./ 1;
  while u and not atom v do <<
    v:=findfunction cdar u;
    if not atom v then <<
      if !*tra or !*trmin then <<
        printc "Extension logarithm is ";
        printsq v >>;
      save:=tryharder;
      tryharder:=x;
      v:= !*multsq(simp!* caar u,
                simplogsq v);
      tryharder:=save;
      answer:=addsq(answer,v);
      u:=cdr u >> >>;
  if atom v
    then return v
    else return answer
  end;


symbolic procedure findfunction divisor;
begin
  scalar v,places,mults,ans,dof1k;
  scalar previousbasis;
  % ***time-hack-2 :::
    % A hack for decreasing the amount of work done in COATES.
  divisor:=for each u in divisor collect
             correct!-mults u;
  if !*coates
    then go to nohack;
  v:=precoates(divisor,intvar,nil);
  if not atom v
    then return v;
nohack:
  for each u in divisor do <<
    places:=(car u).places;
    mults :=(cdr u).mults >>;
  v:=coates(places,mults,intvar);
  if not atom v
    then return v;
  dof1k:=differentials!-1 getsqrtsfromplaces places;
  if null dof1k
    then interr "Must be able to integrate over curves of genus 0";
  if not mazurp(places,dof1k)
    then go to general;
  ans:='provably!-impossible;
  for i:=2:12 do
    if (i neq 11) and
       not atom (ans:=coates!-multiple(places,mults,i))
    then i:=12;   % leave the loop - we have an answer.
  return ans;
general:
  v:=findmaninparm places;
  if null v
     then return algebraic!-divisor(divisor,dof1k);
  if not maninp(divisor,v,dof1k)
    then return 'provably!-impossible;
  v:=1;
loop:
  v:=iadd1 v;
  if not atom (ans:=coates!-multiple(places,mults,v))
    then return ans;
  go to loop
  end;


symbolic procedure correct!-mults u;
begin
  scalar multip;
  multip:=cdr u;
  for each v in car u do
    if (lsubs v eq intvar) and
        eqcar(rsubs v,'expt)
      then multip:=multip * (caddr rsubs v);
    return (car u).multip
  end;


symbolic procedure algebraiccase
    (expression,zlist,varlist);
begin
  scalar rischpart,deriv,w,firstterm;
  scalar sqrtflag;
  sqrtflag:=t;
  sqrtsave(listofallsqrts,listofnewsqrts,list(intvar . intvar));
  rischpart:=errorset('(doalggeom expression),
                      if !*tra or !*trmin then t else btrlevel,
                      !*backtrace);
  newplace list (intvar.intvar);
  if atom rischpart
    then <<
      if !*tra then printc "Inner integration failed";
      deriv:=nil ./ 1;
      % assume no answer.
      rischpart:=deriv >>
    else
      if atom car rischpart
        then <<
          if !*tra or !*trmin then
            printc "The 'logarithmic part' is not elementary";
          return simpint1 list ('int,prepsq expression,intvar) >>
      else <<
        rischpart:=car rischpart;
        deriv:=!*diffsq(rischpart,intvar);
        % deriv := squashsqrt deriv;
        % Should no longer be necessary.
        if !*tra or !*trmin then <<
          printc "Inner working yields";
          printsq rischpart;
          printc "with derivative";
          printsq deriv >> >>;
  deriv:=!*addsq(expression,negsq deriv);
  if null numr deriv
    then return rischpart; % no algebraic part.
  if null involvesq(deriv,intvar)
    then return !*addsq(rischpart,
                !*multsq(deriv,((mksp(intvar,1) .* 1) .+ nil) ./ 1));
                % if the difference is merely a constant.
  varlist:=getvariables deriv;
  zlist:=findzvars(varlist,list intvar,intvar,nil);
  varlist:=purge(zlist,varlist);
  firstterm:=simp!* car zlist; % this may crop up.
  w:=sqrt2top !*multsq(deriv,invsq !*diffsq(firstterm,intvar));
  if null involvesq(w,intvar)
    then return !*addsq(rischpart,!*multsq(w,firstterm));
  if !*noacn then interr "Testing only logarithmic code";
  deriv:=transcendentalcase(deriv,intvar,nil,zlist,varlist);
  return !*addsq(deriv,rischpart)
  end;


symbolic procedure doalggeom(differential);
begin
  scalar reslist,place,placelist,
         savetaylorasslist,sqrts!-in!-integrand,
         taylorasslist;
  placelist:=findpoles(differential,intvar);
  reslist:=nil;
  sqrts!-in!-integrand:=sqrtsinsq (differential,intvar);
  while placelist do <<
    place:=car placelist;
    placelist:=cdr placelist;
    savetaylorasslist:=taylorasslist;
    place:=find!-residue(differential,intvar,place);
    if place
      then reslist:=append(place,reslist)
      else taylorasslist:=savetaylorasslist >>;
  if reslist
    then go to serious;
  if !*tra or !*trmin
    then printc "No residues => no logs";
  return nil ./ 1;
serious:
  placelist:=operateon(reslist,intvar);
  if placelist eq 'failed
    then interr "Divisor operations failed";
  return placelist
  end;


symbolic procedure algebraic!-divisor(divisor,dof1k);
if length dof1k = 1
  then lutz!-nagell(divisor)
  else bound!-torsion(divisor,dof1k);


symbolic procedure coates!-multiple(places,mults,v);
begin
  scalar ans;
  if not atom (ans:=coates(places,
                           for each u in mults collect v*u,
                           intvar))
    then <<
      if !*tra or !*trmin then <<
        princ "Divisor has order ";
        printc v >>;
      return !*kk2q list('nthroot,mk!*sq ans,v) >>
    else return ans
  end;


symbolic procedure mazurp(places,dof1k);
   % Checks to ensure we have an elliptic curve over the rationals.
begin
%  scalar sqrt2,sqrt4,v;
%  sqrt2:=0;
%    % Number of SQRTs of things of degree 1 or 2;
%  sqrt4:=0;
%    % " " " 3 or 4;
%  for each u in getsqrtsfromplaces places do <<
%    v:=!*q2f simp u;
%    if sqrtsinsq(v,intvar)
%      then return nil;
%      % Cannot use nested SQRTs;
%    v:=car stt(v,intvar);
%    if v < 3
%      then if sqrt4>0
%        then return nil
%        else if sqrt2>1
%          then return nil
%          else sqrt2:=iadd1 sqrt2
%      else if v < 5
%        then if sqrt2>0 or sqrt4>0
%          then return nil
%          else sqrt4:=1
%        else return nil >>;
  scalar answer;
  if length dof1k neq 1
    then return nil;
    % Genus = # linearly independent differentials of 1st kind;
    % We know know that it is of genus = 1.
  answer:=t;
  while answer and places do
    if sqrtsintree(basicplace car places,nil,nil)
      then answer:= nil
      else places:=cdr places;
  if null answer then return nil;
  if !*tra then
    <<prin2 "*** We can apply Mazur's bound on the torsion of";
      prin2t "elliptic curves over the rationals">>;
  return t
  end;

endmodule;


module linrel;

% Author: James H. Davenport.

symbolic procedure firstlinearrelation(m,n);
% Returns vector giving first linear relation between
% the rows of n*n matrix m.
begin
  scalar mm,u,uu,v,w,x,xx,i,j,isub1n,ans;
  isub1n:=isub1 n;
  mm:=mkvect(isub1n);
  for i:=0 step 1 until isub1n do
    putv(mm,i,copyvec(getv(m,i),isub1n));
  % mm is a copy of m which we can afford to destroy.
  ans:=mkidenm isub1n;
  i:=0;
outerloop:
  u:=getv(mm,i);
  uu:=getv(ans,i);
  j:=0;
pivotsearch:
  if j iequal n
    then goto zerorow;
  v:=getv(u,j);
  if null numr v then << j:=iadd1 j; goto pivotsearch >>;
  % we now use the j-th element of row i to flatten the j-th
  % element of all later rows.
  if i iequal isub1n then return nil;
    %no further rows to flatten, so no relationships.
  v:=!*invsq negsq v;
  for k:=iadd1 i step 1 until isub1n do <<
    xx:=getv(ans,k);
    x:=getv(mm,k);
    w:=!*multsq(v,getv(x,j));
    for l:=0:isub1n do <<
      putv(x,l,addsq(getv(x,l),!*multsq(w,getv(u,l))));
      putv(xx,l,addsq(getv(xx,l),!*multsq(w,getv(uu,l)))) >> >>;
  i:=iadd1 i;
  if i < n then goto outerloop;
  % no zero rows found at all.
  return nil;
zerorow:
  % the i-t row is all zero, i.e. rows 1...i are dependent.
  return getv(ans,i)
  end;

endmodule;


module maninp;

% Author: James H. Davenport.

fluid '(intvar);

symbolic procedure findmaninparm places;
begin
  scalar sqrts,vars,u;
  sqrts:=sqrtsinplaces places;
loop:
  if null sqrts then return nil;
  vars:=getvariables simp argof car sqrts;
innerloop:
  if null vars
    then <<
      sqrts:=cdr sqrts;
      go to loop >>;
  u:=car vars;
  vars:=cdr vars;
  if u eq intvar
    then go to innerloop;
  if atom u
    then return u;
  if car u eq 'sqrt
    then << u:=simp argof u;
            vars:=varsinsf(numr u,varsinsf(denr u,vars));
            go to innerloop >>;
  interr "Unrecognised differentiation candidate"
  end;

endmodule;


module modify;

% Author: James H. Davenport.

fluid '(intvar);

global '(!*tra);

exports modify!-sqrts,combine!-sqrts;

symbolic procedure modify!-sqrts(basis,sqrtl);
begin
  scalar sqrtl!-in!-sf,n,u,v,f;
  n:=upbv basis;
  sqrtl!-in!-sf:=for each u in sqrtl collect
                    !*q2f simp argof u;
  for i:=0:n do begin
    u:=getv(basis,i);
    v:=sqrtsinsq(u,intvar);
    % We have two tasks to perform,
    % the replacing of SQRT(A)*SQRT(B) by SQRT(A*B)
    % where relevant and the replacing of SQRT(A)
    % by SQRT(A*B) or 1 (depending on whether it occurs in
    % the numerator or the denominator).
    v:=purge(sqrtl,v);
    if null v
      then go to nochange;
    u:=sqrt2top u;
    u:=multsq(modify2(numr u,v,sqrtl!-in!-sf) ./ 1,
              1 ./ modify2(denr u,v,sqrtl!-in!-sf));
    v:=sqrtsinsq(u,intvar);
    v:=purge(sqrtl,v);
    if v then <<
      if !*tra then <<
        printc "Discarding element";
        printsq u >>;
      putv(basis,i,1 ./ 1) >>
      else putv(basis,i,removecmsq u);
    f:=t;
  nochange:
    end;
  basis:=mkuniquevect basis;
  if f and !*tra then <<
    printc "Basis replaced by";
    mapvec(basis,function printsq) >>;
  return basis
  end;


symbolic procedure combine!-sqrts(basis,sqrtl);
begin
  scalar sqrtl!-in!-sf,n,u,v,f;
  n:=upbv basis;
  sqrtl!-in!-sf:=for each u in sqrtl collect
                    !*q2f simp argof u;
  for i:=0:n do begin
    u:=getv(basis,i);
    v:=sqrtsinsq(u,intvar);
    % We have one task to perform,
    % the replacing of SQRT(A)*SQRT(B) by SQRT(A*B)
    % where relevant.
    v:=purge(sqrtl,v);
    if null v
      then go to nochange;
    u:=multsq(modify2(numr u,v,sqrtl!-in!-sf) ./ 1,
              1 ./ modify2(denr u,v,sqrtl!-in!-sf));
    putv(basis,i,u);
    f:=t;
  nochange:
    end;
  if f and !*tra then <<
    printc "Basis replaced by";
    mapvec(basis,function printsq) >>;
  return basis
  end;


symbolic procedure modify2(sf,sqrtsin,realsqrts);
if atom sf
  then sf
  else if atom mvar sf
    then sf
    else if eqcar(mvar sf,'sqrt) and dependsp(mvar sf,intvar)
      then begin
        scalar u,v,w,lcsf,sqrtsin2,w2,lcsf2,temp;
        u:=!*q2f simp argof mvar sf;
        v:=realsqrts;
        while v and null (w:=modify!-quotf(car v,u))
          do v:=cdr v;
        if null v
          then <<
            if !*tra then <<
              printc "Unable to modify (postponed)";
              printsf !*kk2f mvar sf >>;
            return sf >>;
        v:=car v;
        % We must modify SQRT(U) into SQRT(V) if possible.
        lcsf:=lc sf;
        sqrtsin2:=delete(mvar sf,sqrtsin);
        while sqrtsin2 and (w neq 1) do <<
          temp:=!*q2f simp argof car sqrtsin2;
          if (w2:=modify!-quotf(w,temp)) and
             (lcsf2:=modify!-quotf(lcsf,!*kk2f car sqrtsin2))
            then <<
              w:=w2;
              lcsf:=lcsf2 >>;
          sqrtsin2:=cdr sqrtsin2 >>;
        if w = 1
          then return addf(multf(lcsf,formsqrt v),
                           modify2(red sf,sqrtsin,realsqrts));
                           % It is important to use FORMSQRT here since
                           % SIMPSQRT will recreate the factorisation
                           % we are trying to destroy.
          % Satisfactorily explained away.
        return addf(multf(!*p2f lpow sf,
                          modify2(lc sf,sqrtsin,realsqrts)),
                    modify2(red sf,sqrtsin,realsqrts))
        end
      else addf(multf(!*p2f lpow sf,
                      modify2(lc sf,sqrtsin,realsqrts)),
                modify2(red sf,sqrtsin,realsqrts));



%symbolic procedure modifydown(sf,sqrtl);
%if atom sf
%  then sf
%  else if atom mvar sf
%    then sf
%    else if eqcar(mvar sf,'sqrt) and
%            dependsp(mvar sf,intvar) and
%           not member(!*q2f simp argof mvar sf,sqrtl)
%      then addf(modifydown(lc sf,sqrtl),
%                modifydown(red sf,sqrtl))
%      else addf(multf(!*p2f lpow sf,
%                      modifydown(lc sf,sqrtl)),
%                modifydown(red sf,sqrtl));


% symbolic procedure modifyup(sf,sqrtl);
% if atom sf
%   then sf
%   else if atom mvar sf
%     then sf
%     else if eqcar(mvar sf,'sqrt) and
%             dependsp(mvar sf,intvar)
%       then begin
%         scalar u,v;
%         u:=!*q2f simp argof mvar sf;
%         if u member sqrtl
%         then return addf(multf(!*p2f lpow sf,
%                                 modifyup(lc sf,sqrtl)),
%                           modifyup(red sf,sqrtl));
%        v:=sqrtl;
%        while v and not modify!-quotf(car v,u)
%          do v:=cdr v;
%        if null v
%          then interr "No sqrt to upgrade to";
%       return addf(multf(!*kk2f simpsqrt2 car v,
%                          modifyup(lc sf,sqrtl)),
%                    modifyup(red sf,sqrtl))
%        end
%      else addf(multf(!*p2f lpow sf,
%                      modifyup(lc sf,sqrtl)),
%                modifyup(red sf,sqrtl));


symbolic procedure modify!-quotf(u,v);
% Replacement for quotf, in that it gets sqrts right.
if atom v or atom mvar v
  then quotf(u,v)
  else if u=v then 1
  else begin
    scalar sq;
    sq:=sqrt2top(u ./ v);
    if involvesf(denr sq,intvar)
      then return nil;
    if not onep denr sq
      then if not numberp denr sq
        then interr "Gauss' lemma violated in modify"
        else if !*tra
          then <<
            printc "*** Denominator ignored in modify";
            printc denr sq >>;
    return numr sq
    end;

endmodule;


module modlineq;

% Author: James H. Davenport.

fluid '(current!-modulus sqrts!-mod!-prime);

global '(!*tra !*trmin list!-of!-medium!-primes sqrts!-mod!-8);

exports check!-lineq;

list!-of!-medium!-primes:='(101 103 107 109);

sqrts!-mod!-8:=mkvect 7;

putv(sqrts!-mod!-8,0,t);

putv(sqrts!-mod!-8,1,t);

putv(sqrts!-mod!-8,4,t);

symbolic procedure modp!-nth!-root(m,n,p);
begin
  scalar j,p2;
  p2:=p/2;
  for i:=-p2 step 1 until p2 do
    if modular!-expt(i,n) iequal m
      then << j:=i; i:=p2 >>;
  return j
  end;


symbolic procedure modp!-sqrt(n,p);
begin
  scalar p2,s,tt;
  p2:=p/2;
  if n < 0
    then n:=n+p;
  for i:=0:p2 do begin
    tt:=n+p*i;
    if null getv(sqrts!-mod!-8,tt irem 8)
      then return;
      % mod 8 test for perfect squares.
    if (iadd1 tt irem 5) > 2
      then return;
      % squares are -1,0,1 mod 5.
    s:=int!-sqrt tt;
    if fixp s then <<
      p2:=0;
      return >>
    end;
  if (not fixp s) or null s
    then return nil
    else return s
  end;

symbolic procedure subsetp(a,b);
%True if all members of a are also members of b.
    if null a then t
    else if member(car a,b) then subsetp(cdr a,b)
    else nil;

symbolic procedure check!-lineq(m,rightside);
begin
  scalar vlist,n1,n2,u,primelist,mm,v,modp!-subs,atoms;
  n1:=upbv m;
  for i:=0:n1 do <<
    u:=getv(m,i);
    if u
      then for j:=0:(n2:=upbv u) do
        vlist:=varsinsq(getv(u,j),vlist) >>;
  u:=vlist;
  while u do <<
    v:=car u;
    u:=cdr u;
    if atom v
      then atoms:=v.atoms
      else if (car v eq 'sqrt) or (car v eq 'expt)
        then for each w in varsinsf(!*q2f simp argof v,nil) do
             if not (w member vlist)
               then <<
                 u:=w.u;
                 vlist:=w.vlist >>
        else nil
      else interr "Unexpected item" >>;
  if sqrts!-mod!-prime and
     subsetp(vlist,for each u in cdr sqrts!-mod!-prime
                     collect car u)
    then go to end!-of!-loop;
  vlist:=purge(atoms,vlist);
  u:=nil;
  for each v in vlist do
    if car v neq 'sqrt
      then u:=v.u;
  vlist:=nconc(u,sortsqrts(purge(u,vlist),nil));
    % NIL is the variable to measure nesting on:
    % therefore all nesting is being caught.
  primelist:=list!-of!-medium!-primes;
  set!-modulus car primelist;
  atoms:=for each u in atoms collect
           u . modular!-number random car primelist;
  goto try!-prime;
next!-prime:
  primelist:=cdr primelist;
  if null primelist and !*tra
    then printc "Ran out of primes in check!-lineq";
  if null primelist
    then return t;
  set!-modulus car primelist;
try!-prime:
  modp!-subs:=atoms;
  v:=vlist;
loop:
  if null v
    then go to end!-of!-loop;
  u:=modp!-subst(simp argof car v,modp!-subs);
  if caar v eq 'sqrt
    then u:=modp!-sqrt(u,car primelist)
    else if caar v eq 'expt
      then u:=modp!-nth!-root(modular!-expt(u,cadr caddr car v),
        caddr caddr car v,car primelist)
      else interr "Unexpected item";
  if null u
    then go to next!-prime;
  modp!-subs:=(car v . u) . modp!-subs;
  v:=cdr v;
  go to loop;
end!-of!-loop:
  if null primelist
    then <<
      setmod(car sqrts!-mod!-prime);
      modp!-subs:=cdr sqrts!-mod!-prime >>
    else sqrts!-mod!-prime:=(car primelist).modp!-subs;
  mm:=mkvect n1;
  for i:=0:n1 do begin
    u:=getv(m,i);
    if null u
      then return;
    putv(mm,i,v:=mkvect n2);
    for j:=0:n2 do
      putv(v,j,modp!-subst(getv(u,j),modp!-subs))
    end;
  v:=mkvect n1;
  for i:=0:n1 do
    putv(v,i,modp!-subst(getv(rightside,i),modp!-subs));
  u:=mod!-jhdsolve(mm,v);
  if (u eq 'failed) and (!*tra or !*trmin)
    then <<
      princ "Proved insoluble mod ";
      printc car sqrts!-mod!-prime >>;
  return u
  end;


symbolic procedure modp!-subst(sq,slist);
modular!-quotient(modp!-subf(numr sq,slist),
                  modp!-subf(denr sq,slist));


symbolic procedure modp!-subf(sf,slist);
if atom sf
  then if null sf
    then 0
    else modular!-number sf
  else begin
    scalar u;
    u:=assoc(mvar sf,slist);
    if null u
      then interr "Unexpected variable";
    return modular!-plus(modular!-times(modular!-expt(cdr u,ldeg sf),
                                        modp!-subf(lc sf,slist)),
                         modp!-subf(red sf,slist))
    end;


symbolic procedure mod!-jhdsolve(m,rightside);
% Returns answer to m.answer=rightside.
% Matrix m not necessarily square.
begin
  scalar n1,n2,ans,u,row,swapflg,swaps;
  % The SWAPFLG is true if we have changed the order of the
  % columns and need later to invert this via SWAPS.
  n1:=upbv m;
  for i:=0:n1 do
    if (u:=getv(m,i))
      then (n2:=upbv u);
  swaps:=mkvect n2;
  for i:=0:n2 do
    putv(swaps,i,n2-i);
    % We have the SWAPS vector, which should be a vector of indices,
    % arranged like this because VECSORT sorts in decreasing order.
  for i:=0:isub1 n1 do begin
    scalar k,v,pivot;
  tryagain:
    row:=getv(m,i);
    if null row
      then go to interchange;
    % look for a pivot in row.
    k:=-1;
    for j:=0:n2 do
      if not zerop (pivot:=getv(row,j))
        then <<
          k:=j;
          j:=n2 >>;
    if k neq -1
      then goto newrow;
    if not zerop getv(rightside,i)
      then <<
        m:='failed;
        i:=sub1 n1; %Force end of loop.
        go to finished >>;
interchange:
    % now interchange i and last element.
    swap(m,i,n1);
    swap(rightside,i,n1);
    n1:=isub1 n1;
    if i iequal n1
      then goto finished
      else goto tryagain;
  newrow:
    if i neq k
      then <<
        swapflg:=t;
        swap(swaps,i,k);
          % record what we have done.
        for l:=0:n1 do
          swap(getv(m,l),i,k) >>;
        % place pivot on diagonal.
    pivot:=modular!-minus modular!-reciprocal pivot;
    for j:=iadd1 i:n1 do begin
      u:=getv(m,j);
      if null u
        then return;
      v:=modular!-times(getv(u,i),pivot);
      if not zerop v then <<
        putv(rightside,j,
            modular!-plus(getv(rightside,j),
                modular!-times(v,getv(rightside,i))));
        for l:=0:n2 do
          putv(u,l,
             modular!-plus(getv(u,l),
                 modular!-times(v,getv(row,l)))) >>
      end;
  finished:
    end;
  if m eq 'failed
    then go to failed;
    % Equations were inconsistent.
  while null (row:=getv(m,n1)) do
    n1:=isub1 n1;
  u:=nil;
  for i:=0:n2 do
    if not zerop getv(row,i)
      then u:='t;
  if null u
    then if not zerop getv(rightside,n1)
      then go to failed
      else n1:=isub1 n1;
      % Deals with a last equation which is all zero.
  if n1 > n2
    then go to failed;
    % Too many equations to satisfy.
  ans:=mkvect n2;
  for i:=0:n2 do
    putv(ans,i,0);
  % now to do the back-substitution.
  for i:=n1 step -1 until 0 do begin
    row:=getv(m,i);
    if null row
      then return;
    u:=getv(rightside,i);
    for j:=iadd1 i:n2 do
      u:=modular!-plus(u,
         modular!-times(getv(row,j),modular!-minus getv(ans,j)));
    putv(ans,i,modular!-times(u,modular!-reciprocal getv(row,i)))
    end;
  if swapflg
    then vecsort(swaps,list ans);
  return ans;
failed:
  if !*tra
    then printc "Unable to force correct zeroes";
  return 'failed
  end;

endmodule;


module nagell;

% Author: James H. Davenport.

fluid '(intvar);

global '(!*tra !*trmin);

exports lutz!-nagell;

symbolic procedure lutz!-nagell(divisor);
begin
  scalar ans,places,mults,save!*tra;
  for each u in divisor do <<
    places:=(car u).places;
    mults :=(cdr u).mults >>;
  ans:=lutz!-nagell!-2(places,mults);
  save!*tra:=!*tra;
  if !*trmin
    then !*tra:=nil;
  ans:=coates!-multiple(places,mults,ans);
  !*tra:=save!*tra;
  return ans
  end;


symbolic procedure lutz!-nagell!-2(places,mults);
begin
  scalar wst,x,y,equation,point,a;
  wst:=weierstrass!-form getsqrtsfromplaces places;
  x:=car wst;
  y:=cadr wst;
  equation:=caddr wst;
  equation:=!*q2f !*multsq(equation,equation);
  equation:=makemainvar(equation,intvar);
  if ldeg equation = 3
    then equation:=red equation
    else interr "Equation not of correct form";
  if mvar equation eq intvar
    then if ldeg equation = 1
      then <<
        a:=(lc equation) ./ 1;
        equation:=red equation >>
      else interr "Equation should not have a x**2 term"
    else a:=nil ./ 1;
  equation:= a . (equation ./ 1);
  places:=for each u in places collect
            wst!-convert(u,x,y);
  point:=elliptic!-sum(places,mults,equation);
  a:=lutz!-nagell!-bound(point,equation);
  if !*tra or !*trmin then <<
    princ "Point actually is of order ";
    printc a >>;
  return a
  end;


symbolic procedure wst!-convert(place,x,y);
begin
  x:=subzero(xsubstitutesq(x,place),intvar);
  y:=subzero(xsubstitutesq(y,place),intvar);
  return x.y
  end;


symbolic procedure elliptic!-sum(places,mults,equation);
begin
  scalar point;
  point:=elliptic!-multiply(car places,car mults,equation);
  places:=cdr places;
  mults:=cdr mults;
  while places do <<
    point:=elliptic!-add(point,
                         elliptic!-multiply(car places,car mults,
                                            equation),
                         equation);
    places:=cdr places;
    mults:=cdr mults >>;
  return point
  end;


symbolic procedure elliptic!-multiply(point,n,equation);
if n < 0
  then elliptic!-multiply( (car point) . (negsq cdr point),
                           -n,
                           equation)
  else if n = 0
    then interr "N=0 in elliptic!-multiply"
    else if n = 1
      then point
      else begin
        scalar q,r;
        q:=divide(n,2);
        r:=cdr q;
        q:=car q;
        q:=elliptic!-multiply(elliptic!-add(point,point,equation),q,
                                            equation);
        if r = 0
          then return q
          else return elliptic!-add(point,q,equation)
        end;


symbolic procedure elliptic!-add(p1,p2,equation);
begin
  scalar x1,x2,y1,y2,x3,y3,inf,a,b,lhs,rhs;
  a:=car equation;
  b:=cdr equation;
  inf:=!*kk2q 'infinity;
  x1:=car p1;
  y1:=cdr p1;
  x2:=car p2;
  y2:=cdr p2;
  if x1 = x2
    then if y1 = y2
      then <<
        % this is the doubling case.
        x3:=!*multsq(!*addsq(!*addsq(!*multsq(a,a),
                                     !*exptsq(x1,4)),
                             !*addsq(multsq(-8 ./ 1,!*multsq(x1,b)),
                                     !*multsq(!*multsq(x1,x1),
                                              multsq(-2 ./ 1,a)))),
                     !*invsq multsq(4 ./ 1,
                          !*addsq(b,!*multsq(x1,!*addsq(a,
                                                   !*exptsq(x1,2))))));
        y3:=!*addsq(y1,!*multsq(!*multsq(!*addsq(x3,negsq x1),
                                         !*addsq(a,multsq(3 ./ 1,
                                                     !*multsq(x1,x1)))),
                                 !*invsq multsq(2 ./ 1,
                                                y1))) >>
      else x3:=(y3:=inf)
    else if x1 = inf
      then <<
        x3:=x2;
        y3:=y2 >>
      else if x2 = inf
        then <<
          x3:=x1;
          y3:=y1 >>
        else <<
          x3:=!*multsq(!*addsq(!*multsq(a,!*addsq(x1,x2)),
                               !*addsq(multsq(2 ./ 1,b),
                                       !*addsq(!*multsq(!*multsq(x1,x2),
                                                        !*addsq(x1,x2)),
                                               multsq(-2 ./ 1,
                                                    !*multsq(y1,y2))))),
                       !*invsq !*exptsq(!*addsq(x1,negsq x2),2));
          y3:=!*multsq(!*addsq(!*multsq(!*addsq(y2,negsq y1),x3),
                               !*addsq(!*multsq(x2,y1),
                                       !*multsq(x1,negsq y2))),
                       !*invsq !*addsq(x1,negsq x2)) >>;
  if x3 = inf
    then return x3.y3;
  lhs:=!*multsq(y3,y3);
  rhs:=!*addsq(b,!*multsq(x3,!*addsq(a,!*multsq(x3,x3))));
  if numr !*addsq(lhs,negsq rhs) % We can't just compare them
                                  % since they're algebraic numbers.
                                  % JHD Jan 14th. 1987.
    then <<
      prin2t "Point defined by X and Y as follows:";
      printsq x3;
      printsq y3;
      prin2t "on the curve defined by A and B as follows:";
      printsq a;
      printsq b;
      prin2t "gives a consistency check between:";
      printsq lhs;
      printsq rhs;
      interr "Consistency check failed in elliptic!-add" >>;
  return x3.y3
  end;




symbolic procedure infinitep u;
kernp u and (mvar numr u eq 'infinite);


symbolic procedure lutz!-nagell!-bound(point,equation);
begin
  scalar x,y,a,b,lutz!-alist,n,point2,p,l,ans;
    % THE LUTZ!-ALIST is an association list of elements of the form
    % [X-value].([Y-value].[value of N for this point])
    % See thesis, chapter 7, algorithm LUTZ!-NAGELL, step [1].
  x:=car point;
  y:=cdr point;
  if !*tra or !*trmin then <<
    printc "Point to have torsion investigated is";
    printsq x;
    printsq y >>;
  a:=car equation;
  b:=cdr equation;
  if denr y neq 1 then <<
    l:=denr y;
    % we can in fact make l an item whose cube is > denr y.
    y:=!*multsq(y,!*exptf(l,3) ./ 1);
    x:=!*multsq(x,!*exptf(l,2) ./ 1);
    a:=!*multsq(a,!*exptf(l,4) ./ 1);
    b:=!*multsq(b,!*exptf(l,6) ./ 1) >>;
  if denr x neq 1 then <<
    l:=denr x;
    % we can in fact make l an item whose square is > denr x.
    y:=!*multsq(y,!*exptf(l,3) ./ 1);
    x:=!*multsq(x,!*exptf(l,2) ./ 1);
    a:=!*multsq(a,!*exptf(l,4) ./ 1);
    b:=!*multsq(b,!*exptf(l,6) ./ 1) >>;
  % we now have integral co-ordinates for x,y.
  lutz!-alist:=list (x . (y . 0));
  if (x neq car point) and (!*tra or !*trmin) then <<
    printc "Point made integral as ";
    printsq x;
    printsq y;
    printc "on the curve with coefficients";
    printsq a;
    printsq b >>;
  point:=x.y;
  equation:=a.b;
  n:=0;
loop:
  n:=n+1;
  point2:=elliptic!-multiply(x.y,2,equation);
  x:=car point2;
  y:=cdr point2;
  if infinitep x
    then return 2**n;
  if denr x neq 1
    then go to special!-denr;
  if a:=assoc(x,lutz!-alist)
    then if y = cadr a
      then return (ans:=lutz!-reduce(point,equation,2**n-2**(cddr a)))
      else if null numr !*addsq(y,cadr a)
        then return (ans:=lutz!-reduce(point,equation,2**n+2**(cddr a)))
        else interr "Cannot have 3 points here";
  lutz!-alist:=(x.(y.n)).lutz!-alist;
  if ans
    then return ans;
  go to loop;
special!-denr:
  p:=denr x;
  if not jhd!-primep p
    then return 'infinite;
  n:=1;
  n:=1;
loop2:
  point:=elliptic!-multiply(point,p,equation);
  n:=n*p;
  if infinitep car point
    then return n;
  if quotf(p,denr car point)
    then go to loop2;
  return 'infinite
  end;


symbolic procedure lutz!-reduce(point,equation,power);
begin
  scalar n;
  if !*tra or !*trmin then <<
    princ "Point is of order dividing ";
    printc power >>;
  n:=1;
  while evenp power do <<
    power:=power/2;
    n:=n*2;
    point:=elliptic!-add(point,point,equation) >>;
    % we know that all the powers of 2 must appear in the answer.
  if power = 1
    then return n;
  if jhd!-primep power
    then return n*power;
  return n*lutz!-reduce2(point,equation,power,3)
  end;



symbolic procedure lutz!-reduce2(point,equation,power,prime);
if power = 1
  then if infinitep car point
    then 1
    else nil
  else if infinitep car point
    then power
    else begin
      scalar n,prime2,u,ans;
      n:=0;
      while zerop cdr divide(power,prime) do <<
        n:=n+1;
        power:=power/prime >>;
      prime2:=nextprime prime;
      for i:=0:n do <<
        u:=lutz!-reduce2(point,equation,power,prime2);
        if u
          then <<
              ans:=u*prime**i;
              i:=n >>
         else <<
          power:=power*prime;
          point:=elliptic!-multiply(point,prime,equation) >> >>;
      if ans
        then return ans
        else return nil
      end;

endmodule;


module nbasis;

% Author: James H. Davenport.

fluid '(nestedsqrts sqrt!-intvar taylorasslist);

global '(!*tra);

exports normalbasis;
imports substitutesq,taylorform,printsq,newplace,sqrtsinsq,union,
        sqrtsign,interr,vecsort,mapvec,firstlinearrelation,mksp,multsq,
        !*multsq,addsq,removecmsq,antisubs,involvesq;


symbolic procedure normalbasis(zbasis,x,infdegree);
begin
  scalar n,nestedsqrts,sqrts,u,v,w,li,m,lam,i,inf,basis,save;
  save:=taylorasslist;
  inf:=list list(x,'quotient,1,x);
  n:=upbv zbasis;
  basis:=mkvect n;
  lam:=mkvect n;
  m:=mkvect n;
  goto  a;
square:
  sqrts:=nil;
  inf:=append(inf,list list(x,'expt,x,2));
  % we were in danger of getting sqrt(x) where we didnt want it.
a:
  newplace(inf);
  for i:=0:n do <<
    v:=substitutesq(getv(zbasis,i),inf);
    putv(basis,i,v);
    sqrts:=union(sqrts,sqrtsinsq(v,x)) >>;
  if !*tra then <<
    princ "Normal integral basis reduction with the";
    printc " following sqrts lying over infinity:";
    superprint sqrts >>;
  if member(list('sqrt,x),sqrts)
    then goto square;
  sqrts:=sqrtsign(sqrts,x);
  if iadd1 n neq length sqrts
    then interr "Length mismatch in normalbasis";
  for i:=0:n do <<
    v:=cl8roweval(getv(basis,i),sqrts);
    putv(m,i,cdr v);
    putv(lam,i,car v) >>;
reductionloop:
  vecsort(lam,list(basis,m));
  if !*tra then <<
    printc "Matrix before a reduction step at infinity is:";
    mapvec(m,function printc) >>;
  v:=firstlinearrelation(m,iadd1 n);
  if null v
    then goto ret;
  i:=n;
  while null numr getv(v,i) do
    i:=isub1 i;
  li:=getv(lam,i);
  w:=nil ./ 1;
  for j:=0:i do
    w:=addsq(w,!*multsq(getv(basis,j),
                 multsq(getv(v,j),1 ./  !*fmksp(x,-li+getv(lam,j)) )));
           % note the change of sign. my x is coates 1/x at this point!.
  if !*tra then <<
    princ "Element ";
    princ i;
    printc " replaced by the function printed below:" >>;
  w:=removecmsq w;
  putv(basis,i,w);
  w:=cl8roweval(w,sqrts);
  if car w <= li
    then interr "Normal basis reduction did not work";
  putv(lam,i,car w);
  putv(m,i,cdr w);
  goto reductionloop;
ret:
  newplace list (x.x);
  u:= 1 ./ !*p2f mksp(x,1);
  inf:=antisubs(inf,x);
  u:=substitutesq(u,inf);
  m:=nil;
  for i:=0:n do begin
    v:=getv(lam,i)-infdegree;
    if v < 0
      then goto next;
    w:=substitutesq(getv(basis,i),inf);
    for j:=0:v do <<
      if not involvesq(w,sqrt!-intvar)
        then m:=w.m;
      w:=!*multsq(w,u) >>;
  next:
    end;
  tayshorten save;
  return m
  end;


symbolic procedure !*fmksp(x,i);
% sf for x**i.
if i iequal 0
  then 1
  else !*p2f mksp(x,i);


symbolic procedure cl8roweval(basiselement,sqrts);
begin
  scalar lam,row,i,v,minimum,n;
  n:=isub1 length sqrts;
  lam:=mkvect n;
  row:=mkvect n;
  i:=0;
  minimum:=1000000;
  while sqrts do <<
    v:=taylorform substitutesq(basiselement,car sqrts);
    v:=assoc(taylorfirst v,taylorlist v);
    putv(row,i,cdr v);
    v:=car v;
    putv(lam,i,v);
    if v < minimum
      then minimum:=v;
    i:=iadd1 i;
    sqrts:=cdr sqrts >>;
  if !*tra then <<
    princ "Evaluating ";
    printsq basiselement;
    printc lam;
    printc row >>;
  v:=1000000;
  for i:=0:n do <<
    v:=getv(lam,i);
    if v > minimum
      then putv(row,i,nil ./ 1) >>;
  return minimum.row
  end;

endmodule;


module places;
 
% Author: James H. Davenport.
 
fluid '(basic!-listofallsqrts
        basic!-listofnewsqrts
        intvar
        listofallsqrts
        listofnewsqrts
        sqrt!-intvar
        sqrt!-places!-alist
        sqrts!-in!-integrand);
 
exports getsqrtsfromplaces,sqrtsinplaces,get!-correct!-sqrts,basicplace,
        extenplace,equalplace,printplace;
 
 
 
% Function to manipulate places
% a place is stored as a list of substitutions
% substitutions (x.f(x)) define the algrbraic number
% of which this place is an extension,
% while places (f(x).g(x)) define the extension.
%    currently g(x( is list ('minus,f(x))
%       or similar,e.g. (sqrt(sqrt x)).(sqrt(-sqrt x)).

 
 
% Given a list of places, produces a list of all
% the SQRTs in it that depend on INTVAR.
symbolic procedure getsqrtsfromplaces places;
  % The following loop finds all the SQRTs for a basis,
  % taking account of BASICPLACEs.
begin
  scalar basis,v,b,c,vv;
  for each u in places do <<
    v:=antisubs(basicplace u,intvar);
    vv:=sqrtsinsq (substitutesq(!*kk2q intvar,v),intvar);
      % We must go via SUBSTITUTESQ to get parallel
      % substitutions performed correctly.
    if vv
      then vv:=simp argof car vv;
    for each w in extenplace u do <<
      b:=substitutesq(simp lsubs w,v);
      b:=delete(sqrt!-intvar,sqrtsinsq(b,intvar));
      for each u in b do
        for each v in delete(u,b) do
          if dependsp(v,u)
            then b:=delete(u,b);
            % remove all the "inner" items, since they will
            % be accounted for anyway.
      if length b iequal 1
        then b:=car b
 else b:=mvar numr simpsqrtsq mapply(function !*multsq,
                                for each u in b collect simp argof u);
      if vv and not (b member sqrts!-in!-integrand)
        then <<
          c:=numr multsq(simp argof b,vv);
          c:=car sqrtsinsf(simpsqrt2 c,nil,intvar);
   if c member sqrts!-in!-integrand
            then b:=c >>;
      if not (b member basis)
        then basis:=b.basis >> >>;
  % The following loop deals with the annoying case of, say,
  % (X DIFFERENCE X 1) (X EXPT X 2) which should give rise to
  % SQRT(X-1).
  for each u in places do begin
    v:=cdr u;
    if null v or (car rfirstsubs v neq 'expt)
      then return;
    u:=simp!* subst(list('minus,intvar),intvar,rfirstsubs u);
    while v and (car rfirstsubs v eq 'expt) do <<
      u:=simpsqrtsq u;
      v:=cdr v;
      basis:=union(basis,delete(sqrt!-intvar,sqrtsinsq(u,intvar))) >>
    end;
  return remove!-extra!-sqrts basis
  end;
 
 
 
symbolic procedure sqrtsinplaces u;
% Note the difference between this procedure and
% the previous one: this one does not take account
% of the BASICPLACE component (& is pretty useless).
if null u
  then nil
  else sqrtsintree(for each v in car u collect lsubs v,
                   intvar,
                   sqrtsinplaces cdr u);
 
 
 
%symbolic procedure placesindiv places;
% Given a list of places (i.e. a divisor),
% produces a list of all the SQRTs on which the places
% explicitly depend.
%begin scalar v;
%  for each u in places do
%    for each uu in u do
%      if not (lsubs uu member v)
%        then v:=(lsubs uu) . v;
%  return v
%  end;

 
 
symbolic procedure get!-correct!-sqrts u;
% u is a basicplace.
begin
  scalar v;
  v:=assoc(u,sqrt!-places!-alist);
  if v
    then <<
      v:=cdr v;
      listofallsqrts:=cdr v;
      listofnewsqrts:=car v
      >>
    else <<
      listofnewsqrts:=basic!-listofnewsqrts;
      listofallsqrts:=basic!-listofallsqrts
      >>;
  return nil
  end;
 
 
 
%symbolic procedure change!-place(old,new);
%% old and new are basicplaces;
%begin
%  scalar v;
%  v:=assoc(new,sqrt!-places!-alist);
%  if v
%    then sqrtsave(cddr v,cadr v,old)
%    else <<
%      listofnewsqrts:=basic!-listofnewsqrts;
%      listofallsqrts:=basic!-listofallsqrts
%      >>;
%  return nil
%  end;

 
 
symbolic procedure basicplace(u);
% Returns the basic part of a place.
if null u
  then nil
  else if atom caar u
    then (car u).basicplace cdr u
    else nil;
 
 
 
symbolic procedure extenplace(u);
% Returns the extension part of a place.
if u and atom caar u
  then extenplace cdr u
  else u;
 
 
 
symbolic procedure equalplace(a,b);
% Sees if two extension places represent the same place or not.
if null a
  then if null b
    then t
    else nil
  else if null b
    then nil
    else if member(car a,b)
      then equalplace(cdr a,delete(car a,b))
      else nil;
 
 
 
symbolic procedure remove!-extra!-sqrts basis;
begin
  scalar basis2,save;
  save:=basis2:=for each u in basis collect !*q2f simp argof u;
  for each u in basis2 do
    for each v in delete(u,basis2) do
      if quotf(v,u)
        then basis2:=delete(v,basis2);
  if basis2 eq save
    then return basis
    else return for each u in basis2 collect list('sqrt,prepf u)
  end;
 
 
 
symbolic procedure printplace u;
begin
  scalar a,n,v;
  a:=rfirstsubs u;
  princ (v:=lfirstsubs u);
  princ "=";
  if atom a
    then princ "0"
    else if (car a eq 'quotient) and (cadr a=1)
      then princ "infinity"
      else <<
 n:=negsq addsq(!*kk2q v,negsq simp!* a);
% NEGSQ added JHD 22.3.87 - the previous value was wrong.
% If the substitution is (X-v) then this takes -v to 0,
% so the place was at -v.
        if (numberp numr n) and (numberp denr n)
          then <<
            princ numr n;
            if not onep denr n
              then <<
                princ " / ";
                princ denr n >> >>
          else <<
            if degreein(numr n,intvar) > 1
             then printc "Any root of:";
            printsq n;
            if cdr u
              then princ "at the place " >> >>;
  u:=cdr u;
  if null u
    then goto nl!-return;
  n:=1;
  while u and (car rfirstsubs u eq 'expt) do <<
    n:=n * caddr rfirstsubs u;
    u:=cdr u >>;
  if n neq 1 then <<
    terpri!* nil;
    prin2 " ";
    princ v;
    princ "=>";
    princ v;
    princ "**";
    princ n >>;
  while u do <<
    if car rfirstsubs u eq 'minus
      then princ "-"
      else princ "+";
    u:=cdr u >>;
nl!-return:
  terpri();
  return
  end;
 
 
 
symbolic procedure degreein(sf,var);
if atom sf
  then 0
  else if mvar sf eq var
    then ldeg sf
    else max(degreein(lc sf,var),degreein(red sf,var));
 
endmodule;


module precoats;

% Author: James H. Davenport.

fluid '(basic!-listofallsqrts
        basic!-listofnewsqrts
        sqrt!-intvar
        taylorvariable
        thisplace);

global '(!*tra);

exports precoates;
imports mksp,algint!-subf,subzero2,substitutesq,removeduplicates,
        printsq,basicplace,extenplace,interr,get!-correct!-sqrts,
        printplace,simptimes,subzero,negsq,addsq,involvesq,taylorform,
        taylorevaluate,mk!*sq,!*exptsq,!*multsq,!*invsq,sqrt2top,
        jfactor,sqrtsave,antisubs;


symbolic procedure infsubs(w);
if caar w = thisplace
  then (cdar w).(cdr w)
  else (thisplace.(car w)).(cdr w);
% thisplace is (z quotient 1 z) so we are moving to infinity.


symbolic procedure precoates(residues,x,movedtoinfinity);
begin
  scalar answer,placeval,reslist,placelist,placelist2,thisplace;
  reslist:=residues;
  placelist:=nil;
  while reslist do <<
    % car reslist = <substitution list>.<value>;
    placeval:=algint!-subf((mksp(x,1) .* 1) .+ nil,caar reslist);
    if 0 neq cdar reslist
      then if null numr subzero2(denr placeval,x)
        then <<
          if null answer
            then answer:='infinity
            else if answer eq 'finite
              then answer:='mixed;
          if !*tra
            then printc "We have an residue at infinity" >>
        else <<
          if null answer
            then answer:='finite
            else if answer eq 'infinity
              then answer:='mixed;
          placelist:=placeval.placelist;
          if !*tra
            then printc "This is a finite residue" >>;
    reslist:=cdr reslist >>;
  if answer eq 'mixed
    then return answer;
  if answer eq 'infinity
    then <<
      thisplace:=list(x,'quotient,1,x);
      % maps x to 1/x.
      answer:=precoates(for each u in residues collect infsubs u,x,t);
                % derivative of 1/x is -1/x**2.
      if atom answer
        then return answer
        else return substitutesq(answer,list(thisplace)) >>;
  placelist2:=removeduplicates placelist;
  answer := 1 ./ 1;
  % the null divisor.
  if !*tra then <<
    printc "The divisor has elements at:";
    mapcar(placelist2,function printsq) >>;
  while placelist2 do begin
    scalar placelist3,extrasubs,u,bplace;
    % loop over all distinct places.
    reslist:=residues;
    placelist3:=placelist;
    placeval:=nil;
    while reslist do <<
      if car placelist2 = car placelist3
        then <<
          placeval:=(cdar reslist).placeval;
          thisplace:= caar reslist;
          % the substitutions defining car placelist.
          u:=caar reslist;
          bplace:=basicplace u;
          u:=extenplace u;
          extrasubs:=u.extrasubs >>;
      reslist:=cdr reslist;
      placelist3:=cdr placelist3 >>;
    % placeval is a list of all the residues at this place.
    if !*tra then <<
      princ "List of multiplicities at this place:";
      printc placeval;
      princ "with substitutions:";
      superprint extrasubs >>;
    if 0 neq mapply(function plus2,placeval)
      then interr "Divisor not effective";
    get!-correct!-sqrts bplace;
    u:=pbuild(x,extrasubs,placeval);
    sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts,bplace);
    if atom u
      then <<
        placelist2:=nil;
        % set to terminate loop.
        answer:=u >>
      else <<
        answer:=substitutesq(!*multsq(answer,u),antisubs(thisplace,x));
        placelist2:=cdr placelist2 >>
    end;
    % loaded in pbuild to check for poles at the correct places.
  return answer
  end;



symbolic procedure dlist(u);
% Given a list of lists,converts to a list.
if null u
  then nil
  else if null car u
    then dlist cdr u
    else append(car u,dlist cdr u);


symbolic procedure debranch(extrasubs,reslist);
begin
  scalar substlist;
  % remove spurious substitutions.
  for each u in dlist extrasubs do
    if not ((car u) member substlist)
      then substlist:=(car u).substlist;
  % substlist is a list of all the possible substitutions).
  while substlist do
    begin scalar tsqrt,usqrt;
      scalar with1,with2,without1,without2,wres;
    scalar a1,a2,b1,b2;
    % decide if tsqrt is redundant.
    tsqrt:=car substlist;
    substlist:=cdr substlist;
    wres:=reslist;
    for each place in extrasubs do <<
      usqrt:=assoc(tsqrt,place);
        % usqrt is s.s' or s.(minus s').
      if null usqrt
        then interr "Places not all there";
      if cadr usqrt eq 'sqrt
        then<<
          with2:=(car wres).with2;
          with1:=delete(usqrt,place).with1>>
        else<<
          if not (cadr usqrt eq 'minus)
            then interr "Ramification format error";
          without2:=(car wres).without2;
          without1:=delete(usqrt,place).without1 >>;
      wres:=cdr wres>>;
    % first see if one item appears passim.
    if null with1
      then go to itswithout;
    if null without1
      then go to itswith;
    % Now must see if WITH2 matches WITHOUT2 in order WITH1/WITHOUT1.
    a1:=with1;
    a2:=with2;
  outerloop:
    b1:=without1;
    b2:=without2;
  innerloop:
    if (car a1) = (car b1)
      then << if (car a2) neq (car b2)
           then return;
           else go to outeriterate >>;
    b1:=cdr b1;
    b2:=cdr b2;
    if null b1
      then return
      else go to innerloop;
      % null b1 => lists do not match at all.
  outeriterate:
    a1:=cdr a1;
    a2:=cdr a2;
    if a1
      then go to outerloop;
    if !*tra then <<
      princ "Residues reduce to:";
      printc without2;
      printc "at ";
      mapc(without1,function printplace) >>;
    extrasubs:=without1;
    reslist:=without2;
    return;
  itswithout:
    % everything is in the "without" list.
    with1:=without1;
    with2:=without2;
  itswith:
    % remove usqrt from the with lists.
    extrasubs:=for each u in with1 collect delete(assoc(tsqrt,u),u);
    if !*tra then <<
      printc "The following appears throughout the list ";
      printc tsqrt >>;
    reslist:=with2
    end;
  return extrasubs.reslist
  end;


symbolic procedure pbuild(x,extrasubs,placeval);
begin
  scalar multivals,u,v,answer;
  u:=debranch(extrasubs,placeval);
  extrasubs:=car u;
  placeval:=cdr u;
  % remove spurious entries.
  if (length car extrasubs) > 1
    then return 'difficult;
  % hard cases not allowed for.
  multivals:=mapcar(dlist extrasubs,function car);
  u:=simptimes removeduplicates multivals;
  answer:= 1 ./ 1;
    while extrasubs do <<
      v:=substitutesq(u,car extrasubs);
      v:=addsq(u,negsq subzero(v,x));
      v:=mkord1(v,x);
      if !*tra then <<
        princ "Required component is ";
        printsq v >>;
      answer:=!*multsq(answer,!*exptsq(v,car placeval));
      % place introduced with correct multiplicity.
      extrasubs:=cdr extrasubs;
      placeval:=cdr placeval >>;
  if length jfactor(denr sqrt2top !*invsq  answer,x) > 1
    then return 'many!-poles
    else return answer
  end;


symbolic procedure findord(v,x);
begin
  scalar nord,vd;
  %given v(x) with v(0)=0, makes v'(0) nonzero.
  nord:=0;
  taylorvariable:=x;
  while involvesq(v,sqrt!-intvar) do
    v:=substitutesq(v,list(x.list('expt,x,2)));
  vd:=taylorform v;
loop:
  nord:=nord+1;
  if null numr taylorevaluate(vd,nord)
    then go to loop;
  return nord
  end;


symbolic procedure mkord1(v,x);
begin
  scalar nord;
  nord:=findord(v,x);
  if nord iequal 1
    then return v;
  if !*tra then <<
    princ "Order reduction: ";
    printsq v;
    princ "from order ";
    princ nord;
    printc " to order 1" >>;
  % Note that here we do not need to simplify, since SIMPLOG will
  % remove all these SQRTs or EXPTs later.
  return !*p2q mksp(list('nthroot,mk!*sq v,nord),1)
  end;

endmodule;


module primes;

% Author: James H. Davenport.

exports nextprime,jhd!-primep;

symbolic procedure nextprime p;
% Returns the next prime number bigger than p.
    if p=0 then 1
    else if p=1 then 2
    else begin
        if evenp p then p:=p+1 else p:=p+2;
 test:  if jhd!-primep p then return p;
        p:=p+2;
        go to test end;

symbolic procedure jhd!-primep p;
    if p < 4 then t
    else if evenp p then nil
    else begin
      scalar n;
      n:=3; %trial factor.
 top: if n*n>p then return t
      else if remainder(p,n)=0 then return nil;
      n:=n+2;
      go to top end;

endmodule;


module removecm;  % Routines to remove constant factors from expresions.

% Author: James H. Davenport.

fluid '(intvar);

% New improved REMOVECOMMOMMULTIPLES routines.
% These routines replace a straightforward pair with GCDF instead of
% CMGCDF and its associates.  The saving is large in complicated
% expressions (in the "general point of order 7" calculations, they
% exceeded 90% in some cases, being 1.5 secs as opposed to > 15 secs.).
% They are about 1K larger, but this seems a small price to pay.

exports removecmsq,removeconstantsf;
imports ordop,addf,gcdn,gcdf,gcdk,involvesf,dependsp,makemainvar,quotf;

symbolic procedure removecmsq sq;
(removecmsf numr sq) ./ (removecmsf denr sq);

symbolic procedure removecmsf sf;
if atom sf or not ordop(mvar sf,intvar) or not involvesf(sf,intvar)
  then if sf
    then 1
    else nil
  else if null red sf
    then if dependsp(mvar sf,intvar)
      then (lpow sf .* removecmsf lc sf) .+ nil
      else removecmsf lc sf
    else begin
      scalar u,v;
      % The general principle here is to find a (non-INTVAR-depending)
      % coefficient of a purely INTVAR-depending monomial, and then
      % perform a g.c.d. to discover that factor of this which is a CM.
      u:=sf;
      while (v:=involvesf(u,intvar)) do u:=lc makemainvar(u,v);
      if u iequal 1
        then return sf;
      return quotf(sf,cmgcdf(sf,u))
      end;

symbolic procedure cmgcdf(sf,u);
if numberp u
  then if atom sf
    then if null sf
      then u
      else gcdn(sf,u)
    else if u = 1
      then 1
      else cmgcdf(red sf,cmgcdf(lc sf,u))
  else if atom sf
    then gcdf(sf,u)
    else if mvar u eq mvar sf
      then if ordop(intvar,mvar u)
        then gcdf(sf,u)
        else cmgcdf2(sf,u)
      else if ordop(mvar sf,mvar u)
        then cmgcdf(red sf,cmgcdf(lc sf,u))
        else cmgcdf(u,sf);

symbolic procedure remove!-maxdeg(sf,var);
if atom sf
  then 0
  else if mvar sf eq var
    then ldeg sf
    else if ordop(var,mvar sf)
      then 0
      else max(remove!-maxdeg(lc sf,var),remove!-maxdeg(red sf,var));

symbolic procedure cmgcdf2(sf,u);
% SF and U have the same MVAR, but INTVAR comes somewhere
% down in SF.  Therefore we can do better than a straight
% GCDK, or even a straight MAKEMAINVAR.
begin
  scalar n;
  n:=remove!-maxdeg(sf,intvar);
  if n = 0
    then return gcdf(sf,u);
    % Doesn't actually depend on INTVAR.
loop:
  if u = 1
    then return 1;
  u:=gcdf(u,collectterms(sf,intvar,n));
  n:=isub1 n;
  if n < 0
    then return u
    else go loop
  end;

symbolic procedure collectterms(sf,var,n);
if atom sf
  then if n = 0
    then sf
    else nil
  else if mvar sf eq var
    then if ldeg sf = n
      then lc sf
      else if ldeg sf > n
        then collectterms(red sf,var,n)
        else nil
    else if ordop(var,mvar sf)
      then if n = 0
        then sf
        else nil
      else begin
        scalar v,w;
        v:=collectterms(lc sf,var,n);
        w:=collectterms(red sf,var,n);
        if null v
          then return w
          else return addf(w,(lpow sf .* v) .+ nil)
        end;

symbolic procedure removeconstantsf sf;
% Very simple version for now.
begin
  scalar u;
  if null sf
    then return nil
    else if atom sf
      then return 1;
  while (null red sf) and (remove!-constantp mvar sf) do
    sf:=lc sf;
  u:=remove!-const!-content sf;
  if u = 1
    then return sf
    else return quotf!*(sf,u)
  end;

symbolic procedure remove!-constantp pf;
if numberp pf
  then t
  else if atom pf
    then nil
    else if car pf eq 'sqrt
      then remove!-constantp argof pf
      else if (car pf eq 'expt) or (car pf eq 'quotient)
        then (remove!-constantp argof pf)
             and (remove!-constantp caddr pf)
        else nil;

symbolic procedure remove!-const!-content sf;
if numberp sf
  then sf
  else if null red sf
    then if remove!-constantp mvar sf
      then (lpow sf .* remove!-const!-content lc sf) .+ nil
      else remove!-const!-content lc sf
    else begin
      scalar u;
      u:=remove!-const!-content lc sf;
      if u = 1
        then return u;
      return gcdf(u,remove!-const!-content red sf)
      end;

endmodule;


module sqfrnorm;

% Author: James H. Davenport.

fluid '(!*pvar listofallsqrts);

global '(modevalcount);

modevalcount:=1;

exports sqfr!-norm2,res!-sqrt;

%symbolic procedure resultant(u,v);
%begin
%  scalar maxdeg,zeroes,ldegu,ldegv,m;
%  % we can have gone makemainvar on u and v;
%  ldegu:=ldeg u;
%  ldegv:=ldeg v;
%  maxdeg:=isub1 max2(ldegu,ldegv);
%  zeroes:=nlist(nil,maxdeg);
%  u:=remake(u,mvar u,ldegu);
%  v:=remake(v,mvar v,ldegv);
%  m:=nil;
%  ldegu:=isub1 ldegu;
%  ldegv:=isub1 ldegv;
%  for i:=0 step 1 until ldegv do
%    m:=append(ncdr(zeroes,maxdeg-ldegv+i),
%              append(u,ncdr(zeroes,maxdeg-i))).m;
%  for i:=0 step 1 until ldegu do
%    m:=append(ncdr(zeroes,maxdeg-ldegu+i),
%              append(v,ncdr(zeroes,maxdeg-i))).m;
%  return detqf m
%  end;


%symbolic procedure remake(u,v,w);
%% remakes u into a list of sf's representing its coefficients;
%if w iequal 0 then list u
%  else if (pairp u) and (mvar u eq v) and (ldeg u iequal w)
%    then (lc u).remake(red u,v,isub1 w)
%    else (nil ).remake(    u,v,isub1 w);

%fluid '(n); %needed for the mapcar;

%symbolic procedure detqf u;
%   %u is a square matrix standard form.
%%  %value is the determinant of u.
%%  %algorithm is expansion by minors of first row/column;
%   begin integer n;
%   scalar x,y,z;
%        if length u neq length car u then rederr "Non square matrix"
%         else if null cdr u then return caar u;
%        if length u < 3
%          then go to noopt;
%        % try to remove a row with only one non-zero in it;
%        z:=1;
%        x:=u;
%      loop:
%        n:=posnnonnull car x;
%        if n eq t
%          then return nil;
%        % special test for all null;
%        if n then <<
%          y:=nth(car x,n);
%          % next line is equivalent to:
%%           onne of n,z is even;
%          if evenp (n+z-1)
%            then y:=negf y;
%          u:=remove(u,z);
%          return !*multf(y,detqf remove2 u) >>;
%       x:=cdr x;
%       z:=z+1;
%       if x
%         then go to loop;
%     noopt:
%        x := u;
%        n := 1;                 %number of current row/column;
%        z := nil;
%        if nonnull car u < nonnullcar u
%         then go to row!-expand;
%        u:=mapcar(u,function cdr);
%    a:  if null x then return z;
%        y := caar x;
%        if null y then go to b
%         else if evenp n then y := negf y;
%        z := addf(!*multf(y,detqf remove(u,n)),z);
%    b:  x := cdr x;
%        n := iadd1 n;
%        go to a;
%      row!-expand:
%        u:=cdr u;
%        x:=car x;
%      aa:
%        if null x then return z;
%        y:=car x;
%        if null y
%          then go to bb
%          else if evenp n then y:=negf y;
%        z:=addf(!*multf(y,detqf remove2 u),z);
%      bb:
%        x:=cdr x;
%        n:=iadd1 n;
%        go to aa
%   end;
%
%
%symbolic procedure remove2 u;
%mapcar(u,function (lambda x;
%                    remove(x,n)));
%
%unfluid '(n);
%
%symbolic procedure nonnull u;
%if null u
%  then 0
%  else if null car u
%    then nonnull cdr u
%    else iadd1 (nonnull cdr u);
%
%
%symbolic procedure nonnullcar u;
%if null u
%  then 0
%  else if null caar u
%    then nonnullcar cdr u
%    else iadd1 (nonnullcar cdr u);
%
%
%
%symbolic procedure posnnonnull u;
%% returns t if u has no non-null elements
%% nil if more than one
%% else position of the first;
%begin
%  scalar n,x;
%  n:=1;
%loop:
%  if null u
%    then return
%      if x
%        then x
%        else t;
%  if car u
%    then if x
%      then return nil
%      else x:=n;
%  n:=iadd1 n;
%  u:=cdr u;
%  go to loop
%  end;


symbolic procedure res!-sqrt(u,a);
% Evaluates resultant of u ( as a poly in its mvar) and x**-a.
begin
  scalar x,n,v,k,l;
  x:=mvar u;
  n:=ldeg u;
  n:=quotient(n,2);
  v:=mkvect n;
  putv(v,0,1);
  for i:=1:n do
    putv(v,i,!*multf(a,getv(v,i-1)));
  % now substitute for x**2 in u leaving k*x+l.
  k:=l:=nil;
  while u do
    if mvar u neq x
      then <<
        l:=addf(l,u);
        u:=nil >>
      else <<
        if evenp ldeg u
          then l:=addf(l,!*multf(lc u,getv(v,(ldeg u)/2)))
          else k:=addf(k,!*multf(lc u,getv(v,(ldeg u -1)/2)));
        u:=red u >>;
  % now have k*x+l,x**2-a, giving l*l-a*k*k.
  return addf(!*multf(l,l),!*multf(negf a,multf(k,k)))
  end;


symbolic procedure sqfr!-norm2 (f,mvarf,a);
begin
  scalar u,w,aa,ff,resfn;
  resfn:='resultant;
  if eqcar(a,'sqrt)
    then <<
      resfn:='res!-sqrt;
      aa:=!*q2f simp argof a >>
    else rederr "Norms over transcendental extensions";
  f:=pvarsub(f,a,'! gerbil);
  w:=nil;
  if involvesf(f,'! gerbil) then goto l1;
increase:
  w:=addf(w,!*p2f mksp(a,1));
  f:=!*q2f algint!-subf(f,list(mvarf . list('plus,mvarf,
                                            list('minus,'! gerbil))));
l1:
  u:=apply(resfn,list(makemainvar(f,'! gerbil),aa));
  ff:=nsqfrp(u,mvarf);
  if ff
    then go to increase;
  f:=!*q2f algint!-subf(f,list('! gerbil.a));
  % cannot use pvarsub since want to squash higher powers.
  return list(u,w,f)
  end;

symbolic procedure nsqfrp(u,v);
begin
  scalar w;
  w:=modeval(u,v);
  if w eq 'failed
    then go to normal;
  if atom w
    then go to normal;
  if ldegvar(w,v) neq ldegvar(u,v)
    then go to normal;
%  printc "Modular image is:";
%  printsf w;
  w:=gcdf(w,partialdiff(w,v));
%  printc "Answer is:";
%  printsf w;
  if w iequal 1
    then return nil;
normal;
  w:=gcdf(u,partialdiff(u,v));
  if involvesf(w,v)
    then return w
    else return nil
  end;

symbolic procedure ldegvar(u,v);
if atom u
  then 0
  else if mvar u eq v
    then ldeg u
    else if ordop(v,mvar u)
      then 0
      else max2(ldegvar(lc u,v),ldegvar(red u,v));


symbolic procedure modeval(u,v);
if atom u
  then u
  else if v eq mvar u
    then begin
      scalar w,x;
      w:=modeval(lc u,v);
      if w eq 'failed
        then return w;
      x:=modeval(red u,v);
      if x eq 'failed
        then return x;
      if null w
        then return x
        else return (lpow u .* w) .+ x
      end
    else begin
      scalar w,x;
      x:=mvar u;
      if not atom x
        then if dependsp(x,v)
          then return 'failed;
      x:=modevalvar x;
      if x eq 'failed
        then return x;
      w:=modeval(lc u,v);
      if w eq 'failed
        then return w;
      if x
        then w:=multf(w,exptf(x,ldeg u));
      x:=modeval(red u,v);
      if x eq 'failed
        then return x;
      return addf(w,x)
      end;


symbolic procedure modevalvar v;
begin
  scalar w,x;
  if not atom v
    then go to alg;
  w:=get(v,'modvalue);
  if w
    then return w;
  put(v,'modvalue,modevalcount);
  modevalcount:=modevalcount+1;
  return modevalcount-1;
alg:
  if car v neq 'sqrt
    then rederr "Unexpected algebraic";
  if numberp argof v
    then return (mksp(v,1) .* 1) .+ nil;
  w:=modeval(!*q2f simp argof v,!*pvar);
  w:=assoc(w,listofallsqrts);
  % the variable does not matter, since we know that it does not depend.
  if w
    then return cdr w
    else return 'failed
  end;

% unglobal '(modevalcount);

endmodule;


module substns;

% Author: James H. Davenport.

exports xsubstitutep,xsubstitutesq,substitutevec,substitutesq,subzero,
        subzero2,pvarsub;


symbolic procedure xsubstitutep(pf,slist);
simp xsubstitutep2(pf,slist);


symbolic procedure xsubstitutep2(pf,slist);
if null slist
  then pf
  else xsubstitutep2(subst(rfirstsubs slist,
                           lfirstsubs slist,
                           pf),
                     cdr slist);


symbolic procedure xsubstitutesq(sq,slist);
substitutesq(substitutesq(sq,basicplace slist),extenplace slist);


symbolic procedure substitutevec(v,slist);
for i:=0:upbv v do
  putv(v,i,substitutesq(getv(v,i),slist));


symbolic procedure substitutesq(sq,slist);
begin
  scalar list2,nm;
  list2:=nil;
  while slist do <<
    if cdar slist iequal 0
      then <<
        if list2
          then sq:=substitutesq(sq,reversewoc list2);
        list2:=nil;
        sq:=subzero(sq,caar slist) >>
      else if not (caar slist = cdar slist)
        then if assoc(caar slist,list2)
          then list2:=for each u in list2 collect
                  (car u).subst(cdar slist,caar slist,cdr u)
          else list2:=(car slist).list2;
        % don't bother with the null substitution.
    slist:=cdr slist >>;
  list2:=reversewoc list2;
  if null list2
    then return sq;
  nm:=algint!-subf(numr sq,list2);
  if numr nm
    then nm:=!*multsq(nm,invsq algint!-subf(denr sq,list2));
  return nm
  end;

% standard interface.
symbolic procedure subzero(exprn,var);
begin
  scalar top;
  top:=subzero2(numr exprn,var);
  if null numr top
    then return nil ./ 1;
  return !*multsq(top,!*invsq subzero2(denr exprn,var))
  end;


symbolic procedure subzero2(sf,var);
if not involvesf(sf,var)
  then sf ./ 1
  else if var eq mvar sf
    then subzero2(red sf,var)
    else if ordop(var,mvar sf)
      then sf ./ 1
      else begin
        scalar u,v;
        if dependsp(mvar sf,var)
          then <<
            u:=simp subst(0,var,mvar sf);
            if numr u
              then u:=!*exptsq(u,ldeg sf) >>
          else u:=((lpow sf .* 1) .+ nil) ./ 1;
        if null numr u
          then return subzero2(red sf,var);
        v:=subzero2(lc sf,var);
        if null numr v
          then return subzero2(red sf,var);
        return !*addsq(subzero2(red sf,var),
                       !*multsq(u,v))
        end;



symbolic procedure pvarsub(f,u,v);
% Changes u to v in polynomial f. No proper substitutions at all.
if atom f
  then f
  else if mvar f equal u
    then addf(multf(lc f,!*p2f mksp(v,ldeg f)),
              pvarsub(red f,u,v))
    else if ordop(u,mvar f)
      then f
      else addf(multf(pvarsub(lc f,u,v),!*p2f lpow f),
                pvarsub(red f,u,v));

endmodule;


module taylor;

% Author: James H. Davenport.

fluid '(const taylorasslist taylorvariable);

exports taylorform,taylorformp,taylorevaluate,return0,taylorplus,
         initialtaylorplus,taylorminus,initialtaylorminus,
         tayloroptminus,tayloroptplus,taylorctimes,initialtaylortimes,
         tayloroptctimes,taylorsqrtx,initialtaylorsqrtx,
         taylorquotient,initialtaylorquotient,taylorformersqrt,
         taylorbtimes,taylorformertimes,taylorformerexpt;

 symbolic procedure taylorform sq;
 if involvesf(denr sq,taylorvariable)
   then taylorformp list('quotient,tayprepf numr sq,tayprepf denr sq)
   else if 1 iequal denr sq
     then taylorformp tayprepf numr sq
     else taylorformp list('constanttimes,
                           tayprepf numr sq,
                           mk!*sq(1 ./ (denr sq)));
 % get division by a constant right.


 symbolic procedure taylorformp pf;
 if null pf
   then nil
   else if not dependsp(pf,taylorvariable)
     then taylorconst simp pf
     else begin
       scalar fn,initial,args;
       if atom pf
         then if pf eq taylorvariable
           then return taylorformp list ('expt,pf,1)
           else interr "False atom in taylorformp";
       % get 'x right as reduce shorthand for x**1.
       if taylorp pf
         then return pf;
       % cope with pre-expressed cases.
       % ***store-hack-1***
       % remove the (car pf eq 'sqrt) if more store is available.
       if (car pf eq 'sqrt) and
          (fn:=assoc(pf,taylorasslist))
         then go to lookupok;
       % look it up first.
       fn:=get(car pf,'taylorformer);
       if null fn
         then go to ordinary;
       fn:=apply(fn,list cdr pf);
       % ***store-hack-1***
       % remove the test if more store is available.
       if car pf eq 'sqrt
         then taylorasslist:=(pf.fn).taylorasslist;
       return fn;
       % cope with the special cases.
     ordinary:
       args:=mapcar(cdr pf,function taylorformp);
       fn:=get(car pf,'tayloropt);
       if null fn
         then go to nooptimisation;
       fn:=apply(fn,list args);
       if fn
         then go to ananswer;
       % an optimisation has been made.
     nooptimisation:
       fn:=get(car pf,'taylorfunction);
       if null fn
         then interr "No Taylor function provided";
       fn:=fn.args;
       % fn is now the "how to compute" code.
       initial:=get(car pf,'initialtaylorfunction);
       if null initial
         then interr "No initial Taylor function";
       initial:=apply(initial,
                      list for each u in cdr fn collect firstterm u);
       % the first term in the expansion.
       fn:=list(fn,(car initial).(car initial),initial);
     ananswer:
       % ***store-hack-1***
       % uncomment this if more store is available;
       % taylorasslist:=(pf.fn).taylorasslist;
       return fn;
     lookupok:
       % These PRINT statements can be enabled in order to test the
       % efficacy of the association list
 %      printc "Taylor lookup succeeded";
 %      superprint car fn;
 %      printc length taylorasslist;
       return cdr fn
       end;


 symbolic procedure taylorevaluate(texpr,n);
 if n<taylorfirst texpr
   then nil ./ 1
   else if n>taylorlast texpr
     then tayloreval2(texpr,n)
     else begin
       scalar u;
       u:=assoc(n,taylorlist texpr);
       if u
         then return cdr u
         else return tayloreval2(texpr,n)
       end;


 symbolic procedure tayloreval2(texpr,n);
 begin
   scalar u;
   % actually evaluates from scratch.
   u:=apply(taylorfunction texpr, list(n,texpr,cdr taylordefn texpr));
   if 'return0 eq taylorfunction texpr
     then return u;
   % no need to update with trivial zeroes.
   rplacd(cdr texpr,(n.u).taylorlist texpr);
   % update the association list.
   if n>taylorlast texpr
     then rplacd(taylornumbers texpr,n);
   % update the first/last pointer.
   return u
   end;


 symbolic procedure taylorconst sq;
 list('return0 . nil,0 . 0,0 . sq);


 symbolic procedure return0 (a,b,c);
 nil ./ 1;

 flag('(return0),'taylor);


 symbolic procedure firstterm texpr;
 begin
   scalar n,i;
   i:=taylorfirst texpr;
 trynext:
   n:=taylorevaluate(texpr,i);
   if numr n
     then return i.n;
   if i > 50
     then interr "Potentially zero Taylor series";
   i:=iadd1 i;
   rplaca(taylornumbers texpr,i);
   go to trynext
   end;


 symbolic procedure tayloroneterm u;
 % See if a Taylor expression has only one term.
  'return0 eq taylorfunction u and taylorfirst u=taylorlast u;


 % ***store-hack-1***;
 % uncomment this procedure if more store is available;
 % there is a smacro for this at the start of the file
 % for use if no store can be spared;
 %symbolic procedure tayshorten(save);
 %begin
 %  scalar z;
 %  % shortens the association list back to save,
 %    removing all the non-sqrts from it;
 %  while taylorasslist neq save do <<
 %    if caar taylorasslist eq 'sqrt
 %      then z:=(car taylorasslist).z;
 %    taylorasslist:=cdr taylorasslist >>;
 %  taylorasslist:=nconc(z,taylorasslist);
 %  return nil
 %  end;


 symbolic procedure tayprepf sf;
 if atom sf
   then sf
   else if atom mvar sf
     then taylorpoly makemainvar(sf,taylorvariable)
     else if null red sf
       then tayprept lt sf
       else list('plus,tayprept lt sf,tayprepf red sf);


 symbolic procedure tayprept term;
 if tdeg term = 1
   then if tc term = 1
     then tvar term
     else list('times,tvar term,tayprepf tc term)
   else if tc term = 1
     then list ('expt,tvar term,tdeg term)
     else list('times,list('expt,tvar term,tdeg term),
                    tayprepf tc term);


 symbolic procedure taylorpoly sf;
 % SF is a poly with MVAR = TAYLORVARIABLE.
 begin
   scalar tmax,tmin,u;
   tmax:=tmin:=ldeg sf;
   while sf do
     if atom sf or (mvar sf neq taylorvariable)
       then <<
         tmin:=0;
         u:=(0 . !*f2q sf).u;
         sf:=nil >>
       else <<
         u:=((tmin:=ldeg sf) . !*f2q lc sf) . u;
         sf:=red sf >>;
   return (list 'return0) . ((tmin.tmax).u)
   end;


 symbolic procedure taylorplus(n,texpr,args);
 mapply(function addsq,
        for each u in args collect taylorevaluate(u,n));


 symbolic procedure initialtaylorplus slist;
 begin
   scalar n,numlst;
   n:=mapply(function min2,mapcar(slist,function car));
   % the least of the degrees.
   numlst:=nil;
   while slist do <<
     if caar slist iequal n
       then numlst:=(cdar slist).numlst;
     slist:=cdr slist >>;
   return n.mapply(function addsq,numlst)
   end;


 put ('plus,'taylorfunction,'taylorplus);
 put ('plus,'initialtaylorfunction,'initialtaylorplus);


 symbolic procedure taylorminus(n,texpr,args);
 negsq taylorevaluate(car args,n);


 symbolic procedure initialtaylorminus slist;
 (caar slist).(negsq cdar slist);


 put('minus,'taylorfunction,'taylorminus);
 put('minus,'initialtaylorfunction,'initialtaylorminus);


 flag('(taylorplus taylorminus),'taylor);


 symbolic procedure tayloroptminus(u);
 if 'return0 eq taylorfunction car u
   then taylormake(taylordefn car u,
                   taylornumbers car u,
                   taylorneglist taylorlist car u)
   else if 'taylorctimes eq taylorfunction car u
     then begin
       scalar const;
       u:=car u;
       const:=caddr taylordefn u;
       % the item to be negated.
       const:=taylormake(taylordefn const,
                         taylornumbers const,
                         taylorneglist taylorlist const);
       return taylormake(list(taylorfunction u,
                              argof taylordefn u,
                              const),
                         taylornumbers u,
                         taylorneglist taylorlist u)
       end
     else nil;
 put('minus,'tayloropt,'tayloroptminus);


 symbolic procedure taylorneglist u;
 mapcar(u,function (lambda v;
                    (car v).(negsq cdr v)));



 symbolic procedure tayloroptplus args;
 begin
   scalar ret,hard,u;
   u:=args;
   while u do <<
     if 'return0 eq taylorfunction car u
       then ret:=(car u).ret
       else hard:=(car u).hard;
     u:=cdr u >>;
   if null ret or
       null cdr ret
     then return nil;
   ret:=mapply(function joinret,ret);
   if null hard
     then return ret;
   rplaca(args,ret);
   rplacd(args,hard);
    return nil
   end;
 put('plus,'tayloropt,'tayloroptplus);


 symbolic procedure joinret(u,v);
 begin
   scalar nums,a,b,al;
   nums:=(min2(taylorfirst u,taylorfirst v).
          max2(taylorlast u,taylorlast v));
   al:=nil;
   u:=taylorlist u;
   v:=taylorlist v;
   for i:=(car nums) step 1 until (cdr nums) do <<
     a:=assoc(i,u);
     b:=assoc(i,v);
     if a
       then if b
         then al:=(i.addsq(cdr a,cdr b)).al
         else al:=a.al
       else if b
         then al:=b.al  >>;
   return taylormake(list 'return0,nums,al)
   end;




 % the operator constanttimes
 % has two arguments (actually a list)
 % 1) a form dependent on the taylorvariable
 % 2) a form which is not.


 % the operator binarytimes has two arguments (actually a list)
   % but behaves like times otherwise.


 symbolic procedure taylorctimes(n,texpr,args);
 !*multsq(taylorevaluate(car args,n-(taylorfirst cadr args)),
        taylorevaluate(cadr args,taylorfirst cadr args));


 symbolic procedure initialtaylortimes slist;
 % Multiply the variable by the constant.
 ((caar slist)+(caadr slist)). !*multsq(cdar slist,cdadr slist);


 symbolic procedure tayloroptctimes u;
 if 'taylorctimes eq taylorfunction car u
   then begin
     scalar reala,const,iconst,degg;
     % we have nested multiplication.
     reala:=argof taylordefn car u;
     % the thing to be multiplied by the two constants.
     const:=car taylorlist cadr u;
     %the actual outer constant: deg.sq.
     iconst:=caddr taylordefn car u;
     %the inner constant.
     degg:=(taylorfirst iconst)+(car const);
     iconst:=list(taylordefn iconst,
                   degg.degg,
                   degg.!*multsq(cdar taylorlist iconst,cdr const));
     return list('taylorctimes,reala,iconst).
                 ((((taylorfirst car u) + (car const)).
                         ((taylorlast car u) + (car const))).
                  mapcar(taylorlist car u,function multconst))
     end
   else if 'return0 eq taylorfunction car u
     then begin
       scalar const;
       const:=car taylorlist cadr u;
       % the actual constant:deg.sq.
       u:=car u;
       return (taylordefn u).
                   ((((taylorfirst u)+car const).
                         ((taylorlast u)+car const)).
                   mapcar(taylorlist u,function multconst))
       end
     else nil;


 symbolic procedure multconst v;
 % Multiplies v by const in deg.sq form.
 ((car v)+(car const)) . !*multsq(cdr v,cdr const);


 put('constanttimes,'tayloropt,'tayloroptctimes);
 put('constanttimes,'simpfn,'simptimes);
 put('constanttimes,'taylorfunction,'taylorctimes);
 put('constanttimes,'initialtaylorfunction,'initialtaylortimes);


 symbolic procedure taylorbtimes(n,texpr,args);
 begin
   scalar answer,i,n1,n2;
   answer:= nil ./ 1;
   n1:=car firstterm car args;
   % the first term in one argument.
   n2:=car firstterm cadr args;
   % the first term in the other.
   for i:=n1 step 1 until (n-n2) do
     answer:=addsq(answer,!*multsq(taylorevaluate(cadr args,n-i),
                                       taylorevaluate(car args,i)));
   return answer
   end;




 put('binarytimes,'taylorfunction,'taylorbtimes);
 put('binarytimes,'initialtaylorfunction,'initialtaylortimes);
 put('binarytimes,'simpfn,'simptimes);


symbolic procedure taylorformertimes arglist;
begin
  scalar const,var,degg,wsqrt,negcount,u;
  negcount:=0;
  degg:=0;% the deggrees of any solitary x we may meet.
  const:=nil;
  var:=nil;
  wsqrt:=nil;
  while arglist do <<
    if dependsp(car arglist,taylorvariable)
      then if and(eqcar(car arglist,'expt),
                        cadar arglist eq taylorvariable,
                        numberp caddar arglist)
        then degg:=degg+caddar arglist
% removed JHD 21.8.86 - while it is anoptimisation,
% it runs the risk of proving that -1 = +1 by ignoring the
% number of "i" needed - despite the attempts we went to.
%        else if eqcar(car arglist,'sqrt)
%          then <<
%            u:=argof car arglist;
%            wsqrt:=u.wsqrt;
%            if minusq cdr firstterm taylorformp u
%              then negcount:=1+negcount >>
          else if car arglist eq taylorvariable
            then degg:=degg + 1
            else var:=(car arglist).var
      else const:=(car arglist).const;
    arglist:=cdr arglist >>;
  if wsqrt
    then if cdr wsqrt
      then var:=list('sqrt,prepsq simptimes wsqrt).var
      else var:=('sqrt.wsqrt).var;
  if var
    then var:=mapply(function (lambda u,v;
                               list('binarytimes,u,v)),var);
  % insert binary multiplications.
  negcount:=negcount/2;
  if onep cdr divide(negcount,2)
    then const:= (-1).const;
  % we had an odd number of (-1) from i*i.
  if const or (degg neq 0)
    then <<
      if const
        then const:=simptimes const
        else const:=1 ./ 1;
      const:=taylormake(list 'return0,degg.degg,list(degg.const));
      if null var
        then var:=const
        else var:=list('constanttimes,var,const) >>;
  return taylorformp var
  end;

put('times,'taylorformer,'taylorformertimes);




flag('(taylorbtimes taylorctimes taylorquotient),'taylor);
symbolic procedure taylorformerexpt arglist;
begin
  scalar base,expon;
  base:=car arglist;
  expon:=simpcar cdr arglist;
  if (denr expon neq 1) or
     (not numberp numr expon)
    then interr "Hard exponent";
  expon:=numr expon;
  if base neq taylorvariable
    then interr "Hard base";
  return list('return0 . nil,expon.expon,expon.(1 ./ 1))
  end;
put ('expt,'taylorformer,'taylorformerexpt);


symbolic procedure initialtaylorquotient slist;
(caar slist - caadr slist).!*multsq(cdar slist,!*invsq cdadr slist);


symbolic procedure taylorquotient(n,texpr,args);
begin
  % problem is texpr=b/c or c*texpr=b.
  scalar sofar,b,c,cfirst;
  b:=car args;
  c:=cadr args;
  cfirst:=taylorfirst c;
  sofar:=taylorevaluate(b,n+cfirst);
  for i:=taylorfirst texpr step 1 until n-1 do
    sofar:=addsq(sofar,!*multsq(taylorevaluate(texpr,i),
                              negsq taylorevaluate(c,n+cfirst-i)));
  return !*multsq(sofar,!*invsq taylorevaluate(c,cfirst))
  end;


put('quotient,'taylorfunction,'taylorquotient);
put('quotient,'initialtaylorfunction,'initialtaylorquotient);


symbolic procedure minusq sq;
if null sq
  then nil
  else if minusf numr sq
    then not minusf denr sq
     else minusf denr sq;



% This is wrapped round TAYLORFORMERSQRT2 in order to
% remove the innards of the SQRT from the asslist.
% note the precautions for nested SQRTs.

symbolic procedure taylorformersqrt arglist;
% ***store-hack-1***;
% Uncomment these lines if more store is available.
%begin
%  scalar z;
%  z:=taylorasslist;
%  if sqrtsintree(car arglist,taylorvariable)
%    then return taylorformersqrt2 arglist;
%  arglist:=taylorformersqrt2 arglist;
%  taylorasslist:=z;
%  return arglist
%  end;
%
%
%symbolic procedure taylorformersqrt2 arglist;
begin
  scalar f,realargs,ff,realsqrt;
  realargs:=taylorformp carx(arglist,'taylorformersqrt2);
  f:=firstterm realargs;
  if not evenp car f
    then interr "Extra sqrt substitution needed";
  if and(0 iequal car f,
         1 iequal numr cdr f,
         1 iequal denr cdr f)
    then return taylorformp list('sqrtx,realargs);
  % if it starts with 1 already then it is easy.
  ff:=- car f;
  ff:=list(list 'return0,ff.ff,ff.(!*invsq cdr f));
  % ff is the leading term in the expansion of realargs.
  realsqrt:=list('sqrtx,list('constanttimes,realargs,ff));
  ff:=(car f)/2;
  return taylorformp list('constanttimes,
                          realsqrt,
                          list(list 'return0,
                               ff.ff,
                               ff.(simpsqrtsq cdr f)))
  end;


put('sqrt,'taylorformer,'taylorformersqrt);


symbolic procedure initialtaylorsqrtx slist;
0 . (1 ./ 1);
% sqrt(1+ ...) = 1+....


symbolic procedure taylorsqrtx(n,texpr,args);
begin
  scalar sofar,i;
  sofar:=taylorevaluate(car args,n);
  % (1+.....+a(n)*x**n)**2
  % = ....+x**n*(2*a(n)+sum(0<i<n,a(i)*a(n-i))).
  % So a(n)=(coeff(x**n)-sum) /2.
  for i:=1 step 1 until (n-1) do
    sofar:=addsq(sofar,negsq !*multsq(taylorevaluate(texpr,i),
                                    taylorevaluate(texpr,n-i)));
  return multsq(sofar,1 ./ 2)
  end;


flag('(taylorsqrtx),'taylor);
put('sqrtx,'taylorfunction,'taylorsqrtx);
put('sqrtx,'initialtaylorfunction,'initialtaylorsqrtx);

endmodule;


module torsionb;

% Author: James H. Davenport.

fluid '(intvar nestedsqrts);

global '(!*tra !*trmin);

exports bound!-torsion;

symbolic procedure bound!-torsion(divisor,dof1k);
% Version 1 (see Trinity Thesis for difference).
begin
  scalar field,prime1,prime2,prime3,minimum,places;
  scalar non!-p1,non!-p2,non!-p3,curve,curve2,nestedsqrts;
  places:=for each u in divisor
            collect car u;
  curve:=getsqrtsfromplaces places;
  if nestedsqrts
    then rederr "Not yet implemented"
    else curve2:=curve;
  for each u in places do begin
    u:=rfirstsubs u;
    if eqcar(u,'quotient) and cadr u = 1
      then return;
    u:=substitutesq(simp u,list(intvar . 0));
    field:=union(field,sqrtsinsq(u,nil));
    u:=list(intvar . prepsq u);
    for each v in curve2 do
      field:=union(field,sqrtsinsq(substitutesq(v,u),nil));
    end;
  prime1:=2;
  while null (non!-p1:=good!-reduction(curve,dof1k,field,prime1)) do
    prime1:=nextprime prime1;
  prime2:=nextprime prime1;
  while null (non!-p2:=good!-reduction(curve,dof1k,field,prime2)) do
    prime2:=nextprime prime2;
  prime3:=nextprime prime2;
  while null (non!-p3:=good!-reduction(curve,dof1k,field,prime3)) do
    prime3:=nextprime prime3;
  minimum:=fix sqrt float(non!-p1*non!-p2*non!-p3);
  minimum:=min(minimum,non!-p1*max!-power(prime1,min(non!-p2,non!-p3)));
  minimum:=min(minimum,non!-p2*max!-power(prime2,min(non!-p1,non!-p3)));
  minimum:=min(minimum,non!-p3*max!-power(prime3,min(non!-p2,non!-p1)));
  if !*tra or !*trmin then <<
    princ "Torsion is bounded by ";
    printc minimum >>;
  return minimum
  end;


symbolic procedure max!-power(p,n);
% Greatest power of p not greater than n.
begin scalar ans;
  ans:=1;
  while ans<=n do
    ans:=ans*p;
  ans:=ans/p;
  end;


symbolic procedure good!-reduction(curve,dof1k,field,prime);
begin
  scalar u;
  u:=algebraic!-factorise(prime,field);
  interr "Good reduction not finished";
  end;

endmodule;


module wstrass;

% Author: James H. Davenport.

fluid '(!*backtrace
        intvar
        listofallsqrts
        listofnewsqrts
        magiclist
        previousbasis
        sqrt!-intvar
        sqrtflag
        sqrts!-in!-integrand
        taylorasslist
        taylorvariable
        thisplace
        zlist);

global '(!*tra !*trmin coates!-fdi);

exports simpwstrass,weierstrass!-form,gcdn,sqrtsinplaces,
        makeinitialbasis,mkvec,completeplaces,integralbasis,
        normalbasis,mksp,multsq,xsubstitutesq,taylorform,taylorevaluate,
        coatessolve,checkpoles,substitutesq,removecmsq,printsq,interr,
        terpri!*,printplace,finitise,fractional!-degree!-at!-infinity,
        !*multsq,fdi!-print,fdi!-upgrade,fdi!-revertsq,simp,newplace,
        xsubstitutep,sqrtsinsq,removeduplicates,!*exptf,!*multf,
        !*multsq,!*q2f,mapvec,upbv,coates!-lineq,addsq,!*addsq;

symbolic procedure simpwstrass u;
begin
  scalar intvar,sqrt!-intvar,taylorvariable,taylorasslist;
  scalar listofallsqrts,listofnewsqrts;
  scalar sqrtflag,sqrts!-in!-integrand,tt,u;
  tt:=readclock();
  sqrtflag:=t;
  taylorvariable:=intvar:=car u;
  sqrt!-intvar:=mvar !*q2f simpsqrti intvar;
  u:=for each v in cdr u
            collect simp!* v;
  sqrts!-in!-integrand:=sqrtsinsql(u,intvar);
  u:=errorset('(weierstrass!-form sqrts!-in!-integrand),
              t,!*backtrace);
  if atom u
    then return u
    else u:=car u;
  printc list('time,'taken,readclock()-tt,'milliseconds);
  printc "New x value is:";
  printsq car u;
  u:=cdr u;
  printc "New y value is:";
  printsq car u;
  u:=cdr u;
  printc "Related by the equation";
  printsq car u;
  return car u
  end;
put('wstrass,'simpfn,'simpwstrass);

symbolic procedure weierstrass!-form sqrtl;
begin
  scalar sqrtl2,u,x2,x1,vec,a,b,c,d,lhs,rhs;
  if !*tra or !*trmin then <<
    printc "Find weierstrass form for elliptic curve defined by:";
    for each u in sqrtl do
      printsq simp u >>;
  sqrtl2:=sqrts!-at!-infinity sqrtl;
  sqrtl2:=append(car sqrtl2,
                 for each u in cdr sqrtl2 collect
                   u.u);
          % one of the places lying over infinity
          % (after deramification as necessary).
  x2:=coates!-wstrass(list sqrtl2,list(-3),intvar);
    % Note that we do not multiply by the MULTIPLICITY!-FACTOR
    % since we genuinely want a pole of order -3 irrespective
    % of any ramification problems.
  if !*tra then <<
    printc "Function with pole of order 3 (x2) is:";
    printsq x2 >>;
  x1:=coates!-wstrass(list sqrtl2,list(-2),intvar);
  if !*tra then <<
    printc "Function with pole of order 2 (x1) is:";
    printsq x1 >>;
  vec:=mkvec list(1 ./ 1,
                  x1,
                  x2,
                  !*multsq(x1,x1),
                  !*multsq(x2,x2),
                  !*multsq(x1,!*multsq(x1,x1)),
                  !*multsq(x1,x2));
  u:=!*lcm!*(!*exptf(denr x1,3),!*multf(denr x2,denr x2)) ./ 1;
  for i:=0:6 do
    putv(vec,i,!*q2f !*multsq(u,getv(vec,i)));
  if !*tra then <<
    printc "List of seven functions in weierstrass!-form:";
    mapvec(vec,function printsf) >>;
  vec:=wstrass!-lineq vec;
% printsq(addsq(getv(vec,0),addsq(!*multsq(getv(vec,1),x1),
%               addsq(!*multsq(getv(vec,2),x2),
%                     addsq(!*multsq(getv(vec,3),!*multsq(x1,x1)),
%                           addsq(!*multsq(getv(vec,4),!*multsq(x2,x2)),
%                              addsq(!*multsq(getv(vec,5),exptsq(x1,3)),
%                                       !*multsq(getv(vec,6),
%                                               !*multsq(x1,x2)))))))));
  x2:=!*addsq(!*multsq(!*multsq(2 ./ 1,getv(vec,4)),x2),
              addsq(!*multsq(x1,getv(vec,6)),
                    getv(vec,2)));
  putv(vec,4,!*multsq(-4 ./ 1,getv(vec,4)));
  a:=!*multsq(getv(vec,4),getv(vec,5));
  b:=!*addsq(!*multsq(getv(vec,6),getv(vec,6)),
             !*multsq(getv(vec,3),getv(vec,4)));
  c:=!*addsq(!*multsq(2 ./ 1,!*multsq(getv(vec,2),getv(vec,6))),
             !*multsq(getv(vec,1),getv(vec,4)));
  d:=!*addsq(!*multsq(getv(vec,2),getv(vec,2)),
             !*multsq(getv(vec,0),getv(vec,4)));
  lhs:=!*multsq(x2,x2);
  rhs:=addsq(d,!*multsq(x1,
                        addsq(c,!*multsq(x1,addsq(b,!*multsq(x1,a))))));
  if lhs neq rhs then <<
    printsq lhs;
    printsq rhs;
    interr "Previous two unequal - consistency failure 1" >>;
  u:=!*lcm!*(!*lcm!*(denr a,denr b),!*lcm!*(denr c,denr d));
  if u neq 1 then <<
    % for now use u**2 whereas we should be using the least
    % square greater than u**2 (does it really matter).
    x2:=!*multsq(x2,u ./ 1);
    u:=!*multf(u,u) ./ 1;
    a:=!*multsq(a,u);
    b:=!*multsq(b,u);
    c:=!*multsq(c,u);
    d:=!*multsq(d,u) >>;
  if (numr b) and not (quotf(numr b,3)) then <<
    % multiply all through by 9 for the hell of it.
    x2:=multsq(3 ./ 1,x2);
    u:=9 ./ 1;
    a:=multsq(a,u);
    b:=multsq(b,u);
    c:=multsq(c,u);
    d:=multsq(d,u) >>;
  x2:=!*multsq(x2,a);
  x1:=!*multsq(x1,a);
  c:=!*multsq(a,c);
  d:=!*multsq(!*multsq(a,a),d);
  lhs:=!*multsq(x2,x2);
  rhs:=addsq(d,!*multsq(x1,addsq(c,!*multsq(x1,addsq(b,x1)))));
  if lhs neq rhs then <<
    printsq lhs;
    printsq rhs;
    interr "Previous two unequal - consistency failure 2" >>;
  b:=quotf(numr b,3) ./ 1;
  x1:=!*addsq(x1,b);
  d:=!*addsq(d,!*addsq(multsq(2 ./ 1,!*multsq(b,!*multsq(b,b))),
                       negsq !*multsq(c,b)));
  c:=!*addsq(c,!*multsq((-3) ./ 1,!*multsq(b,b)) );
% b:=nil ./ 1;   % not used again.
  if !*tra then <<
    printsq x2;
    printsq x1;
    printc "with coefficients";
    printsq c;
    printsq d;
    rhs:=!*addsq(d,
                 !*addsq(!*multsq(c,x1),
                         !*multsq(x1,!*multsq(x1,x1)) ));
    lhs:=!*multsq(x2,x2);
    if lhs neq rhs then <<
      printsq lhs;
      printsq rhs;
      interr "Previous two unequal - consistency failure 3" >> >>;
    return weierstrass!-form1(c,d,x1,x2)
   end;

symbolic procedure weierstrass!-form1(c,d,x1,x2);
 begin scalar b,u;
  u:=gcdf(numr c,numr d);
    % We will reduce by anything whose square divides C
    % and whose cube divides D.
  if not numberp u then begin
    scalar cc,dd;
    u:=jsqfree(u,mvar u);
    u:=cdr u;
    if null u
      then return;
      % We found no repeated factors.
    for each v in u do
      for each w in v do
        while (cc:=quotf(numr c,multf(w,w))) and
              (dd:=quotf(numr d,exptf(w,3)))
          do <<
            c:=cc ./ 1;
            d:=dd ./ 1;
            x1:=!*multsq(x1,1 ./ w);
            x2:=!*multsq(x2,1 ./ multf(w,simpsqrt2 w)) >>;
    u:=gcdn(algint!-numeric!-content numr c,
            algint!-numeric!-content numr d)
    end;
  b:=2;
 while not (b*b) > u do begin
    scalar nc,nd,uu;
    nc:=0;
    while zerop cdr (uu:=divide(u,b)) do <<
      nc:=nc+1;
      u:=car uu >>;
    if nc < 2
      then go to next;
    uu:=algint!-numeric!-content numr d;
    nd:=0;
    while zerop cdr (uu:=divide(uu,b)) do <<
      nd:=nd+1;
      uu:=car uu >>;
    if nd < 3
      then go to next;
    nc:=min(nc/2,nd/3);
      % re-normalise by b**nc.
    uu:=b**nc;
    c:=multsq(c,1 ./ (uu**2));
    d:=multsq(d,1 ./ (uu**3));
    x1:=multsq(x1,1 ./ uu);
    x2:=multsq(x2,1 ./ (uu*b**(nc/2)) );
    if not evenp nc
      then x2:=!*multsq(x2,!*invsq simpsqrti b);
next:
    b:=nextprime(b)
    end;
  u:=!*kk2q intvar;
  u:=addsq(addsq(d,multsq(c,u)),exptsq(u,3));
  if !*tra or !*trmin then <<
    printc "Standard form is y**2 = ";
    printsq u >>;
  return list(x1,x2,simpsqrtsq u)
  end;

symbolic procedure sqrts!-at!-infinity sqrtl;
begin
  scalar inf,hack,sqrtl2,repeating;
  hack:=list list(intvar,'expt,intvar,2);
  inf:=list list(intvar,'quotient,1,intvar);
  sqrtl2:=list sqrt!-intvar;
  while sqrt!-intvar member sqrtl2 do <<
    if repeating
      then inf:=append(inf,hack);
    newplace inf;
    sqrtl2:=for each v in sqrtl conc
      sqrtsinsq(xsubstitutep(v,inf),intvar);
    repeating:=t >>;
  sqrtl2:=removeduplicates sqrtl2;
  return inf.sqrtl2
  end;

symbolic procedure coates!-wstrass(places,mults,x);
begin
  scalar thisplace,u,finite!-hack,save,places2,mults2;
  if !*tra or !*trmin then <<
    princ "Find function with zeros of order:";
    printc mults;
    if !*tra then
      princ " at ";
    terpri!*(t);
    if !*tra then
      mapc(places,function printplace) >>;
%  finite!-hack:=placesindiv places;
    % FINITE!-HACK is a list of all the substitutors in PLACES;
%  u:=removeduplicates sqrtsintree(finite!-hack,x,nil);
%  if !*tra then <<
%    princ "Sqrts on this curve:";
%    terpri!*(t);
%    superprint u >>;
%  algnos:=removeduplicates mapcar(places,function basicplace);
%  if !*tra then <<
%    printc "Algebraic numbers where residues occur:";
%    superprint algnos >>;
  finite!-hack:= finitise(places,mults);
    % returns list (places,mults,power of x to remove.
  places2:=car finite!-hack;
  mults2:=cadr finite!-hack;
  finite!-hack:=list(places,mults,caddr finite!-hack);
  coates!-fdi:=fractional!-degree!-at!-infinity u;
  if coates!-fdi iequal 1
    then return !*multsq(wstrassmodule(places2,mults2,x,finite!-hack),
                         !*p2q mksp(x,caddr finite!-hack));
  if !*tra
    then fdi!-print();
  places2:=mapcar(places2,function fdi!-upgrade);
  save:=taylorasslist;
  u:=wstrassmodule(places2,
                  mapcar(mults2,function (lambda u;u*coates!-fdi)),
                  x,finite!-hack);
  taylorasslist:=save;
  u:=fdi!-revertsq u;
  return !*multsq(u,!*p2q mksp(x,caddr finite!-hack))
  end;

symbolic procedure wstrassmodule(places,mults,x,finite!-hack);
begin
  scalar pzero,mzero,u,v,basis,sqrts,magiclist,mpole,ppole;
    % MAGICLIST holds the list of extra unknowns created in JHDSOLVE
    % which must be found in CHECKPOLES (calling FINDMAGIC).
  sqrts:=sqrtsinplaces places;
  if !*tra then <<
    princ "Sqrts on this curve:";
    superprint sqrts >>;
  u:=places;
  v:=mults;
  while u do <<
    if 0<car v
      then <<
        mzero:=(car v).mzero;
        pzero:=(car u).pzero >>
      else <<
        mpole:=(car v).mpole;
        ppole:=(car u).ppole >>;
    u:=cdr u;
    v:=cdr v >>;
  basis:=mkvec makeinitialbasis ppole;
  u:=completeplaces(ppole,mpole);
  basis:=integralbasis(basis,car u,cdr u,x);
  basis:=normalbasis(basis,x,0);
  u:=coatessolve(mzero,pzero,basis,force!-pole(basis,finite!-hack));
    % This is the list of special constraints needed
    % to force certain poles to occur in the answer.
 previousbasis:=nil;
  if atom u
    then return u;
  v:= checkpoles(list u,places,mults);
  if null v
    then return 'failed;
  if not magiclist
    then return u;
  u:=removecmsq substitutesq(u,v);
  % Apply the values from FINDMAGIC.
  if !*tra or !*trmin then <<
    printc "Function is";
    printsq u >>;
  magiclist:=nil;
  if checkpoles(list u,places,mults)
    then return u
    else interr "Inconsistent checkpoles"
  end;

symbolic procedure force!-pole(basis,finite!-hack);
begin
  scalar places,mults,u,ans;
  places:=car finite!-hack;
  mults:=cadr finite!-hack;
  finite!-hack:=caddr finite!-hack;
  u:=!*p2q mksp(intvar,finite!-hack);
  basis:=for each v in basis collect multsq(u,v);
  while places do <<
    u:=for each v in basis collect
       taylorevaluate(taylorform xsubstitutesq(v,car places),
                      car mults);
    mults:=cdr mults;
    places:=cdr places;
    ans:=u.ans >>;
  return ans
  end;

symbolic procedure wstrass!-lineq vec;
begin
  scalar zlist,powlist,m,rightside,v;
  scalar zero,one;
  zero:=nil ./ 1;
  one:=1 ./ 1;
  for i:=0:6 do
    zlist:=varsinsf(getv(vec,i),zlist);
  zlist:=intvar . findzvars(zlist,nil,intvar,nil);
  for i:=0:6 do
    putv(vec,i,f2df getv(vec,i));
  for i:=0:6 do
    for each u in getv(vec,i) do
      if not ((tpow u) member powlist)
        then powlist:=(tpow u).powlist;
  m:=for each u in powlist collect begin
    scalar v;
    v:=mkvect 6;
    for i:=0:6 do
      putv(v,i,(lambda u;
                  if null u
                    then zero
                    else tc u)
                 assoc(u,getv(vec,i)));
    return v
    end;
  v:=mkvect 6;
  for i:=0:6 do
    putv(v,i,zero);
  putv(v,4,one);
    % we know that coefficient e is non-zero.
  m:=mkvec (v.m);
  v:=upbv m;
  rightside:=mkvect v;
  putv(rightside,0,one);
  for i:=1:v do
    putv(rightside,i,zero);
  return coates!-lineq(m,rightside)
  end;

% This is same as NUMERIC!-CONTENT in the EZGCD module, but is included
% here so that that module doesn't need to be loaded.

symbolic procedure algint!-numeric!-content form;
 %Find numeric content of non-zero polynomial.
   if domainp form then abs form
   else if null red form then algint!-numeric!-content lc form
   else begin
     scalar g1;
     g1 := algint!-numeric!-content lc form;
     if not (g1=1)
       then g1 := gcddd(g1,algint!-numeric!-content red form);
     return g1
   end;
 
endmodule;


module zmodule;

% Author: James H. Davenport.

fluid '(!*galois
        basic!-listofallsqrts
        basic!-listofnewsqrts
        commonden
        gaussiani
        listofallsqrts
        listofnewsqrts
        sqrt!-places!-alist
        taylorasslist);

global '(!*tra !*trfield !*trmin);

exports zmodule;
imports !*multf,sqrtsinsql,sortsqrts,simp,!*q2f,actualsimpsqrt,printsf;
imports prepf,substitutesq,printsq,mapply,!*multsq,mkilist;
imports mkvecf2q,mkvec,mkidenm,invsq,multsq,negsq,addsq,gcdn;
imports !*invsq,prepsq;

symbolic procedure zmodule(w);
begin
  scalar reslist,denlist,u,commonden,basis,p1,p2,hcf;
  % w is a list of elements (place.residue)=sq.
  for each v in w do <<
    u:=cdr v;
    reslist:=u.reslist;
    denlist:=(denr u).denlist >>;
  basis:=sqrtsinsql(reslist,nil);
  if null u or null cdr u or !*galois
    then go to nochange;
  reslist:=check!-sqrts!-dependence(reslist,basis);
  denlist:=for each u in reslist
             collect denr u;
nochange:
 commonden:=mapply(function(lambda u,v;
                      multf(u,quotf(v,gcdf(u,v)))),denlist)./1;
  u:=nil;
  for each v in reslist do
    u:=(numr !*multsq(v,commonden)).u;
  reslist:=u;
    % We have effectively reserves RESLIST twice,
    % so it is in the corect order.
  u:=bexprn(reslist);
  basis:=car u;
  reslist:=cdr u;
  denlist:=nil;
  while basis do <<
    p1:=reslist;
    p2:=w;
    u:=nil;
    hcf:=0;
    while p1 do <<
      if 0 neq caar p1
        then  <<
          u:=((caar p2).(caar p1)).u;
          hcf:=gcdn(hcf,caar p1) >>;
      p1:=cdr p1;
      p2:=cdr p2 >>;
    if hcf neq 1
     then u:=for each uu in u collect
               (car uu). ( (cdr uu) / hcf);
    denlist:=(prepsq !*multsq(car basis,
                              multsq(!*f2q hcf,!*invsq commonden))
                  .u).denlist;
    basis:=cdr basis;
    reslist:=mapcar(reslist,function cdr) >>;
  return denlist
  end;


symbolic procedure bexprn(wlist);
begin
  scalar basis,replist,w,w2,w3,p1,p2;
  % wlist is a list of sf.
  w:=reverse wlist;
  replist:=nil;
  while w do <<
    w2:=sf2df car w;
    % now ensure that all elements of w2 are in the basis.
    w3:=w2;
    while w3 do <<
      % caar is the sf,cdar a its coefficient.
      if not member(caar w3,basis)
        then <<
          basis:=(caar w3).basis;
          replist:=mapcons(replist,0) >>;
          % adds car w3 to basis.
      w3:=cdr w3 >>;
    replist:=mkilist(basis,0).replist;
    % builds a new zero representation.
    w3:=w2;
    while w3 do <<
      p1:=basis;
      p2:=car replist;
      %the list for this element.
      while p1 do <<
        if caar w3 = car p1
          then rplaca(p2,cdar w3);
        p1:=cdr p1;
        p2:=cdr p2 >>;
      w3:=cdr w3 >>;
    w:=cdr w >>;
  return mkbasis(basis,replist)
  end;


symbolic procedure mkbasis(basis,reslist);
begin
  scalar row,nbasis,nreslist,u,v;
  basis:=for each u in basis collect !*f2q u;
  % basis is a list of sq's
  % reslist is a list of representations in the form
  % ( (coeff1 coeff2 ...)    ...).
  nreslist:=mkilist(reslist,nil);
  % initialise our list-of-lists.
  trynewloop:
  row:=mapcar(reslist,function car);
  reslist:=mapcar(reslist,function cdr);
  if obvindep(row,nreslist)
    then u:=nil
    else u:=lindep(row,nreslist);
  if u
    then <<
      % u contains the numbers with which to add this new item into the
      % basis.
      v:=nil;
      while nbasis do <<
        v:=addsq(car nbasis,!*multsq(car basis,car u)).v;
        nbasis:=cdr nbasis;
        u:=cdr u >>;
      nbasis:=reversewoc v >>
    else <<
      nreslist:=pair(row,nreslist);
      nbasis:=(car basis).nbasis
      >>;
  basis:=cdr basis;
  if basis
   then go to trynewloop;
  return nbasis.nreslist
  end;


symbolic procedure obvindep(row,matrx);
  % True if row is obviously linearly independent of the
  % Rows of the matrix.
begin scalar u;
  if null car matrx
    then return t;
  % no matrix => no dependence.
nexttry:
  if null row
    then return nil;
  if 0 iequal car row
    then go to nouse;
  u:=car matrx;
testloop:
  if 0 neq car u
    then go to nouse;
  u:=cdr u;
  if u
    then go to testloop;
  return t;
nouse:
  row:=cdr row;
  matrx:=cdr matrx;
  go to nexttry
  end;


symbolic procedure sf2df sf;
if null sf
   then nil
   else if numberp sf
    then (1 . sf).nil
    else begin
      scalar a,b,c;
      a:=sf2df lc sf;
      b:=(lpow sf .* 1) .+ nil;
      while a do <<
        c:=(!*multf(caar a,b).(cdar a)).c;
        a :=cdr a >>;
      return nconc(c,sf2df red sf)
      end;





symbolic procedure check!-sqrts!-dependence(sql,sqrtl);
% Resimplifies the list of SQs SQL,
% allowing for all dependencies among the
% sqrts in SQRTl.
begin
  scalar !*galois,sublist,sqrtsavelist,changeflag;
  sqrtsavelist:=listofallsqrts.listofnewsqrts;
  listofnewsqrts:=list mvar gaussiani;
  listofallsqrts:=list((argof mvar gaussiani) . gaussiani);
  !*galois:=t;
  for each u in sortsqrts(sqrtl,nil) do begin
    scalar v,uu;
    uu:=!*q2f simp argof u;
    v:=actualsimpsqrt uu;
    listofallsqrts:=(uu.v).listofallsqrts;
    if domainp v or mvar v neq u
      then <<
        if !*tra or !*trfield then <<
           printc u;
           printc "re-expressed as";
           printsf v >>;
        v:=prepf v;
        sublist:=(u.v) . sublist;
        changeflag:=t >>
    end;
  if changeflag then <<
    sql:=for each u in sql collect
           substitutesq(u,sublist);
    taylorasslist:=nil;
    sqrt!-places!-alist:=nil;
    basic!-listofallsqrts:=listofallsqrts;
    basic!-listofnewsqrts:=listofnewsqrts;
    if !*tra or !*trmin then <<
      printc "New set of residues are";
      mapc(sql,function printsq) >> >>
    else <<
      listofallsqrts:=car sqrtsavelist;
      listofnewsqrts:=cdr sqrtsavelist >>;
  return sql
  end;



symbolic procedure lindep(row,matrx);
  begin
    scalar m,mm,n,i,j,k,u,v,inverse,rowsinuse,failure;
    % Inverse is the answer from the "gaussian elimination"
    % we are doing.
    % Rowsinuse has nil for rows with no "awkward" non-zero entries.
    mm:=length car matrx;
    m:=isub1 mm;
    n:=isub1 length matrx;
    % n=length row.
    row:=mkvecf2q row;
    matrx:=mkvec mapcar(matrx,function mkvecf2q);
    inverse:=mkidenm mm;
    rowsinuse:=mkvect m;
    failure:=t;
    % initialisation complete.
    for i:=0 step 1 until n do begin
      % try to kill off i'th elements in each row.
      u:=nil;
      for j:=0 step 1 until m do <<
        % try to find a  pivot element.
        if  (null u) and
            (null getv(rowsinuse,j)) and
            (numr getv(getv(matrx,i),j))
          then u:=j >>;
      if null u
        then go to nullu;
      putv(rowsinuse,u,t);
      % it is no use trying this again ---
      % u is our pivot element.
      if u iequal m
        then go to nonetokill;
      for j:=iadd1 u step 1 until m do
        if numr getv(getv(matrx,i),j)
          then <<
            v:=negsq multsq(getv(getv(matrx,i),j),
                            invsq getv(getv(matrx,i),u));
            for k:=0 step 1 until mm do
              putv(getv(inverse,k),j,
                addsq(getv(getv(inverse,k),j),
                  multsq(v,getv(getv(inverse,k),u))));
            for k:=0 step 1 until n do
              putv(getv(matrx,k),j,
                addsq(getv(getv(matrx,k),j),
                  multsq(v,getv(getv(matrx,k),u)))) >>;
      %we have now pivoted throughout matrx.
    nonetokill:
      % now do the same in row if necessary.
      if null numr getv(row,i)
        then go to norowop;
      v:=negsq multsq(getv(row,i),
                 invsq getv(getv(matrx,i),u));
      for k:=0 step 1 until mm do
        putv(getv(inverse,k),mm,
          addsq(getv(getv(inverse,k),mm),
            multsq(v,getv(getv(inverse,k),u))));
      for k:=0 step 1 until n do
        putv(row,k,addsq(getv(row,k),
                     multsq(v,getv(getv(matrx,k),u))));
      u:=nil;
      for k:=0 step 1 until n do
        if numr getv(row,k)
          then u:=t;
      % if u is null then row is all 0.
      if null u
        then <<
          n:=-1;
          failure:=nil >>;
    norowop:
      if !*tra then <<
        princ "At end of cycle";
        printc row;
        printc matrx;
        printc inverse >>;
      return;
    nullu:
      % there is no pivot for this u.
      if numr getv(row,i)
        then n:=-1;
        % this element cannot be killed.
      end;
    if failure
      then return nil;
    v:=nil;
    for i:=0 step 1 until m do
      v:=(negsq getv(getv(inverse,m-i),mm)).v;
    return v
    end;

endmodule;


end;

Added r33/anum.red version [15ab74d356].







































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
module arnum;  % Support for algebraic rationals.

% Author: Eberhard Schruefer.

global '(domainlist!* arbase!* arvars!* repowl!* curdefpol!*
         !*acounter!* !*extvar!* reexpressl!*);

!*acounter!* := 0;    %counter for number of extensions;

!*extvar!* := 'a;     %default print character for primitive element;

fluid '(!*arnum dmode!* !*exp !*minimal !*reexpress !*arinv !*arquot
        !*arq alglist!*);

global '(timer timef);

switch arnum;

timer:=timef:=0;

domainlist!*:=union('(!:ar!:),domainlist!*);

symbolic procedure defpoly u;
   begin
     if null(dmode!* eq '!:ar!:) then on 'arnum;
     for each j in u do
         (if eqexpr j then
          if cadr j=0 then mkextension caddr j else
          if caddr j=0 then mkextension cadr j else
             rederr list(cadr j,"=",caddr j,
              "  is not a proper defining polynomial")
          else mkextension j)
   end;

rlistat '(defpoly);

symbolic procedure mkextension u;
   if null curdefpol!* then initalgnum u
    else begin scalar !*exp;
            !*exp := t;
            primitive!_elem !*a2f u
         end;

symbolic procedure initalgnum u;
   begin scalar dmode!*,alglist!*,!*exp;
     !*exp := t;
     arbase!* := nil;
     u := numr simp0 u;
     if lc u neq 1 then u := monicize u;
     % rederr("defining polynomial must be monic");
     curdefpol!* := u;
     for j:=0:(ldeg u-1) do
         arbase!* := (if j=0 then 1
                       else mksp(mvar u,j)) . arbase!*;
     arvars!* := mvar u . arvars!*;
     mk!-algebraic!-number!-vars list mvar u;
     repowl!* := lpow u . negf red u
   end;

symbolic procedure put!-current!-representation(u,v);
   put(u,'currep,v);

symbolic procedure get!-current!-representation u;
   get(u,'currep);

symbolic procedure mkdar u;
   %puts any algebraic number domain element into its tagged form.
   %updated representations (through field extension) are accessed here;
   ((if x then x else '!:ar!: . !*k2f u) ./ 1)
    where x = get!-current!-representation u;

symbolic procedure release u;
   %Undeclares elements of list u to be algebraic numbers;
   for each j in u do
     if atom j then remprop(j,'idvalfn)
      else remprop(car j,'opvalfn);

symbolic procedure mk!-algebraic!-number!-vars u;
   %Declares elements of list u to be algebraic numbers;
   for each j in u do
     if atom j then put(j,'idvalfn,'mkdar)
      else put(car j,'opvalfn,'mkdar);

symbolic procedure uncurrep u;
   for each j in u do remprop(j,'currep);

symbolic procedure update!-extension u;
   %Updates representation of elements in list u;
    for each j in u do
       ((x and put(j,'currep,numr simp prepf cdr x))
      where x = get(j,'currep));

symbolic procedure express!-in!-arvars u;
   %u is an untagged rational number. Result is equivalent algebraic
   %number expressed in input variables.
   rederr "switch reexpress not yet implemented";
%  begin scalar x;
%    for each j in reexpressl!* do
%        x := extmult(extadd(...,j),x);
%    return solve!-for!-arvars x
%  end;

symbolic procedure mkreexpressl;
   %Sets up the homogenous part of the system to be solved for
   %expressing a primitive element expression in terms of the
   %input variables.
   reexpressl!* := nil;
%  begin scalar x;
%


put('reexpress,'simpfg,'((t (mkreexpressl))
                         (nil (setq reexpressl!* nil))));

%*** tables for algebraic rationals ***;

flag('(!:ar!:),'field);
put('arnum,'tag,'!:ar!:);
put('!:ar!:,'dname,'arnum);
put('!:ar!:,'i2d,'!*i2ar);
%put('!:ar!:,'!:rn!:,'ar2rn);
put('!:ar!:,'!:ft!:,'arconv);
put('!:ar!;,'!:bf!:,'arconv);
put('!:ar!:,'!:mod!:,'arconv);
put('!:ar!:,'minusp,'arminusp!:);
put('!:ar!:,'zerop,'arzerop!:);
put('!:ar!:,'onep,'aronep!:);
put('!:ar!:,'plus,'arplus!:);
put('!:ar!:,'difference,'ardifference!:);
put('!:ar!:,'times,'artimes!:);
put('!:ar!:,'quotient,'arquotient!:);
put('!:ar!:,'factorfn,'arfactor!:);
put('!:ar!:,'rationalizefn,'arrationalize!:);
put('!:ar!:,'prepfn,'arprep!:);
put('!:ar!:,'intequivfn,'arintequiv!:);
put('!:ar!:,'prifn,'arprn!:);
put('!:rn!:,'!:ar!:,'rn2ar);
flag('(!:ar!:),'ratmode);

symbolic procedure rn2ar u;
   '!:ar!: . if cddr u=1 then cadr u else u;

symbolic procedure ar2rn u;
   if cadr u eq '!:rn!: then cdr u
    else if numberp cdr u then '!:rn!: . (cdr u . 1)
    else rederr list "conversion to rational not possible";

symbolic procedure !*i2ar u;
   '!:ar!: . u;

symbolic procedure arconv u;
   rederr list("conversion between current extension and",
               get(car u,'dname),"not possible");


symbolic procedure arminusp!: u;
   minusf cdr u;

symbolic procedure arzerop!: u;
   null cdr u;

symbolic procedure aronep!: u;
   cdr u=1;

symbolic procedure arintequiv!: u;
   if numberp cdr u then cdr u
    else if (cadr u eq '!:rn!:) and (cdddr u=1) then caddr u
    else nil;

smacro procedure mkar u;
 '!:ar!: . u;

symbolic procedure arplus!:(u,v);
   begin scalar dmode!*,!*exp;
     !*exp := t;
     return mkar addf(cdr u,cdr v)
   end;

symbolic procedure ardifference!:(u,v);
   begin scalar dmode!*,!*exp;
     !*exp := t;
     return mkar addf(cdr u,negf cdr v)
   end;

symbolic procedure artimes!:(u,v);
   begin scalar dmode!*,!*exp;
     !*exp := t;
     return mkar reducepowers multf(cdr u,cdr v)
   end;

symbolic procedure arquotient!:(u,v);
   begin scalar r,s,y,z,dmode!*,!*exp;
     !*exp := t;
     if domainp cdr v then
          return mkar multd(<<dmode!* := '!:rn!:;
                              s := !:recip cdr v;
                              dmode!* := nil;
                              s>>,cdr u);
     if !*arinv then
        return mkar reducepowers multf(cdr u,arinv cdr v);
     if !*arquot then return mkar arquot(cdr v,cdr u);
     if !*arq then return mkar reducepowers multf(u,arquot1 v);
     r := ilnrsolve(mkqmatr cdr v,mkqcol cdr u);
     z := arbase!*;
     dmode!* := '!:rn!:;
     for each j in r do
         s := addf(multf(int!-equiv!-chk car j,
                       <<y := if atom car z then 1 else !*p2f car z;
                         z := cdr z; y>>),s);
     return mkar s
    end;

symbolic procedure arfactor!: v;
   if domainp v then list v
    else if null curdefpol!* then factorf v
    else
   begin scalar w,x,y,z,aftrs,ifctr,ftrs,mva,mvu,
         dmode!*,!*exp;
     timer:=timef:=0;
     !*exp := t;
     mva := mvar curdefpol!*;
     mvu := mvar v;
     ifctr := factorft numr(v := fd2q v);
     dmode!* := '!:ar!:;
     w := if denr v neq 1 then mkrn(car ifctr,denr v)
           else car ifctr;
     for each f in cdr ifctr do
         begin scalar l;
           y := numr subf1(car f,nil);
           if domainp y then <<w := multd(y,w); return>>;
           y := sqfrnorm y;
           dmode!* := nil;
           ftrs := factorft car y;
           dmode!* := '!:ar!:;
           if cadr y neq 0 then
              l := list(mvu . prepf addf(!*k2f mvu,
                                      negf multd(cadr y,!*k2f mva)));
           y := cddr y;
           for each j in cdr ftrs do
              <<x := gcdf!*(car j,y);
                y := quotf!*(y,x);
                z := if l then numr subf1(x,l) else x;
                x := lnc ckrn z;
                z := quotf(z,x);
                w := multf(w,exptf(x,cdr f));
                aftrs := (z . cdr f) . aftrs>>
         end;
      %print timer; print timef;
      return w . aftrs
    end;

symbolic procedure afactorize u;
   begin scalar ftrs,x,!*exp; integer n;
     !*exp := t;
     if cdr u then <<off 'arnum; defpoly cdr u>>;
     x := arfactor!: !*a2f car u;
     ftrs := (0 . mk!*sq(car x ./ 1)) . nil;
     for each j in cdr x do
       for k := 1:cdr j do
           ftrs := ((n := n+1) . mk!*sq(car j ./ 1)) . ftrs;
     return multiple!-result(ftrs,nil)
   end;


put('algeb!_factorize,'psopfn,'afactorize);

symbolic procedure arprep!: u;                         %u;
   prepf if !*reexpress then express!-in!-arvars cdr u
          else cdr u;

%symbolic procedure simpar u;
%('!:ar!: . !*a2f car u) ./ 1;

%put('!:ar!:,'simpfn,'simpar);


symbolic procedure arprn!: v;
   ( if atom u or (car u memq '(times expt)) then maprin u
     else <<prin2!* "(";
            maprin u;
            prin2!* ")" >>) where u = prepsq!*(cdr v ./ 1);


%*** utility functions ***;

symbolic procedure monicize u;
   %makes standard form u monic by the appropriate variable subst.;
   begin scalar a,mvu,x;
         integer n;
     x := lc u;
     mvu := mvar u;
     n := ldeg u;
     !*acounter!* := !*acounter!* + 1;
     a := intern compress append(explode !*extvar!*,
                                 explode !*acounter!*);
     u := multsq(subf(u,list(mvu . list('quotient,a,x))),
                 x**(n-1) ./ 1);
     mk!-algebraic!-number!-vars list mvu;
     put!-current!-representation(mvu,
                                  mkar(a to 1 .* ('!:rn!: . 1 . x)
                                       .+ nil));
     terpri();
     prin2 "defining polynomial has been monicized";
     terpri();
     maprin prepsq u;
     terpri!* t;
     return !*q2f u
   end;


symbolic procedure polynorm u;
   begin scalar dmode!*,x,y;
         integer n;
     n := ldeg curdefpol!*;
     x := fd2q u;
     y := resultantft(curdefpol!*,numr x,mvar curdefpol!*);
     dmode!* := '!:ar!:;
     return if denr x = 1 then y
             else !*q2f multsq(y ./ 1,1 ./ (denr x)**n)
   end;

symbolic procedure resultantft(u,v,w);
   resultant(u,v,w);

symbolic procedure factorft u;
   begin scalar dmode!*; return factorf u end;

symbolic procedure fd2q u;
   %converts a s.f. over ar to a s.q. over the integers;
   if atom u then u ./ 1
    else if car u eq '!:ar!: then fd2q cdr u
    else if car u eq '!:rn!: then cdr u
    else addsq(multsq(!*p2q lpow u,fd2q lc u),fd2q red u);

symbolic procedure sqfrnorm u;
   begin scalar l,norm,y; integer s;
     y := u;
     if algebnp u then go to b;
     a: s := s-1;
        l := list(mvar u . prepf
                  addf(!*k2f mvar u,multd(s,!*k2f mvar curdefpol!*)));
        y := numr subf1(u,l);
        if null algebnp y then go to a;
     b: norm := polynorm y;
        if not ar!-sqfrp norm then go to a;
     return norm . (s . y)
   end;

symbolic procedure algebnp u;
   if atom u then nil
    else if car u eq '!:ar!: then t
    else if domainp u then nil
    else algebnp lc u or algebnp red u;

symbolic procedure ar!-sqfrp u;
   % This is same as sqfrp in gint module.
   domainp gcdf!*(u,diff(u,mvar u));

symbolic procedure primitive!_elem u;
   begin scalar a,x,y,z,newu,newdefpoly,olddefpoly;
     if x := not!_in!_extension u then u := x
      else return;
     !*acounter!* := !*acounter!* + 1;
     a := intern compress append(explode !*extvar!*,
                                 explode !*acounter!*);
     x := sqfrnorm u;
     newdefpoly := !*q2f subf(car x,list(mvar car x . a));
     olddefpoly := curdefpol!*;
     newu := !*q2f subf(cddr x,list(mvar car x . a));
     rmsubs();
     release arvars!*;
     initalgnum prepf newdefpoly;
     y := gcdf!*(numr simp prepf newu,olddefpoly);
     arvars!* := mvar car x . arvars!*;
     mk!-algebraic!-number!-vars arvars!*;
     put!-current!-representation(mvar olddefpoly,
                                  z := quotf!*(negf red y,lc y));
     put!-current!-representation(mvar car x,
                                  addf(mkar !*k2f a,
                                       multf(!*n2f cadr x,z)));
     rmsubs();
     update!-extension arvars!*;
     terpri!* t;
     prin2!* "*** Defining polynomial for primitive element:";
     terpri!* t;
     maprin prepf curdefpol!*;
     terpri!* t
   end;

symbolic procedure not!_in!_extension u;
   %We still need a criterion which branch to choose;
   %Isolating intervals would do;
   begin scalar ndp,x; integer cld;
     if null !*minimal then return u;
     cld := ldeg u;
     x := arfactor!: u;
     for each j in cdr x do
         if ldeg car j < cld then
            <<ndp := car j;
              cld := ldeg ndp>>;
     if cld=1 then <<mk!-algebraic!-number!-vars list mvar u;
                     put!-current!-representation(mvar u,
                                        quotf!*(negf red ndp,lc ndp));
                     return nil>>
      else return ndp
   end;


symbolic procedure split!_field1(u,v);
   %determines the minimal splitting field for u;
   begin scalar a,ftrs,mvu,q,x,y,z,roots,bpoly,minpoly,newminpoly,
                polys,newfactors,dmode!*,!*exp;
         integer indx,k,n,new!_s;
        off 'arnum;  %crude way to clear previous extensions;
        !*exp := t;
        u := !*q2f simp!* u;
        mvu := mvar u;
        indx := 1;
        polys := (1 . u) . polys;
        !*acounter!* := !*acounter!* + 1;
        a := intern compress append(explode !*extvar!*,
                    explode !*acounter!*);
        minpoly := newminpoly := numr subf(u,list(mvu . a));
        dmode!* := '!:ar!:;
        mkextension prepf minpoly;
        roots := mkar !*k2f  a . roots;
     b: polys := for each j in polys collect
                        if indx=car j then
                           car j . quotf!*(cdr j,
                                        addf(!*k2f mvu,negf car roots))
                         else j;
        k := 1;
        indx := 0;
        for each j in polys do
            begin scalar l;
              x := sqfrnorm cdr j;
              if cadr x neq 0 then
                 l := list(mvu . prepf addf(!*k2f mvu,
                                         negf multd(cadr x,!*k2f a)));
              z := cddr x;
              dmode!* := nil;
              ftrs := cdr factorf car x;
              dmode!* := '!:ar!:;
              for each qq in ftrs do
                <<y := gcdf!*(z,q:=car qq);
                  if ldeg q > ldeg newminpoly then
                     <<newminpoly := q;
                       new!_s := cadr x;
                       indx := k;
                       bpoly := y>>;
                  z := quotf!*(z,y);
                  if l then y := numr subf(y,l);
                  if ldeg y=1 then
                     roots := quotf(negf red y,lc y) . roots
                   else <<newfactors:=(k . y) . newfactors;
                          k:=k+1>>>>
            end;
        if null newfactors then
           <<terpri();
             prin2t "*** Splitting field is generated by:";
             terpri();
             maprin prepf newminpoly;
             terpri!* t;
             n := length roots;
             return multiple!-result(
                             for each j in roots collect
                              (n := n-1) . mk!*sq(j ./ 1),v)>>;
        !*acounter!* := !*acounter!* + 1;
        a := intern compress append(explode !*extvar!*,
                                    explode !*acounter!*);
        newminpoly := numr subf(newminpoly,list(mvu . a));
        bpoly := numr subf(bpoly,list(mvu . a));
        rmsubs();
        release arvars!*;
        initalgnum prepf newminpoly;
        x := gcdf!*(minpoly,numr simp prepf bpoly);
        mk!-algebraic!-number!-vars arvars!*;
        put!-current!-representation(mvar minpoly,
                                     z := quotf!*(negf red x,lc x));
        rmsubs();
        roots := addf(mkar !*k2f a,multf(!*n2f new!_s,z)) .
                      for each j in roots collect numr subf(cdr j,nil);
        polys := for each j in newfactors collect
                     car j . numr simp prepf cdr j;
        newfactors := nil;
        minpoly := newminpoly;
        go to b
  end;
 
symbolic procedure split!-field!-eval u;
   begin scalar x;
     if length u > 2
       then rederr "split!_field called with wrong number of arguments";
     x := split!_field1(car u,if cdr u then cadr u else nil);
     dmode!* := '!:ar!:;
     %The above is necessary for working with the results.
     return x
  end;
 
put('split!_field,'psopfn,'split!-field!-eval);
 
symbolic procedure arrationalize!: u;
   %We should actually factorize the denominator first to
   %make sure that the result is in lowest terms. ????
   begin scalar x,y,z,dmode!*;
     if domainp denr u then return quotf(numr u,denr u) ./ 1;
     if null algebnp denr u then return u;
     x := polynorm numr fd2q denr u;
     y := multsq(fd2q multf(numr u,quotf!*(x,denr u)),1 ./ x);
     dmode!* := '!:ar!:;
     x := numr subf(denr y,nil);
     y := numr subf(numr y,nil);
     z := lnc x;
     return quotf(y,z) ./ quotf(x,z)
   end;

%put('rationalize,'simpfn,'rationalize); its now activated by a switch.
put('polynorm,'polyfn,'polynorm);

%*** support functions ***;

comment the function ilnrsolve and others are identical to the
        %ones in matr except they work only on integers here;
        %there should be better algorithms;


symbolic procedure reducepowers u;
   %reduces powers with the help of the defining polynomial;
   if domainp u or (ldeg u<pdeg car repowl!*) then u
    else if ldeg u=pdeg car repowl!* then
             addf(multf(cdr repowl!*,lc u),red u)
    else reducepowers
         addf(multf(multpf(mvar u .** (ldeg u-pdeg car repowl!*),lc u),
              cdr repowl!*),red u);

symbolic procedure mkqmatr u;
   %u is an ar domainelement, result is a matrix form which
   %needs to be inverted for calculating the inverse of ar;
   begin scalar r,x,v,w;
     v := mkqcol u;
     for each k in cdr reverse arbase!* do
       <<w := reducepowers multpf(k,u);
         v := for each j in arbase!* collect
                <<r := ((if atom j then ratn w
                          else if domainp w then 0 . 1
                          else if j=lpow w then
                                  <<x:=ratn lc w; w:=cdr w; x>>
                          else 0 . 1) . car v);
                  v := cdr v;
                  r>>>>;
     return v
   end;

symbolic procedure mkqcol u;
   %u is an ar domainelement result is a matrix form
   %representing u as a coefficient matrix of the ar base;
   begin scalar x,v;
     v := for each j in arbase!* collect
             if atom j then list ratn u
              else if domainp u then list(0 . 1)
              else if j=lpow u then <<x:=list ratn lc u; u:=cdr u; x>>
               else list(0 . 1);
     return v
   end;

symbolic procedure ratn u;
   if null u then 0 . 1
    else if atom u then u . 1
    else if car u eq '!:rn!: then cdr u
    else rederr "Illegal domain in :ar:";

symbolic procedure inormmat u;
   begin integer y; scalar z;
%    x := 1;
     for each v in u do
       <<y := 1;
         for each w in v do y := ilcm(y,denr w);
         z := (for each w in v
                 collect numr w*y/denr w) . z>>;
     return reverse z
   end;

symbolic procedure ilcm(u,v);
   if u=0 or v=0 then 0
    else if u=1 then v
    else if v=1 then u
    else u*v/gcdn(u,v);

symbolic procedure ilnrsolve(u,v);
   %u is a matrix standard form, v a compatible matrix form;
   %value is u**(-1)*v;
   begin integer n;
     n := length u;
     v := ibacksub(ibareiss inormmat ar!-augment(u,v),n);
     u := ar!-rhside(car v,n);
     v := cdr v;
    return for each j in u collect
              for each k in j collect mkrn(k,v)
    end;

symbolic procedure ar!-augment(u,v);
   % Same as augment in bareiss module.
   if null u then nil
    else append(car u,car v) . ar!-augment(cdr u,cdr v);


symbolic procedure ar!-rhside(u,m);
   % Same as rhside in bareiss module.
   if null u then nil else pnth(car u,m+1) . ar!-rhside(cdr u,m);

 symbolic procedure ibareiss u;
   %as in matr but only for integers;
   begin scalar ik1,ij,kk1,kj,k1j,k1k1,ui,u1,x;
    integer k,k1,aa,c0,ci1,ci2;
    aa:= 1;
    k:= 2;
    k1:=1;
    u1:=u;
    go to pivot;
    agn: u1 := cdr u1;
    if null cdr u1 or null cddr u1 then return u;
    aa:=nth(car u1,k);              %aa := u(k,k);
    k:=k+2;
    k1:=k-1;
    u1:=cdr u1;
    pivot:  %pivot algorithm;
    k1j:= k1k1 := pnth(car u1,k1);
    if car k1k1 neq 0 then go to l2;
    ui:= cdr u1;                    %i := k;
    l:   if null ui then return nil
     else if car(ij := pnth(car ui,k1))=0
      then go to l1;
    l0:  if null ij then go to l2;
    x:= car ij;
    rplaca(ij,-car k1j);
    rplaca(k1j,x);
    ij:= cdr ij;
    k1j:= cdr k1j;
    go to l0;
    l1:  ui:= cdr ui;
    go to l;
    l2:  ui:= cdr u1;                    %i:= k;
    l21: if null ui then return; %if i>m then return;
    ij:= pnth(car ui,k1);
    c0:= car k1k1*cadr ij-cadr k1k1*car ij;
    if c0 neq 0 then go to l3;
    ui:= cdr ui;                    %i:= i+1;
    go to l21;
    l3:  c0:= c0/aa;
    kk1 := kj := pnth(cadr u1,k1);  %kk1 := u(k,k-1);
    if cdr u1 and null cddr u1 then go to ev0
     else if ui eq cdr u1 then go to comp;
    l31: if null ij then go to comp;     %if i>n then go to comp;
    x:= car ij;
    rplaca(ij,-car kj);
    rplaca(kj,x);
    ij:= cdr ij;
    kj:= cdr kj;
    go to l31;
    %pivoting complete;
     comp:
    if null cdr u1 then go to ev;
    ui:= cddr u1;                   %i:= k+1;
     comp1:
    if null ui then go to ev;       %if i>m then go to ev;
    ik1:= pnth(car ui,k1);
    ci1:= (cadr k1k1*car ik1-car k1k1*cadr ik1)/aa;
    ci2:= (car kk1*cadr ik1-cadr kk1*car ik1)/aa;
    if null cddr k1k1 then go to comp3;%if j>n then go to comp3;
    ij:= cddr ik1;                  %j:= k+1;
    kj:= cddr kk1;
    k1j:= cddr k1k1;
     comp2:
    if null ij then go to comp3;
    rplaca(ij,(car ij*c0+car kj*ci1+car k1j*ci2)/aa);
    ij:= cdr ij;
    kj:= cdr kj;
    k1j:= cdr k1j;
    go to comp2;
     comp3:
    ui:= cdr ui;
    go to comp1;
     ev0:if c0=0 then return;
     ev: kj := cdr kk1;
    x := cddr k1k1;                 %x := u(k-1,k+1);
    rplaca(kj,c0);
     ev1:kj:= cdr kj;
    if null kj then go to agn;
    rplaca(kj,(car k1k1*car kj-car kk1*car x)/aa);
    x := cdr x;
    go to ev1
    end;

 symbolic procedure ibacksub(u,m);
    begin scalar ij,ijj,ri,uj,ur; integer i,jj,summ,detm,det1;
    %n in comments is number of columns in u;
    if null u then rederr "singular matrix";
    ur := reverse u;
    detm := car pnth(car ur,m);             %detm := u(i,j);
    if detm=0 then rederr "singular matrix";
    i := m;
     rows:
    i := i-1;
    ur := cdr ur;
    if null ur then return u . detm;
         %if i=0 then return u . detm;
    ri := car ur;
    jj := m+1;
    ijj:=pnth(ri,jj);
     r2: if null ijj then go to rows;    %if jj>n then go to rows;
    ij := pnth(ri,i);               %j := i;
    det1 := car ij;                 %det1 := u(i,i);
    uj := pnth(u,i);
    summ := 0;                      %summ := 0;
     r3: uj := cdr uj;                   %j := j+1;
    if null uj then go to r4;       %if j>m then go to r4;
    ij := cdr ij;
    summ := summ+car ij*nth(car uj,jj);
         %summ:=summ+u(i,j)*u(j,jj);
    go to r3;
     r4: rplaca(ijj,(detm*car ijj-summ)/det1);
         %u(i,j):=(detm*u(i,j)-summ)/det1;
    jj := jj+1;
    ijj := cdr ijj;
    go to r2
    end;

initdmode 'arnum;

put('arnum,'simpfg,
      '((t (setdmode (quote arnum) t))
        (nil (setdmode (quote arnum) nil) (release arvars!*)
             (uncurrep arvars!*) (setq curdefpol!* nil)
             (setq arvars!* nil))));

endmodule;


end;

Added r33/arith.red version [5e2a9bbaab].











































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
module farith;  % Operators for fast arithmetic;

% Authors: A. C. Norman and P. M. A. Moore, 1981;

remprop('iplus,'infix);  % to allow for redefinition;

remprop('itimes,'infix);

symbolic macro procedure iplus u; expand(cdr u,'plus2);

symbolic macro procedure itimes u; expand(cdr u,'times2);

smacro procedure isub1 a; a-1;

smacro procedure iadd1 a; a+1;

remprop('iminus,'infix);

smacro procedure iminus a; -a;

smacro procedure idifference(a,b); a-b;

smacro procedure iquotient(a,b); a/b;

smacro procedure iremainder(a,b); remainder(a,b);

smacro procedure igreaterp(a,b); a>b;

smacro procedure ilessp(a,b); a<b;

smacro procedure iminusp a; a<0;

newtok '((!#) hash);
newtok '((!# !+) iplus);
newtok '((!# !-) idifference);
newtok '((!# !*) itimes);
newtok '((!# !/) iquotient);
newtok '((!# !>) igreaterp);
newtok '((!# !<) ilessp);

infix #+,#-,#*,#/,#>,#<;

precedence #+,+;
precedence #-,-;
precedence #*,*;
precedence #/,/;
precedence #>,>;
precedence #<,<;

flag('(iplus itimes),'nary);

deflist('((idifference iminus)),'unary);

deflist('((iminus iplus)), 'alt);

endmodule;


module genmod; % Modular arithmetic where the modulus may be any size.

% Authors: A. C. Norman and P. M. A. Moore, 1981;

fluid '(current!-modulus modulus!/2);

symbolic procedure set!-general!-modulus p;
  if not numberp p then current!-modulus
  else begin
    scalar previous!-modulus;
    previous!-modulus:=current!-modulus;
    current!-modulus:=p;
    modulus!/2 := p/2;
    return previous!-modulus
  end;

symbolic procedure general!-modular!-plus(a,b);
  begin scalar result;
     result:=a+b;
     if result >= current!-modulus then result:=result-current!-modulus;
     return result
  end;

symbolic procedure general!-modular!-difference(a,b);
  begin scalar result;
     result:=a-b;
     if result < 0 then result:=result+current!-modulus;
     return result
  end;

symbolic procedure general!-modular!-number a;
  begin
     a:=remainder(a,current!-modulus);
     if a < 0 then a:=a+current!-modulus;
     return a
  end;

symbolic procedure general!-modular!-times(a,b);
  begin scalar result;
     result:=remainder(a*b,current!-modulus);
     if result<0
       then result := result+current!-modulus;  %can this happen?
     return result
  end;

symbolic procedure general!-modular!-reciprocal a;
  begin
    return general!-reciprocal!-by!-gcd(current!-modulus,a,0,1)
  end;

symbolic procedure general!-modular!-quotient(a,b);
    general!-modular!-times(a,general!-modular!-reciprocal b);

symbolic procedure general!-modular!-minus a;
    if a=0 then a else current!-modulus - a;

symbolic procedure general!-reciprocal!-by!-gcd(a,b,x,y);
%On input A and B should be coprime. This routine then
%finds X and Y such that A*X+B*Y=1, and returns the value Y
%on input A > B;
   if b=0 then rederr "INVALID MODULAR DIVISION"
   else if b=1 then if y < 0 then y+current!-modulus else y
   else begin scalar w;
%N.B. Invalid modular division is either:
% a)  attempt to divide by zero directly
% b)  modulus is not prime, and input is not
%     coprime with it;
     w:=quotient(a,b); %Truncated integer division;
     return general!-reciprocal!-by!-gcd(b,a-b*w,y,x-y*w)
   end;

%symbolic procedure general!-modular!-expt(x,n);
%   if not fixp n then
%      rederr
%        "ZFACT(general-modular-expt): power is not a small integer"
%   else if n=0 then 1
%   else if n=1 then x
%   else
%     (lambda ans;
%        if evenp n then
%           general!-modular!-times(ans,ans)
%        else general!-modular!-times(general!-modular!-times(ans,x),
%                                     ans))
%      general!-modular!-expt(x,n/2);
 
symbolic procedure general!-modular!-expt(a,n);
% a**n;
    if n=0 then 1
    else if n=1 then a
    else begin scalar x;
     x:=general!-modular!-expt(a,n/2);
     x:=general!-modular!-times(x,x);
     if not evenp n then x:=general!-modular!-times(x,a);
     return x
    end;

endmodule;


module smallmod; %Small integer modular arithmetic used in factorizer.

% Author: Arthur C. Norman.

fluid '(current!-modulus modulus!/2);

global '(largest!-small!-modulus);

symbolic procedure set!-modulus p;
  if not numberp p or p=0 then current!-modulus
  else begin
    scalar previous!-modulus;
    previous!-modulus:=current!-modulus;
    current!-modulus:=p;
    modulus!/2:=p/2;
    set!-small!-modulus p;
    return previous!-modulus
  end;

symbolic procedure set!-small!-modulus p;
  begin
    scalar previous!-modulus;
    if p>largest!-small!-modulus
      then rederr list("Overlarge modulus",p,"being used");
    previous!-modulus:=current!-modulus;
    current!-modulus:=p;
    modulus!/2 := p/2;
    return previous!-modulus
  end;


smacro procedure modular!-plus(a,b);
  begin scalar result;
     result:=a #+ b;
     if not result #< current!-modulus then
            result:=result #- current!-modulus;
     return result
  end;

smacro procedure modular!-difference(a,b);
  begin scalar result;
     result:=a #- b;
     if iminusp result then result:=result #+ current!-modulus;
     return result
  end;

symbolic procedure modular!-number a;
  begin
     a:=remainder(a,current!-modulus);
     if iminusp a then a:=a #+ current!-modulus;
     return a
  end;

smacro procedure modular!-times(a,b);
    remainder(a*b,current!-modulus);

smacro procedure modular!-reciprocal a;
    reciprocal!-by!-gcd(current!-modulus,a,0,1);

symbolic procedure reciprocal!-by!-gcd(a,b,x,y);
%On input A and B should be coprime. This routine then
%finds X and Y such that A*X+B*Y=1, and returns the value Y
%on input A > B;
   if b=0 then rederr "Invalid modular division"
   else if b=1 then if iminusp y then y #+ current!-modulus else y
   else begin scalar w;
%N.B. Invalid modular division is either:
% a)  attempt to divide by zero directly
% b)  modulus is not prime, and input is not
%     coprime with it;
     w:= a #/ b; %Truncated integer division;
     return reciprocal!-by!-gcd(b,a #- b #* w,
                                y,x #- y #* w)
   end;

smacro procedure modular!-quotient(a,b);
    modular!-times(a,modular!-reciprocal b);


smacro procedure modular!-minus a;
    if a=0 then a else current!-modulus #- a;

symbolic procedure modular!-expt(a,n);
% a**n;
    if n=0 then 1
    else if n=1 then a
    else begin scalar x;
     x:=modular!-expt(a,n#/2);
     x:=modular!-times(x,x);
     if not (iremainder(n,2) = 0) then x:=modular!-times(x,a);
     return x
    end;

symbolic set!-modulus(1) ; % forces everything into a standard state;

endmodule;


module random;  % Random Number Generator.

% Author: Unknown.

global '(randomseed!* randommodulus!*);

% The declarations below constitute a linear, congruential random number
% generator (see Knuth, "The Art of Computer Programming:  Volume 2:
% Seminumerical Algorithms", pp9-24).  With the given constants it has a
% period of 392931 and potency 6.  To have deterministic behaviour, set
% RANDOMSEED.

% Constants are:        6   2
%    modulus: 392931 = 3 * 7 * 11
%    multiplier: 232 = 3 * 7 * 11 + 1
%    increment: 65537 is prime
%
% Would benefit from being recoded in a SysLisp style, when full word
% integers could be used with "automatic" modular arithmetic (see
% Knuth).  Perhaps we should have a longer period version?

randommodulus!* := 392931;

% randomseed!* := remainder(time(),randommodulus!*);

randomseed!* := 300000;   % To avoid use of time function.

symbolic procedure next!-random!-number;
   % Returns a pseudo-random number between 0 and RandomModulus-1
   % (inclusive).
   randomseed!* := remainder(232*randomseed!* + 65537, randommodulus!*);

symbolic procedure random(n);
% Returns a pseudo-random number uniformly selected from the range
% 0..N-1.
   fix( (float(n) * next!-random!-number()) / randommodulus!*);

endmodule;


module zfactor;  % Integer factorization.
 
% Author: Julian Padget.
 
% exports zfactor, primep;
% zfactor - returns an alist of factors dotted with their multiplicities
% primep - determines whether argument is prime or not
%
% imports evenp, gcdn, general-modular-expt, general-modular-times, leq,
% modular-expt, modular-times, neq, prin2t, rederr, reversip,
% set-general-modulus, set-small-modulus;
%
% needs bigmod,smallmod;
%
% internal-functions add-factor, general-primep, mcfactor!*,
% internal-primep, isqrt, mcfactor, small-primep;
 
% Parameters to this module are:
%
%    !*confidence!* - controls the computation in the primality test.
%        Probability that a number is composite when test says it is
%        prime is 1/(2**(2*!*confidence!*)).
%
%    !*maxtrys!* - controls the maximum number of attempts to be made
%        at factorisation (using mcfactor) whilst varying the polynomial
%        used as part of the Monte-Carlo technique.  When !*maxtrys!* is
%        exceeded assumes n is prime (case will most likely occur when
%        primality test fails).
%
%    !*mod!* - controls the modulus of the numbers emitted by the random
%        number generator.  It is important that the number being tested
%        for primality should lie in [0,!*mod!*].
%
% Globals private to this module are:
%
%    !*primelist!* - a list of the first xxx prime numbers used in the
%        first part of the factorisation where trial division is
%        employed.
%
%    !*last!-prime!-in!-list!* - the largest prime in the !*primelist!*
 
fluid '(!*maxtrys!* !*confidence!*);
 
!*maxtrys!*:=10; !*confidence!*:=10;
 
global '(!*primelist!* !*last!-prime!-in!-list!*);
 
!*primelist!*:='(
2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97
101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191
193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283
293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401
409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509
521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631
641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751
757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877
881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 1009
1013 1019 1021 1031 1033 1039 1049 1051 1061 1063 1069 1087 1091 1093
1097 1103 1109 1117 1123 1129 1151 1153 1163 1171 1181 1187 1193 1201
1213 1217 1223 1229 1231 1237 1249 1259 1277 1279 1283 1289 1291 1297
1301 1303 1307 1319 1321 1327 1361 1367 1373 1381 1399 1409 1423 1427
1429 1433 1439 1447 1451 1453 1459 1471 1481 1483 1487 1489 1493 1499
1511 1523 1531 1543 1549 1553 1559 1567 1571 1579 1583 1597 1601 1607
1609 1613 1619 1621 1627 1637 1657 1663 1667 1669 1693 1697 1699 1709
1721 1723 1733 1741 1747 1753 1759 1777 1783 1787 1789 1801 1811 1823
1831 1847 1861 1867 1871 1873 1877 1879 1889 1901 1907 1913 1931 1933
1949 1951 1973 1979 1987 1993 1997 1999 2003 2011 2017 2027 2029 2039
2053 2063 2069 2081 2083 2087 2089 2099 2111 2113 2129 2131 2137 2141
2143 2153 2161 2179 2203 2207 2213 2221 2237 2239 2243 2251 2267 2269
2273 2281 2287 2293 2297 2309 2311 2333 2339 2341 2347 2351 2357 2371
2377 2381 2383 2389 2393 2399 2411 2417 2423 2437 2441 2447 2459 2467
2473 2477 2503 2521 2531 2539 2543 2549 2551 2557 2579 2591 2593 2609
2617 2621 2633 2647 2657 2659 2663 2671 2677 2683 2687 2689 2693 2699
2707 2711 2713 2719 2729 2731 2741 2749 2753 2767 2777 2789 2791 2797
2801 2803 2819 2833 2837 2843 2851 2857 2861 2879 2887 2897 2903 2909
2917 2927 2939 2953 2957 2963 2969 2971 2999 3001 3011 3019 3023 3037
3041 3049 3061 3067 3079 3083 3089 3109 3119 3121 3137 3163 3167 3169
3181 3187 3191 3203 3209 3217 3221 3229 3251 3253 3257 3259 3271 3299
3301 3307 3313 3319 3323 3329 3331 3343 3347 3359 3361 3371 3373 3389
3391 3407 3413 3433 3449 3457 3461 3463 3467 3469 3491 3499 3511 3517
3527 3529 3533 3539 3541 3547 3557 3559 3571 )$

!*last!-prime!-in!-list!* := car reverse !*primelist!*;
 
% the following four routines were written by John Abbot and are
% incorporated here with his permission.

symbolic procedure ilog2 n;
% n integral; result 'r' s.t. 2**r <= abs n < 2**(r+1)
if not fixp n then
   rederr "(ZFACTOR(ilog2):argument must be an integer"
else begin scalar ans, powers!-of!-2;
   if n<0 then n:=-n;
   powers!-of!-2:=2 . nil;
   ans:=1;
   while n>=(car powers!-of!-2) do <<
      n:=n/(car powers!-of!-2);
      powers!-of!-2:=((car powers!-of!-2)**2) . powers!-of!-2
   >>;
   while (car powers!-of!-2) neq n and cdr powers!-of!-2 do <<
      powers!-of!-2:=cdr powers!-of!-2;
      ans:=ans+ans;
      if powers!-of!-2 and n>=(car powers!-of!-2) then <<
         n:=n/(car powers!-of!-2);
         ans:=ans+1
      >>
   >>;
   return (ans-1)
end;
 
symbolic procedure isqrt n; irootn(n,2);

symbolic procedure irootn(n,r);
% n,r integral; result 's' approximates rth root of n
% that is if n>0 then s**r <= n < (s+1)**r else s**r >= n > (s-1)**r
% 3363/2378 is an approximation to sqrt 2;
if not (fixp n and fixp r) then
   rederr "ZFACTOR(irootn): both arguments must be integers"
else if r<=0 then
   rederr "ZFACTOR(irootn): non-positive integer root"
else if n<0 then
   if evenp r then
      rederr "ZFACTOR(irootn): even root of a negative integer"
   else
      -irootn(-n,r)
else if r=1 then n
else begin scalar x,newx,upb;
   x:=2**(irootn!-round(1+ilog2 n,r));
   newx:=x-irootn!-roundup(x-n/x**(r-1),r);
   upb:=(3363*x)/2378;
   if upb<newx then newx:=upb;
   repeat <<
      x:=newx;
      newx:=x-irootn!-roundup(x-n/x**(r-1),r)
   >> until newx>=x or newx=0;
   return x
end;
 
symbolic procedure irootn!-round(m,n);
% m,n integral, n>0, answer is nearest integer to m/n
(m+n/2)/n;
 
symbolic procedure irootn!-roundup(m,n);
% m,n integral, n>0, answer is least integer >= m/n
(lambda quotrem;
   if (cdr quotrem)=0 then car quotrem else 1+(car quotrem))
 divide(m,n);
 
symbolic procedure add!-factor(n,l);
   (lambda (p); if p then << rplacd(p,add1 cdr p); l>> else (n . 1) . l)
      if pairp l then if n>(caar l) then nil else atsoc(n,l) else nil;
 
symbolic procedure zfactor n;
if n<0 then
   ((-1) . 1) . zfactor(-n)
else if n<4 then
   list (n . 1)
else % trial division then advanced technology if needed
   (lambda (primelist,rootn,factor!-list); <<
      while pairp primelist do
         (lambda aprime; <<
            while remainder(n,aprime)=0 do <<
               n:=n/aprime;
               rootn:=isqrt n;
               factor!-list:=add!-factor(aprime,factor!-list)
            >>;
            if rootn < aprime then <<
               if n neq 1
                then factor!-list:=add!-factor(n,factor!-list);
               primelist:=aprime
            >>
            else
               primelist:=cdr primelist
          >>)
          car primelist;
      if null primelist then mcfactor!*(n,factor!-list)
       else factor!-list
      >>)
    (!*primelist!*,isqrt n,nil);
 
symbolic procedure mcfactor!*(n,factors!-so!-far);
if internal!-primep n then
   add!-factor(n,factors!-so!-far)
else <<
   n:=(lambda (p,tries); <<
         while (atom p) and (tries<!*maxtrys!*) do <<
            tries:=tries+1;
            p:=mcfactor(n,tries)
         >>;
         if tries>!*maxtrys!* then <<
            prin2 "ZFACTOR(mcfactor!*):Assuming ";
            prin2 n; prin2t " is prime";
            p:=list n
         >>
         else p
       >>)
       (mcfactor(n,1),1);
   if null cdr n then
      add!-factor(n,factors!-so!-far)
   else if (car n)<(cdr n) then
      mcfactor!*(cdr n,mcfactor!*(car n,factors!-so!-far))
   else
      mcfactor!*(car n,mcfactor!*(cdr n,factors!-so!-far))
>>;
 
symbolic procedure mcfactor(n,p);
% Based on "An Improved Monte-Carlo Factorisation Algorithm" by
% R.P.Brent in BIT 20 (1980) pp 176-184.  Argument n is the number to
% factor, p specifies the constant term of the polynomial.  There are
% supposed to be optimal p's for each n, but in general p=1 works well.
begin scalar gg,k,m,q,r,x,y,ys;
   y:=0; r:=q:=m:=1;
outer:
   x:=y;
   for i:=1:r do y:=remainder(y*y+p,n);
   k:=0;
inner:
   ys:=y;
   for i:=1:(if m<(r-k) then m else r-k) do <<
      y:=remainder(y*y+p,n);
      q:=remainder(q*abs(x-y),n)
   >>;
   gg:=gcdn(q,n);
   k:=k+m;
   if (k<r) and (gg leq 1) then goto inner;
   r:=2*r;
   if gg leq 1 then goto outer;
   if gg=n then begin
   loop:
      ys:=remainder(ys*ys+p,n);
      gg:=gcdn(abs(x-ys),n);
      if gg leq 1 then goto loop
   end;
   return if gg=n then n else gg . (n/gg)
end;
 
symbolic procedure primep n;
   if n member !*primelist!* then t
   else if (isqrt n)<!*last!-prime!-in!-list!* then
      begin scalar p;
         p:=!*primelist!*;
      loop:
         if remainder(n,car p)=0 then return nil;
         if null(p:=cdr p) then return t;
         go loop
      end
   else if n>largest!-small!-modulus then
      general!-primep n
   else
      small!-primep n;
 
symbolic procedure internal!-primep n;
   if n>largest!-small!-modulus then
      general!-primep n
   else
      small!-primep n;
 
symbolic procedure small!-primep n;
% Based on an algorithm of M.Rabin published in the Journal of Number
% Theory Vol 12, pp 128-138 (1980).  This version uses small modular
% arithmetic which can be open coded.
begin scalar i,m,l,b2m,result,x,!*mod!*;
   m:=n-1;
   l:=0;
   set!-small!-modulus n;
      % first a quick check for compositeness
   if modular!-expt(3,m) neq 1 then return nil;
   i:=20;
   while (!*mod!*:=2**i)<n do i:=i+4;
      % construct (2**l)*m from n-1
   while evenp m do << m:=m/2; l:=l+1 >>;
   i:=1;
   result:=t;
   b2m:=mkvect l;
   while result and i<=!*confidence!* do <<
         % pick a potential witness
         % make a vector of b**(2*m) up to b**((2**l)*m)
      x:=putv(b2m,1,modular!-expt(remainder(random(!*mod!*),n),m+m));
      for j:=2:l do x:=putv(b2m,j,modular!-times(x,x));
         % neq 1 implies a witness that n is composite
      if getv(b2m,l)=1 then
         for j:=1:l do <<
            if result then <<
               x:=gcdn(getv(b2m,j)-1,n);
               if (x neq 1) and (x neq n) then result:=nil
            >>
         >>
      else result:=nil;
      i:=i+1
   >>;
   return result
end;
 
symbolic procedure general!-primep n;
% Based on an algorithm of M.Rabin published in the Journal of Number
% Theory Vol 12, pp 128-138 (1980).  This version uses general modular
% arithmetic which is somewhat more expensive than the above routine
begin scalar i,m,l,b2m,result,x,!*mod!*;
   m:=n-1;
   l:=0;
   set!-general!-modulus n;
      % first a quick check for compositeness
   if general!-modular!-expt(3,m) neq 1 then return nil;
   i:=32;
   while (!*mod!*:=2**i)<n do i:=i+4;
      % construct (2**l)*m from n-1
   while evenp m do << m:=m/2; l:=l+1 >>;
   i:=1;
   result:=t;
   b2m:=mkvect l;
   while result and i<=!*confidence!* do <<
         % pick a potential witness
         % make a vector of b**(2*m) up to b**((2**l)*m)
      x:=putv(b2m,1,
              general!-modular!-expt(remainder(random(!*mod!*),n),m+m));
      for j:=2:l do x:=putv(b2m,j,general!-modular!-times(x,x));
         % /=1 implies a witness that n is composite
      if getv(b2m,l)=1 then
         for j:=1:l do <<
            if result then <<
               x:=gcdn(getv(b2m,j)-1,n);
               if (x neq 1) and (x neq n) then result:=nil
            >>
         >>
      else result:=nil;
      i:=i+1
   >>;
   return result
end;
 
endmodule;


end;

Added r33/bfloat.red version [6a4733a467].























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
module bfloat; % Routines for arbitrary precision real arithmetic.

% Author: T. Sasaki, 1979.

% Modifications by: Anthony C. Hearn (interface to algebraic mode)
%                   Jed B. Marti (general cleanup)

global '(bfsaveprec!* !*nat !:prec!: domainlist!*);

% BFSAVEPREC!* is precision at which to save constants. If NIL, use
% !:PREC!: otherwise use value of this global (usually set in REND).

% Constants for use during this package. These are set at the
% end of this package.

global '(!:bf!-pi         %PI to 20 digits.
         !:bf!-0          %0.0
         !:bf!-1          %1.0
         !:bf!-e          %E to 20 digits
         !:bf!-0!.5       %0.5
         !:bf!-0!.25      %0.25
         !:bf!-0!.1       %0.1
         !:bf!-1!.72      %1.72
         !:bf!-0!.42      %0.42
         !:bf!-0!.72      %0.72
        );

switch bigfloat;

comment *** Tables for Bigfloats ***;

domainlist!* := union('(!:bf!:),domainlist!*);
put('bigfloat,'tag,'!:bf!:);
put('!:bf!:,'dname,'bigfloat);
flag('(!:bf!:),'field);
put('!:bf!:,'i2d,'i2bf!:);
put('!:ft!:,'!:bf!:,'!*ft2bf);
put('!:rn!:,'!:bf!:,'!*rn2bf);
put('!:bf!:,'minusp,'minusp!:);
put('!:bf!:,'plus,'bfplus!:);
put('!:bf!:,'times,'ttimes!:);
put('!:bf!:,'difference,'tdifference!:);
put('!:bf!:,'quotient,'bfquotient!:);
put('!:bf!:,'zerop,'bfzerop!:);
put('!:bf!:,'onep,'bfonep!:);
put('!:bf!:,'prepfn,'bfprep!:);
put('!:bf!:,'prifn,'bfprin!:);
put('!:bf!:,'cmpxtype,list '!:gbf!:);

comment SMACROS needed;

symbolic smacro procedure mt!:(nmbr);
 % This function selects the mantissa of a number "n".
 % NMBR is a BIG-FLOAT representation of "n".
          cadr nmbr;


symbolic smacro procedure ep!:(nmbr);
 % This function selects the exponent of a number "n".
 % NMBR is a BIG-FLOAT representation of "n".
          cddr nmbr;


symbolic procedure i2bf!: u; '!:bf!: . u . 0;

symbolic procedure !*rn2bf u;
   begin scalar x;
      x := get('!:bf!:,'i2d);
      return apply2(get('!:bf!:,'quotient),
                    apply(x,list cadr u),apply(x,list cddr u))
   end;

symbolic procedure !*ft2bf u; conv!:a2bf cdr u;

symbolic procedure bfplus!:(u,v);
   % Value is sum of U and V, or tagged bigfloat zero if outside
   % precision.
   begin scalar x,y;
      x := tplus!:(u,v);
      y := '!:bf!: . abs mt!: x . (ep!: x+!:prec!:-1);
      return if lessp!:(y,abs!: u) and lessp!:(y,abs!: v)
               then '!:bf!: . (0 . ep!: x)
              else x
   end;

symbolic procedure bfquotient!:(u,v); divide!:(u,v,!:prec!:);

symbolic procedure bfzerop!: u;
   % This is possibly too restricted a definition.
   mt!: u = 0;

symbolic procedure bfonep!: u;
   % allow for roundup of four in the last place.
   begin scalar x,y;
      y := ep!: u + !:prec!:;
      if not(y=0 or y=1) then return;
      x := mt!: u*10**y - 10**!:prec!:;
      return (x<=0 and x>=-4)
   end;

symbolic procedure bfprep!: u; u;

symbolic procedure bfprin!: u;
   % Print tagged bigfloat U.
   bfprin cdr u;

symbolic procedure bfprin nmbr;
   %prints a big-float in a variety of formats. Still needs work
   %for fortran output;
    begin integer j,k;  scalar u,v;
 nmbr := round!:mt('!:bf!: . nmbr,!:prec!:-2);
 if bfzerop!:(nmbr) then return prin2!* '!0;
 u := explode abs(j := mt!: nmbr);
 k := ep!: nmbr;
 if k>=0 then if k>5 then go to etype
  else <<v := list('!.,'!0);
         while (k := k-1)>=0 do v := '!0 . v;
         u := nconc(u,v)>>
  else if (k := order!:(nmbr)+1)>0 
   then <<v := u;
   while (k := k-1)>0 do v := cdr v;
   rplacd(v,'!. . cdr v)>>
  else if k<-10 then go to etype
  else <<while (k := k+1)<=0 do u := '!0 . u;
  u := '!0 . '!. . u>>;
 bfprin1(u,j);
 return nmbr;
   etype:
 if null( cdr(u)) then rplacd(u , list('!0));
 u:= car u . '!. . cdr u;
 j := bfprin1(u,j);
 if j=0 then <<prin2!*("E "  ); j:=2>> else
 if j=1 then <<prin2!*(" E " ); j:=4>> else
 if j=2 then <<prin2!*(" E  "); j:=0>> else
 if j=3 then <<prin2!*(" E " ); j:=0>> else
 if j=4 then <<prin2!*("  E "); j:=2>>;
 u:=explode( k:=order!:(nmbr));
 if k>=0 then u:=cons('!+,u);
 while u do <<prin2!*( car(u)); u:=cdr(u); j:=j+1;
     if j=5 then <<prin2!*(" "); j:=0>> >>;
 return nmbr
    end;

symbolic procedure bfprin1(u,j);
   begin scalar v,w;
 if j<0 then u := '!- . u;
 %suppress trailing zeros;
 v := u;
 while not(car v eq '!.) do v := cdr v;
 v := cdr v;
    l: while cdr v and not(cadr v eq '!0) do v := cdr v;
 w := cdr v;
        while w and car w eq '!0 do w := cdr w;
 if null w then rplacd(v,nil) else <<v := w; go to l>>;
 %now print the number;
 j := 0;
 for each char in u do <<prin2!* char; j := j+1;
    if j=5 then <<if !*nat then prin2!* '! ;
           j := 0>>>>;
 return j
   end;

symbolic procedure bflerrmsg u;
   %Standard error message for BFLOAT module;
   rederr list("Invalid argument to",u);


% Simp property for !:BF!: since PREP is identity.

symbolic procedure !:bf!:simp u; ('!:bf!: . u) ./ 1;

put('!:bf!:,'simpfn,'!:bf!:simp);

!:prec!: := 12;   %default value;

initdmode 'bigfloat;

symbolic procedure precision n;
   if n=0 then !:prec!:-2 else <<!:prec!: := n+2; n>>;

flag('(precision),'opfn);    % symbolic operator precision;


% *** Tables for Elementary Function and Constant Values ***

deflist('((exp exp!*) (expt bfexpt!:) (log log!*) (sin sin!*)
   (cos cos!*) (tan tan!*) (asin asin!*) (acos acos!*)
   (atan atan!*) (sqrt sqrt!*) (sinh sinh!*) (cosh cosh!*)
   (e e!*) (pi pi!*)),
 '!:bf!:);

symbolic procedure bfexpt!:(u,v);
   % Calculates u**v, including case u<0.
   if minusp!: u 
     then multd(texpt!:any(minus!: u,v),
                !*q2f if null numr simp list('difference,v,
                                             '(quotient 1 2))
                        then simp 'i
                       else mksq(list('expt,'(minus 1),v),1))
    else texpt!:any(u,v);

symbolic procedure exp!* u; exp!:(u,!:prec!:);

symbolic procedure log!* u; log!:(u,!:prec!:);

symbolic procedure sin!* u; sin!:(u,!:prec!:);

symbolic procedure cos!* u; cos!:(u,!:prec!:);

symbolic procedure tan!* u; tan!:(u,!:prec!:);

symbolic procedure asin!* u; asin!:(u,!:prec!:);

symbolic procedure acos!* u; acos!:(u,!:prec!:);

symbolic procedure atan!* u; atan!:(u,!:prec!:);

symbolic procedure sqrt!* u; sqrt!:(u,!:prec!:);

symbolic procedure sinh!* u;
   ttimes!:(conv!:a2bf 0.5,
            tdifference!:(exp!* u,exp!* !:minus u));

symbolic procedure cosh!* u;
   ttimes!:(conv!:a2bf 0.5,
            bfplus!:(exp!* u,exp!* !:minus u));

symbolic procedure pi!*;
   if !:prec!:>1000 then !:bigpi !:prec!: else !:pi !:prec!:;

symbolic procedure e!*; !:e !:prec!:;


%*************************************************************
%*************************************************************
%**                                                         **
%**       ARBITRARY PRECISION REAL ARITHMETIC SYSTEM        **
%**               machine-independent version               **
%**                                                         **
%**                         made by                         **
%**                                                         **
%**                     Tateaki  Sasaki                     **
%**                                                         **
%**           The University of Utah,  March 1979           **
%**                                                         **
%**=========================================================**
%**                                                         **
%**  For design philosophy and characteristics of this      **
%**      system, see T. Sasaki, "An Arbitrary Precision     **
%**      Real Arithmetic Package in REDUCE," Proceedings    **
%**      of EUROSAM '79, Marseille (France), June 1979.     **
%**                                                         **
%**  For implementing and using this system, see T. Sasaki, **
%**      "Manual for Arbitrary Precision Real Arithmetic    **
%**      System in REDUCE," Operating Report of Utah Sym-   **
%**      bolic Computation Group.                           **
%**                                                         **
%**=========================================================**
%**                                                         **
%**  In order to speed up this system, you have only to     **
%**      rewrite four routines (DECPREC!:, INCPREC!:,       **
%**      PRECI!:, and ROUND!:LAST) machine-dependently.     **
%**                                                         **
%**=========================================================**
%**                                                         **
%**                    Table of Contents                    **
%**                                                         **
%** 1-1. Initialization.                                    **
%** 1-2. Constructor, selectors and basic predicate.        **
%** 1-3. Temporary routines for rational number arithmetic. **
%** 1-4. Counters.                                          **
%** 1-5. Routines for converting the numeric type.          **
%** 1-6. Routines for converting a big-float number.        **
%** 1-7. Routines for reading/printing numbers.             **
%** 2-1. Arithmetic manipulation routines.                  **
%** 2-2. Arithmetic predicates.                             **
%** 3-1. Elementary constants.                              **
%** 3-2. Routines for saving constants.                     **
%** 4-1. Elementary functions.                              **
%** 5-1. Appendix: routines for defining infix operators.   **
%**                                                         **
%*************************************************************
%*************************************************************


%*************************************************************
%**                                                         **
%** 1-1. Initialization.                                    **
%**                                                         **
%*************************************************************

%*************************************************************
%**                                                         **
%** 1-2. CONSTRUCTOR, SELECTORS and basic PREDICATE.        **
%**                                                         **
%*************************************************************

 symbolic smacro procedure make!:bf(mt,ep);
 % MT and EP are any integers (positive or negative).  So,
 %      you can handle any big or small numbers.  In this
 %      sense, "BF" denotes a BIG-FLOATING-POINT number.
 %      Hereafter, an internal representation of a number
 %      constructed by MAKE!:BF is referred to as a
 %      BIG-FLOAT representation.
          cons('!:bf!: , cons(mt,ep))$


symbolic procedure bfp!:(x);
 % This function returns T if X is a BIG-FLOAT
 %      representation, else it returns NIL.
 % X is any LISP entity.
          if atom(x) then nil else
          if car(x) eq '!:bf!: then t else nil$


%*************************************************************
%**                                                         **
%** 1-3. Temporary routines for rational number arithmetic. **
%**                                                         **
%*************************************************************

symbolic procedure make!:ratnum(nm,dn);
% This function constructs an internal representation
%      of a rational number composed of the numerator
%      NM and the denominator DN.
% NM and DN are any integers (positive or negative).
% **** Four routines in this section are temporary.
% ****      That is, if your system has own routines
% ****      for rational number arithmetic, you can
% ****      accommodate our system to yours only by
% ****      redefining these four routines.
  if zerop dn then rederr "ZERO DENOMINATOR IN MAKE!:RATNUM"
    else if dn > 0 then '!:ratnum!: . (nm . dn)
                   else '!:ratnum!: . (-nm . -dn);


symbolic procedure ratnump!:(x);
% This function returns T if X is a rational number
%      representation, else it returns NIL.
% X is any LISP entity.
eqcar(x, '!:ratnum!:);                   %JBM Change to EQCAR.


symbolic smacro procedure numr!: rnmbr;
% This function selects the numerator of a rational
%      number "n".
% RNMBR is a rational number representation of "n".
          cadr rnmbr$


symbolic smacro procedure denm!: rnmbr;
% This function selects the denominator of a rational
%      number "n".
% RNMBR is a rational number representation of "n".
          cddr rnmbr$


%*************************************************************
%**                                                         **
%** 1-4. COUNTERS.                                          **
%**                                                         **
%*************************************************************

symbolic smacro procedure preci!: nmbr;
% This function counts the precision of a number "n".
% NMBR is a BIG-FLOAT representation of "n".
          length explode abs mt!: nmbr$


symbolic procedure order!: nmbr;
% This function counts the order of a number "n".
% NMBR is a BIG-FLOAT representation of "n".
% **** ORDER(n)=k if 10**k <= ABS(n) < 10**(k+1)
% ****     when n is not 0, and ORDER(0)=0.
  if mt!: nmbr = 0 then 0
   else preci!: nmbr + ep!: nmbr - 1$


%*************************************************************
%**                                                         **
%** 1-5. Routines for converting the numeric type.          **
%**                                                         **
%*************************************************************

symbolic procedure conv!:a2bf(n);
% This function converts a number N or a number-like
%      entity N to a <BIG-FLOAT>, i.e., a BIG-FLOAT
%      representation of N.
% N is either an integer, a floating-point number,
%      a string representing a number, a rational
%      number, or a <BIG-FLOAT>.
% **** This function is the most general conversion
% ****      function to get a BIG-FLOAT representation.
% ****      In this sense, A means an Arbitrary number.
% **** A rational number is converted to a <BIG-FLOAT>
% ****      of precision !:PREC!: if !:PREC!: is not
% ****      NIL, else the precision is set 50.
   if bfp!: n then n
    else if fixp n then make!:bf(n, 0)
    else if floatp n then read!:num n
    else if stringp n then read!:num n
    else if ratnump!: n then 
       conv!:r2bf(n, if !:prec!: then !:prec!: else 50)
    else if not atom n and idp car n and get(car n,'dname)
     then apply(get(car n,'!:bf!:),list n)
    else bflerrmsg 'conv!:a2bf$


symbolic procedure conv!:f2bf fnmbr;
% This function converts a floating-point number
%      FNMBR to a <BIG-FLOAT>, i.e., a BIG-FLOAT
%      representation.
% FNMBR is a floating-point number.
% **** CAUTION!. If you input a number, say, 0.1,
% ****      some systems do not accept it as 0.1
% ****      but may accept it as 0.09999999.
% ****      In such a case, you had better use
% ****      CONV!:S2BF than to use CONV!:F2BF.
  if floatp fnmbr then read!:num fnmbr
     else bflerrmsg 'conv!:f2bf$


symbolic procedure conv!:i2bf intgr;
% This function converts an integer INTGR to a <BIG-
%      FLOAT>, i.e., a BIG-FLOAT representation.
% INTGR is an integer.
  if fixp intgr then make!:bf(intgr, 0)
    else bflerrmsg 'conv!:i2bf$


symbolic procedure conv!:r2bf(rnmbr,k);
% This function converts a rational number RNMBR to a
%      <BIG-FLOAT> of precision K, i.e., a BIG-FLOAT
%      representation with a given precision.
% RNMBR is a rational number representation.
% K is a positive integer.
  if ratnump!: rnmbr and fixp k and k > 0 then
             divide!:( make!:bf( numr!: rnmbr, 0),
                       make!:bf( denm!: rnmbr, 0), k)
   else bflerrmsg 'conv!:r2bf$


symbolic procedure conv!:s2bf strng;
% This function converts a string representing
%      a number "n" to a <BIG-FLOAT>, i.e.,
%      a BIG-FLOAT representation.
% STRNG is a string representing "n".  "n" may
%      be an integer, a floating-point number
%      of any precision, or a rational number.
% **** CAUTION!  Some systems may set the
% ****           maximum size of string.
  if stringp strng then read!:num strng
   else bflerrmsg 'conv!:s2bf$


symbolic procedure conv!:bf2f nmbr;
% This function converts a <BIG-FLOAT>, i.e., a BIG-FLOAT
%      representation of "n", to a floating-point number.
% NMBR is a BIG-FLOAT representation of the number "n".
  if bfp!: nmbr then
       float mt!: nmbr * float(10 ** ep!: nmbr)
   else bflerrmsg 'conv!:bf2f$


symbolic procedure conv!:bf2i nmbr;
% This function converts a <BIG-FLOAT>, i.e., a BIG-FLOAT
%      representation of "n", to an integer.  The result
%      is the integer part of "n".
% **** For getting the nearest integer to "n", please use
% ****      the combination MT!:( CONV!:EP(NMBR,0)).
% NMBR is a BIG-FLOAT representation of the number "n".
  if bfp!: nmbr then
      if ep!:(nmbr := cut!:ep(nmbr, 0)) = 0 then mt!: nmbr
             else mt!: nmbr * 10 ** ep!: nmbr
   else bflerrmsg 'conv!:bf2i$


symbolic procedure conv!:bf2r nmbr;
% This function converts a <BIG-FLOAT>, i.e., a BIG-FLOAT
%      representation of "n", to a rational number.
% NMBR is a BIG-FLOAT representation of "n".
% **** The numerator and the denominator of the result
% ****      have no common divisor.
  if bfp!: nmbr then
    begin integer nn,nd,m,n,q;
          if (q := ep!: nmbr) >= 0 then
               << nn := mt!: nmbr * 10**q; nd := 1; m := 1 >>
          else << nn := mt!: nmbr; nd := 10 ** -q;
                  if abs nn > abs nd then <<m := nn; n := nd >>
                     else << m := nd; n:= nn >>;
                 while not(n = 0) do
                       << q := remainder(m, n); m := n; n := q >> >>;
          return make!:ratnum(nn/m, nd/m);
    end
   else bflerrmsg 'conv!:bf2r$


%*************************************************************
%**                                                         **
%** 1-6. Routines for converting a BIG-FLOAT number.        **
%**                                                         **
%*************************************************************

symbolic procedure decprec!:(nmbr, k);
% This function converts a number "n" to an equivalent
%      number the precision of which is decreased by K.
% **** CAUTION!  No rounding is made.
% NMBR is a BIG-FLOAT representation of "n".
% K is a positive integer.
   make!:bf( mt!: nmbr / 10**k, ep!: nmbr + k)$


symbolic procedure incprec!:(nmbr, k);
% This function converts a number "n" to an equivalent
%      number the precision of which is increased by K.
% **** CAUTION!  No rounding is made.
% NMBR is a BIG-FLOAT representation of "n".
% K is a positive integer.
   make!:bf( mt!: nmbr * 10**k, ep!: nmbr - k)$


symbolic procedure conv!:mt(nmbr, k);
% This function converts a number "n" to an
%      equivalent number of precision K by
%      rounding "n" or adding "0"s to "n".
% NMBR is a BIG-FLOAT representation of "n".
% K is a positive integer.
  if bfp!: nmbr and fixp k and k > 0 then
    if (k := preci!: nmbr - k) = 0 then nmbr
      else if k < 0 then incprec!:(nmbr, -k)
           else round!:last(decprec!:(nmbr, k - 1))
   else bflerrmsg 'conv!:mt$


symbolic procedure conv!:ep(nmbr, k);
% This function converts a number "n" to an
%      equivalent number having the exponent K
%      by rounding "n" or adding "0"s to "n".
% NMBR is a BIG-FLOAT representation of "n".
% K is an integer (positive or negative).
  if bfp!: nmbr and fixp k then
    if (k := k - ep!: nmbr) = 0 then nmbr
       else if k < 0 then incprec!:(nmbr, -k)
            else round!:last(decprec!:(nmbr, k - 1))
   else bflerrmsg 'conv!:ep$


symbolic procedure cut!:mt(nmbr,k);
% This function returns a given number "n" unchanged
%      if its precision is not greater than K, else it
%      cuts off its mantissa at the (K+1)th place and
%      returns an equivalent number of precision K.
% **** CAUTION!  No rounding is made.
% NMBR is a BIG-FLOAT representation of "n".
% K is a positive integer.
  if bfp!: nmbr and fixp k and k > 0 then
     if (k := preci!: nmbr - k) <= 0 then nmbr
             else decprec!:(nmbr, k)
   else bflerrmsg 'cut!:mt$


symbolic procedure cut!:ep(nmbr, k);
% This function returns a given number "n" unchanged
%      if its exponent is not less than K, else it
%      cuts off its mantissa and returns an equivalent
%      number of exponent K.
% **** CAUTION!  No rounding is made.
% NMBR is a BIG-FLOAT representation of "n".
% K is an integer (positive or negative).
  if bfp!: nmbr and fixp k then
     if (k := k - ep!: nmbr) <= 0 then nmbr
        else decprec!:(nmbr, k)
   else bflerrmsg 'cut!:ep$


symbolic procedure match!:(n1,n2);
% This function converts either "n1" or "n2" so that they
%      have the same exponent, which is the smaller of
%      the exponents of "n1" and "n2".
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
% **** CAUTION!  Using this function, one of the previous
% ****           expressions of "n1" and "n2" is lost.
 if bfp!: n1 and bfp!: n2 then
    begin integer e1,e2;  scalar n;
          if (e1 := ep!: n1) = (e2 := ep!: n2) then return t;
          if e1 > e2 then << rplaca(n1, car(n := conv!:ep(n1, e2)));
                             rplacd(n1, cdr n) >>
           else << rplaca(n2, car(n := conv!:ep(n2, e1)));
                   rplacd(n2, cdr n) >>;
          return t;
    end
   else bflerrmsg 'match!:$


symbolic procedure round!:mt(nmbr, k);
% This function rounds a number "n" at the (K+1)th place
%      and returns an equivalent number of precision K
%      if the precision of "n" is greater than K, else
%      it returns the given number unchanged.
% NMBR is a BIG-FLOAT representation of "n".
% K is a positive integer.
  if bfp!: nmbr and fixp k and k > 0 then
    if (k := preci!: nmbr - k - 1) < 0 then nmbr
       else if k = 0 then round!:last nmbr
           else round!:last decprec!:(nmbr, k)
   else bflerrmsg 'round!:mt$


symbolic procedure round!:ep(nmbr, k);
% This function rounds a number "n" and returns an
%      equivalent number having the exponent K if
%      the exponent of "n" is less than K, else
%      it returns the given number unchanged.
% NMBR is a BIG-FLOAT representation of "n".
% K is an integer (positive or negative).
  if bfp!: nmbr and fixp k then
    if (k := k - 1 - ep!: nmbr) < 0 then nmbr
      else if k = 0 then round!:last nmbr
      else round!:last decprec!:(nmbr, k)
   else bflerrmsg 'round!:ep$


symbolic procedure round!:last nmbr;
% This function rounds a number "n" at its last place.
% NMBR is a BIG-FLOAT representation of "n".
begin scalar n;
   n := divide(abs mt!: nmbr, 10);
   if cdr n < 5 then n := car n else n := car n + 1;
   if mt!: nmbr < 0 then n := -n;
   return make!:bf(n, ep!: nmbr + 1);
end$


%*************************************************************
%**                                                         **
%** 1-7. Routines for reading/printing numbers.             **
%**                                                         **
%*************************************************************

symbolic procedure allfixp l;            %JBM
% Returns T if all of L are FIXP.        %JBM
if null l then t                         %JBM
  else if not fixp car l then nil        %JBM
  else allfixp cdr l;                    %JBM


symbolic procedure read!:lnum(l);
% This function reads a long number "n" represented by a list in a way
% described below, and constructs a BIG-FLOAT representation of "n".
% L is a list of integers, the first element of which gives the order of
% "n" and all the next elements when concatenated give the mantissa of
% "n".
% **** ORDER(n)=k if 10**k <= ABS(n) < 10**(k+1).
% **** Except for the first element, all integers in L
% ****      should not begin with "0" because some
% ****      systems suppress leading zeros.
% JBM: Fix some kludgy coding here.
% JBM: Add BFSAVEPREC!* precision saver.
if not allfixp l then bflerrmsg 'read!:lnum
 else begin scalar mt, ep, k, sign, u, v, dcnt;
          mt := dcnt := 0;      %JBM
%          ep := car(u := l) + 1;   %JBM
          u := l;
          ep := add1 car u;
          sign := if minusp cadr l then -1 else 1;   %JBM
          while u:=cdr u do
            << k := length explode(v := abs car u);  %JBM
%               k := 0;  %JBM
%               while v do << k := k + 1; v := cdr v >>;  %JBM
               mt := mt * 10**k + v; %JBM
               ep := ep - k;
               dcnt := dcnt +  k;    % JBM
               if bfsaveprec!* and dcnt > bfsaveprec!* then  %JBM
                  u := '(nil) >>;     %JBM
          return make!:bf(sign * mt, ep);
    end$


symbolic procedure read!:num(n);
% This function reads a number or a number-like entity N
%      and constructs a BIG-FLOAT representation of it.
% N is an integer, a floating-point number, or a string
%      representing a number.
% **** If the system does not accept or may incorrectly
% ****      accept the floating-point numbers, you can
% ****      input them as strings such as "1.234E-56",
% ****      "-78.90 D+12" , "+3456 B -78", or "901/234".
% **** A rational number in a string form is converted
% ****      to a <BIG-FLOAT> of precision !:PREC!: if
% ****      !:PREC!: is not NIL, else the precision of
% ****      the result is set 50.
% **** Some systems set the maximum size of strings.  If
% ****      you want to input long numbers exceeding
% ****      such a maximum size, please use READ!:LNUM.
if fixp n then make!:bf(n, 0)
else if not(numberp n or stringp n) then bflerrmsg 'read!:num
else
    begin integer j,m,sign;  scalar ch,u,v,l,appear!.,appear!/;
          j := m := 0;
          sign := 1;
          u := v := appear!. := appear!/ := nil;
          l := explode n;
    loop: ch := car l;
          if digit ch then << u := ch . u; j := j + 1 >>
           else if ch eq '!. then << appear!. := t; j := 0 >>
           else if ch eq '!/ then << appear!/ := t; v := u; u := nil >>
           else if ch eq '!- then sign := -1
           else if ch memq '(!E !D !B !e !d !b) then go to jump;  %JBM
    endl: if l := cdr l then goto loop else goto make;
    jump: while l := cdr l do
            <<if digit(ch := car l) or ch eq '!-
                 then v := ch . v >>;
          l := reverse v;
          if car l eq '!- then m := - compress cdr l
                          else m:= compress l;
    make: u := reverse u;
          v := reverse v;
          if appear!/ then 
            return conv!:r2bf(make!:ratnum(sign*compress v,compress u),
                              if !:prec!: then !:prec!: else 50);
          if appear!. then j := - j else j := 0;
          if sign = 1 then u := compress u else u := - compress u;
          return make!:bf(u, j + m);
    end$


symbolic procedure print!:bf(nmbr, type);
% This function prints a number "n" in the print-type TYPE.
% NMBR is a BIG-FLOAT representation of "n".
% TYPE is either 'N, 'I, 'E, 'F, 'L, 'R, meaning as:
%      TYPE='N ... the internal representation is printed.
%      TYPE='I ... the integer part is printed.
%      TYPE='E ... <mantissa in form *.***>E<exponent>.
%      TYPE='F ... <integer part>.<decimal part>.
%      TYPE='L ... in a list form readable by READ!:LNUM.
%      TYPE='R ... printed as a rational number.
% **** The number is printed by being inserted a blank
% ****      after each five characters.  Therefore, you
% ****      can not use the printed numbers as input data,
% ****      except when they are printed in type 'L.
if not(type memq '(n i e f l r))         %JBM
   or not bfp!: nmbr then bflerrmsg 'print!:bf
else
    begin integer j,k;  scalar u,v;
%          if bfzerop!: nmbr  then nmbr:=make!:bf(0, 0);
          if bfzerop!: nmbr then nmbr := !:bf!-0;    %JBM
          if type eq 'i then goto itype
           else if type eq 'e then goto etype
           else if type eq 'f then goto ftype
           else if type eq 'l then goto ltype
           else if type eq 'r then goto rtype;
   ntype: print nmbr;
          return t;
   itype: u := explode conv!:bf2i nmbr;
          j := 0;
          while u do << prin2 car u; u := cdr u; j := j + 1;
                        if j = 5 then << prin2 " "; j := 0 >> >>;
          terpri();
          return t;
   etype: u := explode abs(j := mt!: nmbr);
          if null cdr u then rplacd(u , list 0);
          if j >= 0 then u := car u . ('!. . cdr u)
           else u := '!- . (car u . ('!. . cdr u));
          j := 0;
          while u do << prin2 car u; u := cdr u; j := j + 1;
                        if j = 5 then << prin2 " "; j := 0 >> >>;
          if j = 0 then << prin2 "E "; j := 2 >>
           else if j = 1 then << prin2 " E "; j := 4 >>
           else if j = 2 then << prin2 " E  "; j := 0 >>
           else if j = 3 then << prin2 " E "; j := 0 >>
           else if j = 4 then << prin2 "  E "; j := 2 >>;
          u := explode(k := order!: nmbr);
          if k >= 0 then u := '!+ . u;
          while u do << prin2 car u; u := cdr u; j := j + 1;
                        if j=5 then << prin2 " "; j := 0 >> >>;
          terpri();
          return t;
   ftype: u := explode abs mt!: nmbr;
          if (j := ep!: nmbr) >= 0 then
               << v := nil; while (j := j - 1) >= 0 do v := 0 . v;
                  u := nconc(u, v) >>
           else if (j := order!: nmbr + 1) > 0 then
               << v := u; while (j := j - 1) > 0 do v := cdr v;
                  rplacd(v, '!. . cdr v) >>
           else << while (j := j + 1) <= 0 do u := 0 . u;
                   u := 0 . ('!. . u) >>;
          if mt!: nmbr < 0 then u := '!- . u;
          j := 0;
          while u do << prin2 car u; u := cdr u; j := j + 1;
                        if j = 5 then << prin2 " "; j := 0 >> >>;
          terpri();
          return t;
   ltype: prin2 " '(";
          prin2 order!: nmbr;
          prin2 "  ";
          u := explode mt!: nmbr;
          j := 0;
          while u do << prin2 car u; u := cdr u; j := j + 1;
                       if j >= 5 and u and not(car u eq '!0)
                          then <<prin2 " "; j := j - 5 >> >>;
          prin2 ")";
          terpri();
          return t;
   rtype: print!:ratnum conv!:bf2r nmbr;
          return t;
    end$


symbolic procedure print!:ratnum rnmbr;
% This function prints a rational number "n".
% RNMBR is a rational number representation of "n".
% **** The number is printed by being inserted a blank
% ****      after each five characters.  So, you can
% ****      not use the printed numbers as input data.
if not ratnump!: rnmbr then bflerrmsg 'print!:ratnum
 else
    begin integer j;  scalar u, v;
          u := numr!: rnmbr;
          v := denm!: rnmbr;
          if v < 0 then << u := - u; v := - v >>;
          j := 0;
          for each d in explode u        %JBM loop here.
              do << prin2 d; j := j + 1;
                    if j = 5 then << prin2 " "; j := 0 >> >>;
          if j = 0 then << prin2 "/ "; j := 2 >>
           else if j = 1 then << prin2 " / "; j := 4 >>
           else if j = 2 then << prin2 " /  "; j := 0 >>
           else if j = 3 then << prin2 " / "; j := 0 >>
           else if j = 4 then << prin2 "  / "; j := 2 >>;
          for each d in explode v        %JBM loop here.
              do << prin2 d; j := j + 1;
                    if j = 5 then << prin2 " "; j := 0 >> >>;
          terpri();
          return t;
    end$


%*************************************************************
%**                                                         **
%** 2-1. Arithmetic manipulation routines.                  **
%**                                                         **
%*************************************************************

symbolic procedure abs!: nmbr;
% This function makes the absolute value of "n".
% N is a BIG-FLOAT representation of "n".
  if mt!: nmbr > 0 then nmbr
   else make!:bf(- mt!: nmbr, ep!: nmbr)$


symbolic procedure minus!: nmbr;
% This function makes the minus number of "n".
% N is a BIG-FLOAT representation of "n".
   make!:bf(- mt!: nmbr, ep!: nmbr)$


symbolic procedure plus!:(n1, n2);
% This function calculates the sum of "n1" and "n2".
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
  begin integer e1, e2;
        if (e1 := ep!: n1) = (e2 := ep!: n2) then return
           make!:bf(mt!: n1 + mt!: n2, e1)
         else if e1 > e2 then return 
           make!:bf(mt!: incprec!:(n1, e1 - e2) + mt!: n2, e2)
         else return
           make!:bf(mt!: n1 + mt!: incprec!:(n2, e2 - e1), e1);
  end$


symbolic procedure difference!:(n1, n2);
% This function calculates the difference of "n1" and "n2".
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
  begin integer e1,e2;
        if (e1 := ep!: n1) = (e2 := ep!: n2) then return
           make!:bf(mt!: n1 - mt!: n2, e1)
        else if e1 > e2 then return
           make!:bf(mt!: incprec!:(n1, e1 - e2) - mt!: n2, e2)
        else return
           make!:bf(mt!: n1 - mt!: incprec!:(n2, e2 - e1), e1);
  end$


symbolic procedure times!:(n1, n2);
% This function calculates the product of "n1" and "n2".
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
  make!:bf(mt!: n1 * mt!: n2, ep!: n1 + ep!: n2)$


 symbolic procedure divide!:(n1,n2,k);
% This function calculates the quotient of "n1" and "n2",
%      with the precision K, by rounding the ratio of "n1"
%      and "n2" at the (K+1)th place.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
% K is any positive integer.
begin
  n1 := conv!:mt(n1, k + preci!: n2 + 1);
  n1 := make!:bf(mt!: n1 / mt!: n2, ep!: n1 - ep!: n2);
  return round!:mt(n1, k);
end$


symbolic procedure expt!:(nmbr, k);
% This function calculates the Kth power of "n".
%      The result will become a long number if
%      ABS(K) >> 1.
% NMBR is a BIG-FLOAT representation of "n".
% K is an integer (positive or negative).
% **** For calculating a power X**K, with non-
% ****      integer K, please use TEXPT!:ANY.
if k >= 0 then
   make!:bf(mt!: nmbr ** k, ep!: nmbr * k)
% else divide!:(make!:bf(1, 0), expt!:(nmbr, - k),
 else divide!:(!:bf!-1, expt!:(nmbr, - k),    %JBM
                               - preci!: nmbr * k)$


symbolic procedure tplus!:(n1, n2);
% This function calculates the sum of "n1" and "n2"
%      up to a precision specified by !:PREC!: or N1 or N2.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2",
%      otherwise they are converted to <BIG-FLOAT>'s.
if bfp!:(n1 := conv!:a2bf n1) and
   bfp!:(n2 := conv!:a2bf n2) then
     round!:mt(plus!:(n1, n2), 
               (if !:prec!: then !:prec!:
                 else max(preci!: n1, preci!: n2)))
   else bflerrmsg 'tplus!:$


symbolic procedure tdifference!:(n1, n2);
% This function calculates the difference of "n1" and "n2"
%      up to a precision specified by !:PREC!: or N1 or N2.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2",
%      otherwise they are converted to <BIG-FLOAT>'s.
if bfp!:(n1 := conv!:a2bf n1) and
   bfp!:(n2 := conv!:a2bf n2) then
    round!:mt(difference!:(n1, n2),
              (if !:prec!: then !:prec!:
                           else max(preci!: n1, preci!: n2)))
   else bflerrmsg 'tdifference!:$


symbolic procedure ttimes!:(n1, n2);
% This function calculates the product of "n1" and "n2"
%      up to a precision specified by !:PREC!: or N1 or N2.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2",
%      otherwise they are converted to <BIG-FLOAT>'s.
if bfp!:(n1 := conv!:a2bf n1) and
   bfp!:(n2 := conv!:a2bf n2) then
    round!:mt(times!:(n1, n2),
              (if !:prec!: then !:prec!:
                else max(preci!: n1, preci!: n2)))
   else bflerrmsg 'ttimes!:$


symbolic procedure tdivide!:(n1, n2);
% This function calculates the quotient of "n1" and "n2"
%      up to a precision specified by !:PREC!: or N1 or N2.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2",
%      otherwise they are converted to <BIG-FLOAT>'s.
if bfp!:(n1 := conv!:a2bf n1) and
   bfp!:(n2 := conv!:a2bf n2) then
    divide!:(n1,
             n2,
             (if !:prec!: then !:prec!:
              else max(preci!: n1, preci!: n2)))
   else bflerrmsg 'tdivide!:$


symbolic procedure texpt!:(nmbr, k);
% This function calculates the Kth power of "n" up to
%      the precision specified by !:PREC!: or NMBR.
% NMBR is a BIG-FLOAT representation of "n",
%      otherwise it is converted to a <BIG-FLOAT>.
% K is an integer (positive or negative).
% **** For calculating a power X**K, where K is not
% ****      an integer, please use TEXPT!:ANY.
if bfp!:(nmbr := conv!:a2bf nmbr) and fixp k then
%    if k = 0 then make!:bf(1, 0)
    if zerop k then !:bf!-1    %JBM
     else if k = 1 then nmbr
%     else if k < 0 then tdivide!:(make!:bf(1, 0),
     else if minusp k then tdivide!:(!:bf!-1,   %JBM
                                  texpt!:(nmbr, - k))
     else texpt!:cal(nmbr, k,
                     (if !:prec!: then !:prec!: else preci!: nmbr))
   else bflerrmsg 'texpt!:$


symbolic procedure texpt!:cal(nmbr,k,prec);
if k=1 then nmbr
 else begin integer k2;  scalar u;
          u := round!:mt(times!:(nmbr, nmbr), prec);
          if k = 2 then return u
           else if (k - 2 * (k2 := k / 2)) = 0 then return
               texpt!:cal(u, k2, prec)
           else return round!:mt
               (times!:(nmbr, texpt!:cal(u, k2, prec)), prec);
      end$


symbolic procedure quotient!:(n1, n2);
% This function calculates the integer quotient of "n1"
%      and "n2", just as the "QUOTIENT" for integers does.
% **** For calculating the quotient up to a necessary
% ****      precision, please use DIVIDE!:.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
begin integer e1, e2;
  if (e1 := ep!: n1) = (e2 := ep!: n2) then return
             make!:bf(mt!: n1 / mt!: n2, 0)
   else if e1 > e2 then return
             quotient!:(incprec!:(n1, e1 - e2) , n2)
   else return
             quotient!:(n1, incprec!:(n2, e2 - e1));
end$


symbolic procedure remainder!:(n1, n2);
% This function calculates the remainder of "n1" and "n2",
%      just as the "REMAINDER" for integers does.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
begin integer e1, e2;
  if (e1 := ep!: n1) = (e2 := ep!: n2) then return
      make!:bf(remainder(mt!: n1, mt!: n2), e2)
   else if e1 > e2 then return
      remainder!:(incprec!:(n1, e1 - e2), n2)
   else return
      remainder!:(n1, incprec!:(n2, e2 - e1));
end$


symbolic procedure texpt!:any(x, y);
% This function calculates the power x**y, where "x"
%      and "y" are any numbers.  The precision of
%      the result is specified by !:PREC!: or X or Y.
% **** For a negative "x", this function returns
% ****      -(-x)**y unless "y" is an integer.
% X is a BIG-FLOAT representation of "x", otherwise
%      it is converted to a <BIG-FLOAT>.
% Y is either an integer, a floating-point number,
%      or a BIG-FLOAT number, i.e., a BIG-FLOAT
%      representation of "y".
if fixp y then texpt!:(x, y)
 else if integerp!: y then texpt!:(x, conv!:bf2i y)
 else if not bfp!:(x := conv!:a2bf x) or
         not bfp!:(y := conv!:a2bf y) then bflerrmsg 'texpt!:any
% else if minusp!: y then tdivide!:(make!:bf(1, 0),
 else if minusp!: y then tdivide!:(!:bf!-1,    %JBM
                                   texpt!:any(x, minus!: y))
 else begin integer n;  scalar xp, yp;
          n := (if !:prec!: then !:prec!:
                else max(preci!: x, preci!: y));
          if minusp!: x then xp:=minus!: x else xp := x;
          if integerp!: times!:(y, conv!:i2bf 2) then  %CONSTANT
             << xp := incprec!:(xp, 1);
                yp := texpt!:(xp, conv!:bf2i y);
                yp := times!:(yp, sqrt!:(xp, n + 1)); 
                yp := round!:mt(yp, n) >>
          else
             << yp := ttimes!:(y, log!:(xp, n + 1));
                yp := exp!:(yp, n) >>;

          return (if minusp!: x then minus!: yp else yp);
     end$


symbolic procedure max!:(n1,n2);
% This function returns the larger of "n1" and "n2".
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
  if greaterp!:(n2, n1) then n2 else n1$


symbolic procedure min!:(n1,n2);
% This function returns the smaller of "n1" and "n2".
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
  if lessp!:(n2, n1) then n2 else n1$


%*************************************************************
%**                                                         **
%** 2-2. Arithmetic predicates.                             **
%**                                                         **
%*************************************************************

symbolic procedure greaterp!:(n1, n2);
% This function returns T if "n1" > "n2" else returns NIL.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
begin integer e1,e2;
  if (e1 := ep!: n1) = (e2 := ep!: n2) then
     return (mt!: n1 > mt!: n2)          %JBM
  else if e1 > e2 then
     return mt!: incprec!:(n1, e1 - e2) > mt!: n2   %JBM
  else 
     return mt!: n1 > mt!: incprec!:(n2, e2 - e1)   %JBM
end$


symbolic procedure geq!:(n1, n2);
% This function returns T if "n1" >= "n2" else returns NIL.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
  not lessp!:(n1, n2)$


symbolic procedure equal!:(n1,n2);
% This function returns T if "n1" = "n2" else returns NIL.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
 bfzerop!: difference!:(n1, n2)$


symbolic procedure lessp!:(n1, n2);
% This function returns T if "n1" < "n2" else returns NIL.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
  greaterp!:(n2, n1)$


symbolic procedure leq!:(n1, n2);
% This function returns T if "n1" <= "n2" else returns NIL.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
  not greaterp!:(n1, n2)$


symbolic procedure integerp!: x;
% This function returns T if X is a BIG-FLOAT
%      representing an integer, else it returns NIL.
% X is any LISP entity.
%JBM Critique: this is pretty slow. Couldn't we just check the
%JBM Critique: exponent in relation to the precision?
bfp!: x and
  (ep!: x >= 0 or
   equal!:(x, conv!:i2bf conv!:bf2i x));


symbolic procedure minusp!: x;
% This function returns T if "x"<0 else returns NIL.
% X is any LISP entity.
  bfp!: x and mt!: x < 0$


%*************************************************************
%**                                                         **
%** 3-1. Elementary CONSTANTS.                              **
%**                                                         **
%*************************************************************

symbolic procedure !:pi k;
% This function calculates the value of the circular
%      constant "PI", with the precision K, by
%      using Machin's well known identity:
%         PI = 16*atan(1/5) - 4*atan(1/239).
%      Calculation is performed mainly on integers.
% K is a positive integer.
if not fixp k or k <= 0 then bflerrmsg '!:pi
 else if k <= 20 then
%   round!:mt(make!:bf(314159265358979323846, -20), k)
   round!:mt(!:bf!-pi, k)    %JBM
 else
    begin integer k3,s,ss,m,n,x;  scalar u;

          u := get!:const('!:pi, k);
          if u neq "NOT FOUND" then return u;
          ss := n := 10 ** (k3 := k + 3) / 5;
          x := -5 ** 2;
          m := 1;
          while n neq 0 do <<n := n/x; ss := ss + n/(m := m + 2)>>;
          s := n := 10 ** k3 / 239;
          x := -239 ** 2;
          m := 1;
          while n neq 0 do << n := n / x; s := s + n / (m := m + 2) >>;
     ans: u := round!:mt(make!:bf(16 * ss - 4 * s, - k3), k);
          save!:const('!:pi, u);
          return u;
    end$


symbolic procedure !:bigpi k;
% This function calculates the value of the circular
%      constant "PI", with the precision K, by the
%      arithmetic-geometric mean method.  (See,
%      R. Brent, JACM Vol.23, #2, pp.242-251(1976).)
% K is a positive integer.
% **** This function should be used only when you
% ****      need "PI" of precision higher than 1000.
if not fixp k or k <= 0 then bflerrmsg '!:bigpi
 else begin integer k2, n;  scalar dcut, half, x, y, u, v;
          u := get!:const('!:pi, k);
          if u neq "NOT FOUND" then return u;
          k2 := k + 2;
%          half := conv!:s2bf "0.5";      %constant
          half := !:bf!-0!.5;    %JBM
          dcut := make!:bf(10, - k2);
          x := conv!:i2bf(n := 1);
          y := divide!:(x, !:sqrt2 k2, k2);
%          u := conv!:s2bf "0.25";        %constant
          u := !:bf!-0!.25;    %JBM
          while greaterp!:(abs!: difference!:(x, y), dcut) do
            << v := x;
               x := times!:(plus!:(x, y), half);
               y := sqrt!:(cut!:ep(times!:(y, v), - k2), k2);
               v := difference!:(x, v);
               v := times!:(times!:(v, v), conv!:i2bf n);
               u := difference!:(u, cut!:ep(v, - k2));
               n := 2 * n >>;
          v := cut!:mt(expt!:(plus!:(x, y), 2), k2);
          u := divide!:(v, times!:(conv!:i2bf 4, u), k); %CONSTANT
          save!:const('!:pi, u);
          return u;
    end$


symbolic procedure !:e k;
% This function calculates the value of "e", the base
%      of the natural logarithm, with the precision K,
%      by summing the Taylor series for exp(x=1).
%      Calculation is performed mainly on integers.
% K is a positive integer.
if not fixp k or k <= 0 then bflerrmsg '!:e
 else if k <= 20 then
%   round!:mt(make!:bf(271828182845904523536, -20), k)
   round!:mt(!:bf!-e, k)    %JBM
 else begin integer k2, ans, m, n;  scalar u;
          u := get!:const('!:e, k);
          if u neq "NOT FOUND" then return u;
          k2 := k + 2;
          m := 1;
          n := 10 ** k2;
          ans := 0;
          while n neq 0  do ans := ans + (n := n / (m := m + 1));
          ans := ans + 2 * 10 ** k2;
          u := round!:mt(make!:bf(ans, - k2), k);
          save!:const('!:e2, u);
          return u;
       end$


symbolic procedure !:e01(k);
% This function calculates exp(0.1), the value of the
%      exponential function at the point 0.1, with
%      the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:e01, k);
  if u neq "NOT FOUND" then return u;
%  u := exp!:(conv!:s2bf "0.1", k);       %constant
  u := exp!:(!:bf!-0!.1, k);    %JBM
  save!:const('!:e01, u);
  return u;
end$


symbolic procedure !:log2 k;
% This function calculates log(2), the natural
%      logarithm of 2, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:log2, k);
  if u neq "NOT FOUND" then return u;
  u := log!:(conv!:i2bf 2, k);           %CONSTANT
  save!:const('!:log2, u);
  return u;
end$


symbolic procedure !:log3 k;
% This function calculates log(3), the natural
%      logarithm of 3, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:log3, k);
  if u neq "NOT FOUND" then return u;
  u := log!:(conv!:i2bf 3, k);           %CONSTANT
  save!:const('!:log3, u);
  return u;
end$


symbolic procedure !:log5 k;
% This function calculates log(5), the natural
%      logarithm of 5, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:log5, k);
  if u neq "NOT FOUND" then return u;
  u := log!:(conv!:i2bf 5, k);           %CONSTANT
  save!:const('!:log5, u);
  return u;
end$


symbolic procedure !:log10 k;
% This function calculates log(10), the natural
%      logarithm of 10, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:log10,  k);
  if u neq "NOT FOUND" then return u;
  u := log!:(conv!:i2bf 10, k);          %CONSTANT
  save!:const('!:log10, u);
  return u;
end$


symbolic procedure !:logpi k;
% This function calculates log(PI), the natural
%      logarithm of "PI", with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:logpi, k);
  if u neq "NOT FOUND" then return u;
  u := log!:(!:pi(k + 2), k);
  save!:const('!:logpi, u);
  return u
end$


symbolic procedure !:sqrt2(k);
% This function calculates SQRT(2), the square root
%      of 2, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:sqrt2, k);
  if u neq "NOT FOUND" then return u;
  u := sqrt!:(conv!:i2bf 2, k);          %CONSTANT
  save!:const('!:sqrt2, u);
  return u;
end$


symbolic procedure !:sqrt3(k);
% This function calculates SQRT(3), the square root
%      of 3, with the precision K.
% K is a positive integer.
begin scalar u;
  u:=get!:const('!:sqrt3, k);
  if u neq "NOT FOUND" then return u;
  u := sqrt!:(conv!:i2bf 3, k);          %CONSTANT
  save!:const('!:sqrt3, u);
  return u;
end$


symbolic procedure !:sqrt5 k;
% This function calculates SQRT(5), the square root
%      of 5, with the precision K. 
% K is a positive integer.
begin scalar u;
  u := get!:const('!:sqrt5, k);
  if u neq "NOT FOUND" then return u;
  u := sqrt!:(conv!:i2bf 5, k);          %CONSTANT
  save!:const('!:sqrt5, u);
  return u;
end$


symbolic procedure !:sqrt10 k;
% This function calculates SQRT(10), the square root
%      of 10, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:sqrt10, k);
  if u neq "NOT FOUND" then return u;
  u := sqrt!:(conv!:i2bf 10, k);         %CONSTANT
  save!:const('!:sqrt10, u);
  return u;
end$


symbolic procedure !:sqrtpi k;
% This function calculates SQRT(PI), the square root
%      of "PI", with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:sqrtpi, k);
  if u neq "NOT FOUND" then return u;
  u := sqrt!:(!:pi(k + 2), k);
  save!:const('!:sqrtpi, u);
  return u;
end$


symbolic procedure !:sqrte k;
% This function calculates SQRT(e), the square root
%      of "e", with the precision K.
% K is a positive integer.
begin scalar u;
  u:=get!:const('!:sqrte, k);
  if u neq "NOT FOUND" then return u;
  u := sqrt!:(!:e(k + 2), k);
  save!:const('!:sqrte, u);
  return u;
end$


symbolic procedure !:cbrt2 k;
% This function calculates CBRT(2), the cube root
%      of 2, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrt2, k);
  if u neq "NOT FOUND" then return u;
  u := cbrt!:(conv!:i2bf 2, k);          %CONSTANT
  save!:const('!:cbrt2, u);
  return u;
end$


symbolic procedure !:cbrt3 k;
% This function calculates CBRT(3), the cube root
%      of 3, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrt3, k);
  if u neq "NOT FOUND" then return u;
  u := cbrt!:(conv!:i2bf 3, k);
  save!:const('!:cbrt3, u);
  return u;
end$


symbolic procedure !:cbrt5 k;
% This function calculates CBRT(5), the cube root
%    of 5, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrt5, k);
  if u = "NOT FOUND" then return u;
  u := cbrt!:(conv!:i2bf 5, k);          %CONSTANT
  save!:const('!:cbrt5, u);
  return u;
end$


symbolic procedure !:cbrt10 k;
% This function calculates CBRT(10), the cube root
%      of 10, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrt10, k);
  if u neq "NOT FOUND" then return u;
  u := cbrt!:(conv!:i2bf 10, k);         %CONSTANT
  save!:const('!:cbrt10, u);
  return u;
end$


symbolic procedure !:cbrtpi k;
% This function calculates CBRT(PI), the cube root
%      of "PI", with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrtpi, k);
  if u neq "NOT FOUND" then return u;
  u := cbrt!:(!:pi(k + 2), k);
  save!:const('!:cbrtpi, u);
  return u;
end$


symbolic procedure !:cbrte k;
% This function calculates CBRT(e), the cube root
%      of "e", with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrte, k);
  if u neq "NOT FOUND" then return u;
  u := cbrt!:(!:e(k + 2), k);
  save!:const('!:cbrte, u);
  return u;
end$


%*************************************************************
%**                                                         **
%** 3-2. Routines for saving CONSTANTS.                     **
%**                                                         **
%*************************************************************

symbolic procedure get!:const(cnst, k);
% This function returns the value of constant CNST
%      of the precision K, if it was calculated
%      previously with, at least, the precision K,
%      else it returns "NOT FOUND".
% CNST is the name of the constant (to be quoted).
% K is a positive integer.
  if atom cnst and fixp k and k > 0 then
    begin scalar u;
          u := get(cnst, 'save!:c);
          if null u or car u < k then return "NOT FOUND"
           else if car u = k then return cdr u
                             else return round!:mt(cdr u, k);
    end
   else bflerrmsg 'get!:const$


symbolic procedure save!:const(cnst, nmbr);
% This function saves the value of constant CNST
%      for the later use.
% CNST is the name of the constant (to be quoted).
% NMBR is a BIG-FLOAT representation of the value.
  if atom cnst and bfp!: nmbr then
       put(cnst, 'save!:c, preci!: nmbr . nmbr)
   else bflerrmsg 'save!:const$


symbolic procedure set!:const(cnst, l);
% This function sets the value of constant CNST.
% CNST is the name of the constant (to be quoted).
% L is a list of integers, which represents the
%      value of the constant in the way described
%      in the function READ!:LNUM.
     save!:const(cnst, read!:lnum l)$


% Setting the constants.


set!:const( '!:pi    , '( 0   3141 59265 35897 93238 46264
     33832 79502 88419 71693 99375 105820 9749 44592 30781
     64062 86208 99862 80348 25342 11706 79821 48086 51328
     23066 47093 84460 95505 82231 72535 94081 28481 1174
    5028410 2701 93852 11055 59644 62294 89549 30381 96442
     88109 8) )$

set!:const( '!:e     , '( 0   2718 28182 84590 45235 36028
     74713 52662 49775 72470 93699 95957 49669 67627 72407
     66303 53547 59457 13821 78525 16642 74274 66391 93200
     30599 21817 41359 66290 43572 90033 42952 60595 63073
     81323 28627 943490 7632 33829 88075 31952 510190 1157
     38341 9) )$

set!:const( '!:e01   , '( 0   1105 17091 80756 47624 81170
     78264 90246 66822 45471 94737 51871 87928 63289 44096
     79667 47654 30298 91433 18970 74865 36329 2) )$

set!:const( '!:log2  , '(-1   6931 47180 55994 53094 17232
     12145 81765 68075 50013 43602 55254 1206 800094 93393
     62196 96947 15605 86332 69964 18687 54200 2) )$

set!:const( '!:log3  , '( 0   1098 61228 866810 9691 39524
     52369 22525 70464 74905 57822 74945 17346 94333 63749
     42932 18608 96687 36157 54813 73208 87879 7) )$

set!:const( '!:log5  , '( 0   1609 43791 2434100 374 60075
     93332 26187 63952 56013 54268 51772 19126 47891 47417
     898770 7657 764630 1338 78093 179610 7999 7) )$

set!:const( '!:log10 , '( 0   2302 58509 29940 456840 1799
     14546 84364 20760 11014 88628 77297 60333 27900 96757
     26096 77352 48023 599720 5089 59829 83419 7) )$

set!:const( '!:logpi , '( 0   1144 72988 5849400 174 14342
     73513 53058 71164 72948 12915 31157 15136 23071 47213
     77698 848260 7978 36232 70275 48970 77020 1) )$

set!:const( '!:sqrt2 , '( 0   1414 21356 23730 95048 80168
     872420 96980 7856 96718 75376 94807 31766 79737 99073
     24784 621070 38850 3875 34327 64157 27350 1) )$

set!:const( '!:sqrt3 , '( 0   17320 5080 75688 77293 52744
     634150 5872 36694 28052 53810 38062 805580 6979 45193
     301690 88000 3708 11461 86757 24857 56756 3) )$

set!:const( '!:sqrt5 , '( 0   22360 6797 74997 89696 40917
     36687 31276 235440 6183 59611 52572 42708 97245 4105
    209256 37804 89941 441440 8378 78227 49695 1) )$

set!:const( '!:sqrt10, '( 0   3162 277660 1683 79331 99889
     35444 32718 53371 95551 39325 21682 685750 4852 79259
     44386 39238 22134 424810 8379 30029 51873 47))$

set!:const( '!:sqrtpi, '( 0   1772 453850 9055 16027 29816
     74833 41145 18279 75494 56122 38712 821380 7789 85291
     12845 91032 18137 49506 56738 54466 54162 3) )$

set!:const( '!:sqrte , '( 0   1648 721270 7001 28146 8486
    507878 14163 57165 3776100 710 14801 15750 79311 64066
     10211 94215 60863 27765 20056 36664 30028 7) )$

set!:const( '!:cbrt2 , '( 0   1259 92104 98948 73164 7672
    106072 78228 350570 2514 64701 5079800 819 75112 15529
     96765 13959 48372 93965 62436 25509 41543 1) )$

set!:const( '!:cbrt3 , '( 0   1442 249570 30740 8382 32163
     83107 80109 58839 18692 53499 35057 75464 16194 54168
     75968 29997 33985 47554 79705 64525 66868 4) )$

set!:const( '!:cbrt5 , '( 0   1709 97594 66766 96989 35310
     88725 43860 10986 80551 105430 5492 43828 61707 44429
     592050 4173 21625 71870 10020 18900 220450 ) )$

set!:const( '!:cbrt10, '( 0   2154 4346900 318 83721 75929
     35665 19350 49525 93449 42192 10858 24892 35506 34641
     11066 48340 80018 544150 3543 24327 61012 6) )$

set!:const( '!:cbrtpi, '( 0   1464 59188 75615 232630 2014
     25272 63790 39173 85968 55627 93717 43572 55937 13839
     36497 98286 26614 56820 67820 353820 89750 ) )$

set!:const( '!:cbrte , '( 0   1395 61242 50860 89528 62812
     531960 2586 83759 79065 15199 40698 26175 167060 3173
     90156 45951 84696 97888 17295 83022 41352 1) )$


%*************************************************************
%**                                                         **
%** 4-1. Elementary FUNCTIONS.                              **
%**                                                         **
%*************************************************************

symbolic procedure sqrt!:(x, k);
% This function calculates SQRT(x), the square root
%      of "x", with the precision K, by Newton's
%      iteration method.
% X is a BIG-FLOAT representation of "x", x >= 0,
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or minusp!: x or
     not fixp k or k <= 0 then bflerrmsg 'sqrt!:
    else if bfzerop!: x then conv!:i2bf 0
    else begin integer k2,ncut,nfig;  scalar dcut,half,dy,y,y0,u;
          k2 := k + 2;
          ncut := k2 - (order!: x + 1) / 2;
%          half := conv!:s2bf "0.5";
          half := !:bf!-0!.5;    %JBM
          dcut := make!:bf(10, - ncut);
          dy := make!:bf(20, - ncut);
          y0 := conv!:mt(x, 2);
          if remainder(ep!: y0, 2) = 0 then
                y0 := make!:bf(3 + 2 * mt!: y0 / 25,  ep!: y0 / 2)
           else y0 := make!:bf(10 + 2 * mt!: y0 / 9, (ep!: y0 - 1) / 2);
          nfig := 1;
          while nfig < k2 or greaterp!:(abs!: dy, dcut) do
            << if (nfig := 2 * nfig) > k2 then nfig := k2;
               u := divide!:(x, y0, nfig);
               y := times!:(plus!:(y0, u), half);
               dy := difference!:(y, y0);
               y0 := y >>;
          return round!:mt(y, k);
    end$


symbolic procedure cbrt!:(x, k);
% This function calculates CBRT(x), the cube root
%      of "x", with the precision K, by Newton's
%      iteration method.
% X is a BIG-FLOAT representation of any real "x",
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     not fixp k or k <= 0 then bflerrmsg 'cbrt!:
   else if bfzerop!: x then conv!:i2bf 0
   else if minusp!: x then minus!: cbrt!:(minus!: x, k)
   else begin integer k2, ncut, nfig, j;  scalar dcut, thre, dy, y, u;
          k2 := k + 2;
          ncut := k2 - (order!: x + 2) / 3;
          thre := conv!:i2bf 3;
          dcut := make!:bf(10, - ncut);
          dy := make!:bf(20, - ncut);
          y := conv!:mt(x, 3);
          if (j := remainder(ep!: y, 3)) = 0 then
               y := make!:bf(5 + mt!: y / 167, ep!: y / 3)
           else if j = 1 or j = -2 then
                y := make!:bf(10 + mt!: y / 75, (ep!: y - 1) / 3)
           else y := make!:bf(22 + 2 * mt!: y / 75, (ep!: y - 2) / 3);
          nfig := 1;
          while nfig < k2 or greaterp!:(abs!: dy, dcut) do
            << if (nfig := 2 * nfig) > k2 then nfig := k2;
               u := cut!:mt(times!:(y, y), nfig);
               u := divide!:(x, u, nfig);
               j :=order!:(u := difference!:(u, y)) + ncut - k2;
               dy := divide!:(u, thre, max(1, nfig + j));
               y := plus!:(y, dy) >>;
          return round!:mt(y, k);
    end$


symbolic procedure exp!:(x, k);
% This function calculates exp(x), the value of
%      the exponential function at the point "x",
%      with the precision K, by summing terms of
%      the Taylor series for exp(z), 0 < z < 1.
% X is a BIG-FLOAT representation of any real "x",
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     not fixp k or k <= 0 then bflerrmsg 'exp!: 
   else if bfzerop!: x then conv!:i2bf 1
   else begin integer k2, m;  scalar one, q, r, y, yq, yr, save!:p;
          k2 := k + 2;
          one := conv!:i2bf 1;
          q := conv!:i2bf(m := conv!:bf2i(y := abs!: x));
          r := difference!:(y, q);
          if bfzerop!: q then yq := one
           else << save!:p := !:prec!:;
                   !:prec!: := k2;
                   yq := texpt!:(!:e k2, m);
                   !:prec!: := save!:p >>;
          if bfzerop!: r then yr:=one
           else begin integer j, n;  scalar dcut, fctrial, ri, tm;
              dcut := make!:bf(10, - k2);
              yr := ri := tm := one;
              m := 1;
              j := 0;
              while greaterp!:(tm, dcut) do
                << fctrial := conv!:i2bf(m := m * (j := j + 1));
                   ri := cut!:ep(times!:(ri, r), - k2);
                   n := max(1, k2 - order!: fctrial + order!: ri);
                   tm := divide!:(ri, fctrial, n);
                   yr := plus!:(yr,tm);
                   if remainder(j,10)=0 then yr := cut!:ep(yr, - k2) >>;
        end;
          y := cut!:mt(times!:(yq, yr), k + 1);
          return (if minusp!: x then divide!:(one, y, k)
                  else round!:last y);
    end$


symbolic procedure log!:(x, k);
% This function calculates log(x), the value of the
%      logarithmic function at the point "x", with
%      the precision K, by summing terms of the
%      Taylor series for log(1+z), 0 < z < 0.10518.
% X is a BIG-FLOAT representation of "x", x > 0,
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     minusp!: x or bfzerop!: x or
     not fixp k or k <= 0 then bflerrmsg 'log!:
   else if equal!:(x, conv!:i2bf 1) then conv!:i2bf 0
   else begin integer k2,m;  scalar ee,es,one,sign,l,y,z,save!:p;
          k2 := k + 2;
          one := conv!:i2bf 1;
          ee := !:e k2;
          es := !:e01 k2;
          if greaterp!:(x, one) then << sign := one; y := x >>
           else << sign := minus!: one; y := divide!:(one, x, k2) >>;
          if lessp!:(y, ee) then << m := 0; z := y >>
           else << if (m := (order!: y * 23) / 10) = 0 then z := y
                    else << save!:p := !:prec!:;
                            !:prec!: := k2;
                            z := divide!:(y, texpt!:(ee, m), k2);
                            !:prec!: := save!:p >>;
                    while greaterp!:(z, ee) do
                       << m := m+1; z := divide!:(z, ee, k2) >> >>;
          l := conv!:i2bf m;
%          y := conv!:s2bf "0.1";         %constant
          y := !:bf!-0!.1;    %JBM
          while greaterp!:(z, es) do
            << l := plus!:(l, y); z := divide!:(z, es, k2) >>;
          z := difference!:(z, one);
        begin integer n;  scalar dcut, tm, zi;
              y := tm := zi := z;
              z := minus!: z;
              dcut := make!:bf(10, - k2);
              m := 1;
              while greaterp!:(abs!: tm, dcut) do
               << zi := cut!:ep(times!:(zi, z), - k2);
                  n := max(1, k2 + order!: zi);
                  tm := divide!:(zi, conv!:i2bf(m := m + 1), n);
                  y := plus!:(y, tm);
                  if zerop remainder(m,10) then y := cut!:ep(y,-k2)>>;
        end;
          y := plus!:(y, l);
          return round!:mt(times!:(sign, y), k);
    end$


symbolic procedure ln!:(x, k);
% This function calculates log(x), the value of
%      the logarithmic function at the point "x",
%      with the precision K, by solving
%         x = exp(y)  by Newton's method.
% X is a BIG-FLOAT representation of "x", x > 0,
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     minusp!: x or bfzerop!: x or
     not fixp k or k <= 0 then bflerrmsg 'ln!:
    else if equal!:(x, conv!:i2bf 1) then conv!:i2bf 0
    else begin integer k2, m;  scalar ee, one, sign, y, z, save!:p;
          k2 := k + 2;
          one := conv!:i2bf 1;
          ee := !:e(k2 + 2);
          if greaterp!:(x, one) then << sign := one; y := x >>
           else << sign := minus!: one; y := divide!:(one, x, k2) >>;
          if lessp!:(y, ee) then << m := 0; z := y >>
           else << if zerop (m := (order!: y * 23) / 10) then z := y
                    else << save!:p := !:prec!:;
                            !:prec!: := k2;
                            z := divide!:(y, texpt!:(ee, m), k2);
                            !:prec!: := save!:p >>;
                    while greaterp!:(z, ee) do
                     << m := m + 1; z := divide!:(z, ee, k2) >> >>;
        begin integer nfig, n;  scalar dcut, dx, dy, x0;
              dcut := make!:bf(10, - k2);
              dy := make!:bf(20, - k2);
%             y := divide!:(difference!:(z,one), conv!:s2bf "1.72", 2);
              y := divide!:(difference!:(z,one), !:bf!-1!.72, 2);  %JBM
              nfig := 1;
              while nfig < k2 or greaterp!:(abs!: dy, dcut) do
               << if (nfig := 2 * nfig) > k2 then nfig := k2;
                  x0 := exp!:(y, nfig);
                  dx := difference!:(z, x0);
                  n := max(1, nfig + order!: dx);
                  dy := divide!:(dx, x0, n);
                  y := plus!:(y, dy) >>;
        end;
          y := plus!:(conv!:i2bf m, y);
          return round!:mt(times!:(sign, y), k);
    end$


symbolic procedure sin!:(x, k);
% This function calculates sin(x), the value of
%      the sine function at the point "x", with
%      the precision K, by summing terms of the
%      Taylor series for sin(z), 0 < z < PI/4.
% X is a BIG-FLOAT representation of any rael "x",
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     not fixp k or k <= 0 then bflerrmsg 'sin!:
   else if bfzerop!: x then conv!:i2bf 0
   else if minusp!: x then minus!: sin!:(minus!: x, k)
   else begin integer k2, m;  scalar pi4, sign, q, r, y;
          k2 := k + 2;
          m := preci!: x;
%          pi4 := times!:(!:pi(k2 + m), conv!:s2bf "0.25"); %constant
          pi4 := times!:(!:pi(k2 + m), !:bf!-0!.25);    %JBM
          if lessp!:(x, pi4) then << m := 0; r := x >>
           else << m := conv!:bf2i(q := quotient!:(x, pi4));
                   r := difference!:(x, times!:(q, pi4)) >>;
          sign := conv!:i2bf 1;
          if m >= 8 then m := remainder(m, 8);
          if m >= 4 then << sign := minus!: sign; m := m - 4>>;
          if m = 0 then goto sn
           else if onep m then goto m1
           else if m = 2 then goto m2
           else goto m3;
      m1: r := cut!:mt(difference!:(pi4, r), k2);
          return times!:(sign, cos!:(r, k));
      m2: r := cut!:mt(r, k2);
          return times!:(sign, cos!:(r, k));
      m3: r := cut!:mt(difference!:(pi4, r), k2);
    sn: begin integer j, n, ncut;  scalar dcut, fctrial, ri, tm;
              ncut := k2 - min(0, order!: r + 1);
              dcut := make!:bf(10, - ncut);
              y := ri := tm := r;
              r := minus!: cut!:ep(times!:(r, r), - ncut);
              m := j := 1;
              while greaterp!:(abs!: tm, dcut) do
               << j := j + 2;
                  fctrial := conv!:i2bf(m := m * j * (j - 1));
                  ri := cut!:ep(times!:(ri, r), - ncut);
                  n := max(1, k2 - order!: fctrial + order!: ri);
                  tm := divide!:(ri, fctrial, n);
                  y := plus!:(y, tm);
                  if zerop remainder(j,20) then y := cut!:ep(y,-ncut)>>;
        end;
          return round!:mt(times!:(sign, y), k);
    end$


symbolic procedure cos!:(x, k);
% This function calculates cos(x), the value of
%      the cosine function at the point "x", with
%      the precision K, by summing terms of the
%      Taylor series for cos(z), 0 < z < PI/4.
% X is a BIG-FLOAT representation of any real "x",
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     not fixp k or k <= 0 then bflerrmsg 'cos!:
    else if bfzerop!: x then conv!:i2bf 1
    else if minusp!: x then cos!:(minus!: x, k)
    else begin integer k2, m;  scalar pi4, sign, q, r, y;
          k2 := k + 2;
          m := preci!: x;
%          pi4 := times!:(!:pi(k2 + m), conv!:s2bf "0.25"); %constant
          pi4 := times!:(!:pi(k2 + m), !:bf!-0!.25);    %JBM
          if lessp!:(x, pi4) then << m := 0; r := x >>
           else << m := conv!:bf2i(q := quotient!:(x, pi4));
                   r := difference!:(x, times!:(q, pi4)) >>;
          sign := conv!:i2bf 1;
          if m >= 8 then m := remainder(m, 8);
          if m >= 4 then << sign := minus!: sign; m := m - 4 >>;
          if m >= 2 then sign := minus!: sign;
          if m = 0 then goto cs
           else if m = 1 then goto m1
           else if m = 2 then goto m2
           else goto m3;
      m1: r := cut!:mt(difference!:(pi4, r), k2);
          return times!:(sign, sin!:(r, k));
      m2: r := cut!:mt(r, k2);
          return times!:(sign, sin!:(r, k));
      m3: r := cut!:mt(difference!:(pi4, r), k2);
    cs: begin integer j, n;  scalar dcut, fctrial, ri, tm;
              dcut := make!:bf(10, - k2);
              y := ri := tm := conv!:i2bf 1;
              r := minus!: cut!:ep(times!:(r, r), - k2);
              m := 1;
              j := 0;
              while greaterp!:(abs!: tm, dcut) do
               << j := j + 2;
                  fctrial := conv!:i2bf(m := m * j * (j - 1));
                  ri := cut!:ep(times!:(ri, r), - k2);
                  n := max(1, k2 - order!: fctrial + order!: ri);
                  tm := divide!:(ri, fctrial, n);
                  y := plus!:(y, tm);
                  if zerop remainder(j,20) then y := cut!:ep(y,-k2)>>;
        end;
          return round!:mt(times!:(sign, y), k);
    end$


symbolic procedure tan!:(x, k);
% This function calculates tan(x), the value of
%      the tangent function at the point "x",
%      with the precision K, by calculating
%         sin(x)  or  cos(x) = sin(PI/2-x).
% X is a BIG-FLOAT representation of any real "x",
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     not fixp k or k <= 0 then bflerrmsg 'tan!:
   else if bfzerop!: x then conv!:i2bf 0
   else if minusp!: x then minus!: tan!:(minus!: x, k)
   else begin integer k2, m;  scalar one, pi4, sign, q, r;
          k2 := k + 2;
          one := conv!:i2bf 1;
          m := preci!: x;
%          pi4 := times!:(!:pi(k2 + m), conv!:s2bf "0.25"); %constant
          pi4 := times!:(!:pi(k2 + m), !:bf!-0!.25);    %JBM
          if lessp!:(x, pi4) then << m := 0; r := x >>
           else << m := conv!:bf2i(q := quotient!:(x, pi4));
                   r := difference!:(x, times!:(q, pi4)) >>;
          if m >= 4 then m := remainder(m, 4);
          if m >= 2 then sign := minus!: one else sign := one;
          if m = 1 or m = 3 then r := difference!:(pi4, r);
          r := cut!:mt(r, k2);
          if m = 0 or m = 3 then goto m03 else goto m12;
     m03: r := sin!:(r, k2);
          q := difference!:(one, times!:(r, r));
          q := sqrt!:(cut!:mt(q, k2), k2);
          return times!:(sign, divide!:(r, q, k));
     m12: r := sin!:(r, k2);
          q := difference!:(one, times!:(r, r));
          q := sqrt!:(cut!:mt(q, k2), k2);
          return times!:(sign, divide!:(q, r, k));
    end$


symbolic procedure asin!:(x, k);
% This function calculates asin(x), the value of
%      the arcsine function at the point "x",
%      with the precision K, by calculating
%         atan(x/SQRT(1-x**2))  by ATAN!:.
%      The answer is in the range [-PI/2 , PI/2].
% X is a BIG-FLOAT representation of "x", IxI <= 1,
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     greaterp!:(abs!: x, conv!:i2bf 1) or
     not fixp k or k <= 0 then bflerrmsg 'asin!:
   else if minusp!: x then minus!: asin!:(minus!: x, k)
   else begin integer k2;  scalar one, y;
          k2 := k + 2;
          one := conv!:i2bf 1;
          if lessp!:(difference!:(one, x), make!:bf(10, - k2))
%          then return round!:mt(times!:(!:pi(k+1),conv!:s2bf "0.5"),k);
            then return round!:mt(times!:(!:pi add1 k,!:bf!-0!.5),k);
                 %JBM
          y := cut!:mt(difference!:(one, times!:(x, x)), k2);
          y := divide!:(x, sqrt!:(y, k2), k2);
          return atan!:(y, k);
    end$


symbolic procedure acos!:(x, k);
% This function calculates acos(x), the value of
%      the arccosine function at the point "x",
%      with the precision K, by calculating
%         atan(SQRT(1-x**2)/x)  if  x > 0  or
%         atan(SQRT(1-x**2)/x) + PI  if  x < 0.
%      The answer is in the range [0 , PI].
% X is a BIG-FLOAT representation of "x", IxI <= 1,
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     greaterp!:(abs!: x, conv!:i2bf 1) or
     not fixp k or k <= 0 then bflerrmsg 'acos!:
   else begin integer k2;  scalar y;
          k2 := k + 2;
          if lessp!:(abs!: x, make!:bf(50, - k2))
%          then return round!:mt(times!:(!:pi(k+1),conv!:s2bf "0.5"),k);
           then return round!:mt(times!:(!:pi add1 k,!:bf!-0!.5),k);
                %JBM
          y := difference!:(conv!:i2bf 1, times!:(x, x));
          y := cut!:mt(y, k2);
          y := divide!:(sqrt!:(y, k2), abs!: x, k2);
          return (if minusp!: x then
                   round!:mt(difference!:(!:pi(k + 1), atan!:(y, k)), k)
                  else atan!:(y, k) );
    end$


symbolic procedure atan!:(x, k);
% This function calculates atan(x), the value of the
%      arctangent function at the point "x", with
%      the precision K, by summing terms of the
%      Taylor series for atan(z)  if  0 < z < 0.42.
%      Otherwise the following identities are used:
%         atan(x) = PI/2 - atan(1/x)  if  1 < x  and
%         atan(x) = 2*atan(x/(1+SQRT(1+x**2)))
%            if  0.42 <= x <= 1.
%      The answer is in the range [-PI/2 , PI/2].
% X is a BIG-FLOAT representation of any real "x",
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     not fixp k or k <= 0 then bflerrmsg 'atan!:
   else if bfzerop!: x then conv!:i2bf 0
   else if minusp!: x then minus!: atan!:(minus!: x, k)
   else begin integer k2;  scalar one, pi4, y, z;
          k2 := k + 2;
          one := conv!:i2bf 1;
%          pi4 := times!:(!:pi k2, conv!:s2bf "0.25"); %constant
          pi4 := times!:(!:pi k2, !:bf!-0!.25);    %JBM
          if equal!:(x, one) then return round!:mt(pi4, k);
          if greaterp!:(x, one) then return
           round!:mt(difference!:(plus!:(pi4, pi4),
                                  atan!:(divide!:(one,x,k2),k + 1)),k);
%         if lessp!:(x, conv!:s2bf "0.42") then goto at; %constant
          if lessp!:(x, !:bf!-0!.42) then goto at;    %JBM
          y := plus!:(one, cut!:mt(times!:(x, x), k2));
          y := plus!:(one, sqrt!:(y, k2));
          y := atan!:(divide!:(x, y, k2), k + 1);
          return round!:mt(times!:(y, conv!:i2bf 2), k);
    at: begin integer m, n, ncut;  scalar dcut, tm, zi;
              ncut := k2 - min(0, order!: x + 1);
              y := tm := zi := x;
              z := minus!: cut!:ep(times!:(x, x), - ncut);
              dcut := make!:bf(10, - ncut);
              m := 1;
              while greaterp!:(abs!: tm, dcut) do
               << zi := cut!:ep(times!:(zi, z), - ncut);
                  n := max(1, k2 + order!: zi);
                  tm := divide!:(zi, conv!:i2bf(m := m + 2), n);
                  y := plus!:(y, tm);
                  if zerop remainder(m,20) then y := cut!:ep(y,-ncut)>>;
        end;
          return round!:mt(y, k)
    end$


symbolic procedure arcsin!:(x, k);
% This function calculates arcsin(x), the value of
%      the arcsine function at the point "x", with
%      the precision K, by solving
%         x = sin(y)  if  0 < x <= 0.72,  or
%         SQRT(1-x**2) = sin(y)  if  0.72 < x,
%      by Newton's iteration method.
%      The answer is in the range [-PI/2 , PI/2].
% X is a BIG-FLOAT representation of "x", IxI <= 1,
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     greaterp!:(abs!: x, conv!:i2bf 1) or
     not fixp k or k <= 0 then bflerrmsg 'arcsin!:
   else if bfzerop!: x then conv!:i2bf 0
   else if minusp!: x then minus!: arcsin!:(minus!: x, k)
   else begin integer k2;  scalar dcut, one, pi2, y;
          k2 := k + 2;
          dcut := make!:bf(10, - k2 + order!: x + 1);
          one := conv!:i2bf 1;
%         pi2 := times!:(!:pi(k2 + 2), conv!:s2bf "0.5"); %constant
          pi2 := times!:(!:pi(k2 + 2), !:bf!-0!.5);    %JBM
          if lessp!:(difference!:(one, x), dcut) then
             return round!:mt(pi2, k);
%         if greaterp!:(x, conv!:s2bf "0.72") then goto ac
          if greaterp!:(x, !:bf!-0!.72) then goto ac    %JBM
             else goto as;
      ac: y := cut!:mt(difference!:(one, times!:(x, x)), k2);
          y := arcsin!:(sqrt!:(y, k2), k);
          return round!:mt(difference!:(pi2, y), k);
    as: begin integer nfig,n;  scalar cx, dx, dy, x0;
              dy := one;
              y := x;
              nfig := 1;
              while nfig < k2 or greaterp!:(abs!: dy, dcut) do
               << if (nfig := 2 * nfig) > k2 then nfig := k2;
                  x0 := sin!:(y, nfig);
                  cx := difference!:(one, times!:(x0, x0));
                  cx := cut!:mt(cx, nfig);
                  cx := sqrt!:(cx, nfig);
                  dx := difference!:(x, x0);
                  n := max(1, nfig + order!: dx);
                  dy := divide!:(dx, cx, n);
                  y := plus!:(y, dy) >>;
        end;
          return round!:mt(y, k);
    end$


symbolic procedure arccos!:(x, k);
% This function calculates arccos(x), the value of
%      the arccosine function at the point "x", with
%      the precision K, by calculating
%         arcsin(SQRT(1-x**2))  if  x > 0.72  and
%         PI/2 - arcsin(x)  otherwise  by ARCSIN!:.
%      The answer is in the range [0 , PI].
% X is a BIG-FLOAT representation of "x", IxI <= 1,
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     greaterp!:(abs!: x, conv!:i2bf 1) or
     not fixp k or k <= 0 then bflerrmsg 'arccos!:
%  else if leq!:(x, conv!:s2bf "0.72") then
   else if leq!:(x, !:bf!-0!.72) then    %JBM
             round!:mt(difference!:
%              (times!:(!:pi(k + 1), conv!:s2bf "0.5"),
               (times!:(!:pi add1 k, !:bf!-0!.5),    %JBM
                arcsin!:(x, k) ), k)
          else arcsin!:(sqrt!:(cut!:mt
               (difference!:(conv!:i2bf 1, times!:(x, x)),
                 k + 2), k + 2), k)$


symbolic procedure arctan!:(x, k);
% This function calculates arctan(x), the value of
%      the arctangent function at the point "x",
%      with the precision K, by calculating
%         arcsin(x/SQRT(1+x**2))  by ARCSIN!:
%      The answer is in the range [-PI/2 , PI/2].
% X is a BIG-FLOAT representation of any real "x",
%      otherwise it is converted to a <BIG-FLOAT>.
% K is a positive integer.
  if not bfp!:(x := conv!:a2bf x) or
     not fixp k or k <= 0 then bflerrmsg 'arctan!:
   else if minusp!: x then minus!: arctan!:(minus!: x, k)
   else arcsin!:(divide!:(x, sqrt!:(cut!:mt
          (plus!:(conv!:i2bf 1, times!:(x, x)), k + 2), k + 2), k + 2),
                 k)$


%Miscellaneous constants (added by JBM).

!:bf!-pi := make!:bf(314159265358979323846, -20);

!:bf!-0 := make!:bf(0, 0);

!:bf!-1 := make!:bf(1, 0);

!:bf!-e := make!:bf(271828182845904523536, -20);

!:bf!-0!.5 := conv!:s2bf "0.5";

!:bf!-0!.25 := conv!:s2bf "0.25";

!:bf!-0!.1 := conv!:s2bf "0.1";

!:bf!-1!.72 := conv!:s2bf "1.72";

!:bf!-0!.42 := conv!:s2bf "0.42";

!:bf!-0!.72 := conv!:s2bf "0.72";


endmodule;


module gbf;   % Support for gaussian bigfloats.

% Author: Eberhard Schruefer.

global '(domainlist!*);

fluid '(!*big!_complex);

domainlist!* := union('(!:gbf!:),domainlist!*);

put('big!_complex,'tag,'!:gbf!:);
put('!:gbf!:,'dname,'big!_complex);
put('!:gbf!:,'i2d,'!*i2gbf);
put('!:gbf!:,'minusp,'gbfminusp!:);
put('!:gbf!:,'zerop,'gbfzerop!:);
put('!:gbf!:,'onep,'gbfonep!:);
put('!:gbf!:,'plus,'gbfplus!:);
put('!:gbf!:,'difference,'gbfdifference!:);
put('!:gbf!:,'times,'gbftimes!:);
put('!:gbf!:,'quotient,'gbfquotient!:);
put('!:gbf!:,'rationalizefn,'girationalize!:);
put('!:gbf!:,'prepfn,'gbfprep!:);
put('!:gbf!:,'prifn,'gbfprn!:);
put('!:bf!:,'!:gbf!:,'bf2gbf);
put('!:rn!:,'!:gbf!:,'rn2gbf);
put('!:ft!:,'!:gbf!:,'ft2gbf);
put('!:gbf!:,'!:bf!:,'gbf2bf);
put('!:gbf!:,'cmpxfn,'mkgbf);
put('!:gbf!:,'ivalue,'mkdgbf);
put('!:gbf!:,'realtype,'!:bf!:);
flag('(!:gbf!:),'field);

symbolic procedure mkdgbf u;
   ('!:gbf!: . (i2bf!: 0 . i2bf!: 1)) ./ 1;

smacro procedure mkgbf(rp,ip);
   '!:gbf!: . (rp . ip);

symbolic procedure bf2gbf u; mkgbf(u,i2bf!: 0);

symbolic procedure rn2gbf u; mkgbf(!*rn2bf u,i2bf!: 0);

symbolic procedure ft2gbf u; mkgbf(!*ft2bf u,i2bf!: 0);

symbolic procedure gbf2bf u;
   if bfzerop!: cddr u then cadr u
    else rederr
          "conversion to bigfloat requires zero imaginary part";

symbolic procedure !*i2gbf u;
   '!:gbf!: . (i2bf!: u . i2bf!: 0);

symbolic procedure gbfminusp!: u;
   %this makes not much sense;
   if bfzerop!: cddr u then minusp!: cadr u
    else minusp!: cddr u;

symbolic procedure gbfzerop!: u;
   bfzerop!:(cadr u) and bfzerop!:(cddr u);

symbolic procedure gbfonep!: u;
   bfonep!:(cadr u) and bfzerop!:(cddr u);

symbolic procedure gbfplus!:(u,v);
   mkgbf(bfplus!:(cadr u,cadr v),bfplus!:(cddr u,cddr v));

symbolic procedure gbfdifference!:(u,v);
   mkgbf(tdifference!:(cadr u,cadr v),
         tdifference!:(cddr u,cddr v));

symbolic procedure gbftimes!:(u,v);
   begin scalar r1,i1,r2,i2,rr,ii;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     rr := tdifference!:(ttimes!:(r1,r2),ttimes!:(i1,i2));
     ii := bfplus!:(ttimes!:(r1,i2),ttimes!:(r2,i1));
     return mkgbf(rr,ii)
   end;

symbolic procedure gbfquotient!:(u,v);
   begin scalar r1,i1,r2,i2,rr,ii,d;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     d := bfplus!:(ttimes!:(r2,r2),ttimes!:(i2,i2));
     rr := bfplus!:(ttimes!:(r1,r2),ttimes!:(i1,i2));
     ii := tdifference!:(ttimes!:(i1,r2),ttimes!:(i2,r1));
     return mkgbf(bfquotient!:(rr,d),bfquotient!:(ii,d))
   end;

symbolic procedure gbfprep!: u; gbfprep1 cdr u;

%symbolic procedure simpgbf u;
   %('!:gbf!: . u) ./ 1;

%put('!:gbf!:,'simpfn,'simpgbf);

symbolic procedure gbfprep1 u;
   if bfzerop!: cdr u then if bfonep!: car u then 1
                            else car u
    else if bfzerop!: car u then if bfonep!: cdr u then 'i
                                  else list('times,cdr u,'i)
    else list('plus,car u,if bfonep!: cdr u then 'i
                           else list('times,cdr u,'i));

symbolic procedure gbfprn!: u;
   (lambda v; if atom v or car v eq 'times
                  or car v memq domainlist!* then maprin v
               else <<prin2!* "("; maprin v; prin2!* ")">>) gbfprep1 u;


%*** elementary functions;

% All functions below return the principal value. Be aware of certain
% pecularities in this respect. E.g. if you raise a complex quantity
% to a complex power and then raise the result to the reciprocal power
% you will not in general obtain the base, since (u**v)**(1/v) is
% different from u in general.

deflist('((e gbfe!*) (pi gbfpi!*)),'!:gbf!:);

symbolic procedure gbfe!*; bf2gbf e!*();

symbolic procedure gbfpi!*; bf2gbf pi!*();

deflist('((expt gbfexpt) (sin gbfsin) (cos gbfcos) (tan gbftan)
          (asin gbfasin) (acos gbfacos) (atan gbfatan)
          (log gbflog)),'!:gbf!:);

symbolic procedure gbfexpt(u,v);
   begin scalar norm,ang,angr;
     norm := sqrt!*(bfplus!:(ttimes!:(cadr u,cadr u),
                             ttimes!:(cddr u,cddr u)));
     ang := bfarg!: u;
     angr := bfplus!:(ttimes!:(cddr v,log!* norm),
                      ttimes!:(cadr v,ang));
     norm := ttimes!:(texpt!:any(norm,cadr v),
                 exp!* ttimes!:('!:bf!: . (-cadddr v) . cddddr v,ang));
     return mkgbf(ttimes!:(norm,cos!* angr),
                  ttimes!:(norm,sin!* angr))
   end;

symbolic procedure bfarg!: u;
   % Returns bfarg u in the range (-pi,+pi), as a bigfloat.
   (lambda x,y;
      if bfzerop!: y then if minusp!: x then pi!*()
                           else i2bf!: 0
       else if bfzerop!: x then if minusp!: y then
                                    ttimes!:(pi!*(),conv!:a2bf(-0.5))
                                 else ttimes!:(pi!*(),conv!:a2bf 0.5)
       else if minusp!: x and minusp!: y then
               tdifference!:(atan!*(bfquotient!:(y,x)),pi!*())
       else if minusp!: x and not minusp!: y then
               bfplus!:(atan!*(bfquotient!:(y,x)),pi!*())
       else atan!*(bfquotient!:(y,x))) (cadr u,cddr u);

%put('bfarg,'polyfn,'bfarg!:); %make it available to algebraic mode;

symbolic procedure gbfsin u;
   mkgbf(ttimes!:(sin!* cadr u,cosh!* cddr u),
         ttimes!:(cos!* cadr u,sinh!* cddr u));

symbolic procedure gbfcos u;
   mkgbf(ttimes!:(cos!* cadr u,cosh!* cddr u),
        !:minus ttimes!:(sin!* cadr u,sinh!* cddr u));

symbolic procedure gbftan u;
   begin scalar v;
     v := bfplus!:(cos!* ttimes!:(conv!:a2bf 2.0,cadr u),
                   cosh!* ttimes!:(conv!:a2bf 2.0,cddr u));
     return
        mkgbf(bfquotient!:(sin!* ttimes!:(conv!:a2bf 2.0,cadr u),v),
              bfquotient!:(sinh!* ttimes!:(conv!:a2bf 2.0,cddr u),v))
   end;

symbolic procedure gbfasin u;
   begin scalar a,b,c;
     a := ttimes!:(conv!:a2bf 0.5,
       sqrt!*(bfplus!:(texpt!:any(bfplus!:(cadr u,i2bf!: 1),i2bf!: 2),
                       ttimes!:(cddr u,cddr u))));
     b := ttimes!:(conv!:a2bf 0.5,
       sqrt!*(bfplus!:(texpt!:any(bfplus!:(cadr u,i2bf!:(-1)),i2bf!: 2),
                       ttimes!:(cddr u,cddr u))));
     c := bfplus!:(a,b);
     b := tdifference!:(a,b);
     a := c;
     c := bfplus!:(a,sqrt!*(tdifference!:(ttimes!:(a,a),i2bf!: 1)));
     return mkgbf(asin!* b,log!* c)
   end;

symbolic procedure gbfacos u;
   begin scalar a,b,c;
     a := ttimes!:(conv!:a2bf 0.5,
       sqrt!*(bfplus!:(texpt!:any(bfplus!:(cadr u,i2bf!: 1),i2bf!: 2),
                       ttimes!:(cddr u,cddr u))));
     b := ttimes!:(conv!:a2bf 0.5,
       sqrt!*(bfplus!:(texpt!:any(bfplus!:(cadr u,i2bf!:(-1)),i2bf!: 2),
                       ttimes!:(cddr u,cddr u))));
     c := bfplus!:(a,b);
     b := tdifference!:(a,b);
     a := c;
     c := bfplus!:(a,sqrt!*(tdifference!:(ttimes!:(a,a),i2bf!: 1)));
     return mkgbf(acos!* b,ttimes!:(log!* c,i2bf!:(-1)))
   end;

symbolic procedure gbfatan u;
   gbftimes!:(gbflog(gbfquotient!:(
                        gbfplus!:(!*i2gbf 1,gbftimes!:(mkgbf(0,-1),u)),
                        gbfplus!:(!*i2gbf 1,gbftimes!:(mkgbf(0,1),u)))),
              mkgbf(0,conv!:a2bf 0.5));

symbolic procedure gbflog u;
   %Returns the principal value of log u;
   if realp u then mkgbf(log!* u,i2bf!: 0)
    else begin scalar norm;
           norm := sqrt!* bfplus!:(ttimes!:(cadr u,cadr u),
                                   ttimes!:(cddr u,cddr u));
           return mkgbf(log!* norm,bfarg!: u)
         end;

initdmode 'big!_complex;

endmodule;


end;

Added r33/boot.sl version [4fc226a118].









































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
% Standard LISP equivalent of BOOT.RED.

(fluid '(!*blockp !*mode))

(global '(oldchan!*))

(global '(crchar!* cursym!* fname!* nxtsym!* ttype!* !$eol!$))

(put '!; 'switch!* '(nil !*semicol!*))

(put '!( 'switch!* '(nil !*lpar!*))

(put '!) 'switch!* '(nil !*rpar!*))

(put '!, 'switch!* '(nil !*comma!*))

(put '!. 'switch!* '(nil cons))

(put '!: 'switch!* '(((!= nil setq)) !*colon!*))

(put '!*comma!* 'infix 1)

(put 'setq 'infix 2)

(put 'cons 'infix 3)

(flag '(!*comma!*) 'nary)

(flag '(!*colon!* !*semicol!* end then else) 'delim)

(put 'begin 'stat 'blockstat)

(put 'if 'stat 'ifstat)

(put 'symbolic 'stat 'procstat)

(de begin2 nil
   (prog nil
      (setq cursym!* '!*semicol!*)
a     (cond
         ((eq cursym!* 'end) (progn (rds oldchan!*) (return nil)))
         (t (prin2 (errorset '(eval (form (xread nil))) t t)) ))
      (go a)))

(de form (u) u)

(de xread (u) (progn (scan) (xread1 u)))

(de xread1 (u)
   (prog (v w x y z z2)
a     (setq z cursym!*)
a1    (cond
         ((or (null (atom z)) (numberp z)) (setq y nil))
         ((flagp z 'delim) (go end1))
         ((eq z '!*lpar!*) (go lparen))
         ((eq z '!*rpar!*) (go end1))
         ((setq y (get z 'infix)) (go infx))
         ((setq y (get z 'stat)) (go stat)))
a3    (setq w (cons z w))
next  (setq z (scan))
      (go a1)
lparen(setq y nil)
      (cond
         ((eq (scan) '!*rpar!*)
            (and w (setq w (cons (list (car w)) (cdr w)))) )
         ((eqcar (setq z (xread1 'paren)) '!*comma!*)
            (setq w (cons (cons (car w) (cdr z)) (cdr w))))
         (t (go a3)))
      (go next)
infx  (setq z2 (mkvar (car w) z))
un1   (setq w (cdr w))
      (cond
         ((null w) (go un2))
         (t (setq z2 (cons (car w) (list z2)))) )
      (go un1)
un2   (setq v (cons z2 v))
preced(cond ((null x) (go pr4)) ((lessp y (car (car x))) (go pr2)))
pr1   (setq x (cons (cons y z) x))
      (go next)
pr2   (setq v
         (cons
            (cond
               ((and (eqcar (car v) (cdar x)) (flagp (cdar x) 'nary))
                  (cons (cdar x) (cons (cadr v) (cdar v))))
               (t (cons (cdar x) (list (cadr v) (car v)))) )
            (cdr (cdr v))))
      (setq x (cdr x))
      (go preced)
stat  (setq w (cons (eval (list y)) w))
      (setq y nil)
      (go a)
end1  (cond
         ((and (and (null v) (null w)) (null x)) (return nil))
         (t (setq y 0)))
      (go infx)
pr4   (cond ((null (equal y 0)) (go pr1)) (t (return (car v)))) ))

(de eqcar (u v) (and (null (atom u)) (eq (car u) v)))

(de mksetq (u v) (list 'setq u v))

(de mkvar (u v) u)

(de rread nil
   (prog (x)
      (setq x (token))
      (return
         (cond
            ((and (equal ttype!* 3) (eq x '!()) (rrdls))
            (t x)))) )

(de rrdls nil
   (prog (x)
      (setq x (rread))
      (cond
         ((null (equal ttype!* 3)) (go a))
         ((eq x '!)) (return nil))
         ((null (eq x '!.)) (go a)))
      (setq x (rread))
      (token)
      (return x)
a     (return (cons x (rrdls)))) )

(de token nil
   (prog (x y)
      (setq x crchar!*)
a     (cond
         ((seprp x) (go sepr))
         ((digit x) (go number))
         ((liter x) (go letter))
         ((eq x '!%) (go coment))
         ((eq x '!!) (go escape))
         ((eq x '!') (go quote))
         ((eq x '!") (go string)))
      (setq ttype!* 3)
      (cond ((delcp x) (go d)))
      (setq nxtsym!* x)
a1    (setq crchar!* (readch))
      (go c)
escape(setq y (cons x y))
      (setq x (readch))
letter(setq ttype!* 0)
let1  (setq y (cons x y))
      (cond
         ((or (digit (setq x (readch))) (liter x)) (go let1))
         ((eq x '!!) (go escape)))
      (setq nxtsym!* (intern (compress (reverse y))))
b     (setq crchar!* x)
c     (return nxtsym!*)
number(setq ttype!* 2)
num1  (setq y (cons x y))
      (cond ((digit (setq x (readch))) (go num1)))
      (setq nxtsym!* (compress (reverse y)))
      (go b)
quote (setq crchar!* (readch))
      (setq nxtsym!* (list 'quote (rread)))
      (setq ttype!* 4)
      (go c)
string(prog (raise)
         (setq raise !*raise)
         (setq !*raise nil)
   strinx(setq y (cons x y))
         (cond ((null (eq (setq x (readch)) '!")) (go strinx)))
         (setq y (cons x y))
         (setq nxtsym!* (mkstrng (compress (reverse y))))
         (setq !*raise raise))
      (setq ttype!* 1)
      (go a1)
coment(cond ((null (eq (readch) !$eol!$)) (go coment)))
sepr  (setq x (readch))
      (go a)
d     (setq nxtsym!* x)
      (setq crchar!* '! )
      (go c)))

(setq crchar!* '! )

(de delcp (u) (or (eq u '!;) (eq u '!$)))

(de mkstrng (u) u)

(de seprp (u) (or (eq u '! ) (eq u !$eol!$)))

(de scan nil
   (prog (x y)
      (cond ((null (eq cursym!* '!*semicol!*)) (go b)))
a     (setq nxtsym!* (token))
b     (cond
         ((or (null (atom nxtsym!*)) (numberp nxtsym!*)) (go l))
         ((and (setq x (get nxtsym!* 'newnam)) (setq nxtsym!* x))
            (go b))
         ((eq nxtsym!* 'comment) (go comm))
         ((and
             (eq nxtsym!* '!')
             (setq cursym!* (list 'quote (rread))))
            (go l1))
         ((null (setq x (get nxtsym!* 'switch!*))) (go l))
         ((eq (cadr x) '!*semicol!*)
            (return (setq cursym!* (cadr x)))) )
sw1   (setq nxtsym!* (token))
      (cond
         ((or
             (null (car x))
             (null (setq y (assoc nxtsym!* (car x)))) )
            (return (setq cursym!* (cadr x)))) )
      (setq x (cdr y))
      (go sw1)
comm  (cond ((eq (readch) '!;) (setq crchar!* '! )) (t (go comm)))
      (go a)
l     (setq cursym!*
         (cond
            ((null (eqcar nxtsym!* 'string)) nxtsym!*)
            (t (cons 'quote (cdr nxtsym!*)))) )
l1    (setq nxtsym!* (token))
      (return cursym!*)))

(de ifstat nil
   (prog (condx condit)
a     (setq condx (xread t))
      (setq condit (nconc condit (list (list condx (xread t)))) )
      (cond
         ((null (eq cursym!* 'else)) (go b))
         ((eq (scan) 'if) (go a))
         (t (setq condit
               (nconc condit (list (list t (xread1 t)))) )))
b     (return (cons 'cond condit))))

(de procstat nil
   (prog (x y)
      (cond ((eq cursym!* 'symbolic) (scan)))
      (cond
         ((eq cursym!* '!*semicol!*)
            (return (null (setq !*mode 'symbolic)))) )
      (setq fname!* (scan))
      (cond ((atom (setq x (xread1 nil))) (setq x (list x))))
      (setq y (xread nil))
      (cond ((flagp (car x) 'lose) (return nil)))
      (putd (car x) 'expr (list 'lambda (cdr x) y))
      (setq fname!* nil)
      (return (list 'quote (car x)))) )

(de blockstat nil
   (prog (x hold varlis !*blockp)
a0    (setq !*blockp t)
      (scan)
      (cond
         ((null (or (eq cursym!* 'integer) (eq cursym!* 'scalar)))
            (go a)))
      (setq x (xread nil))
      (setq varlis
         (nconc
            (cond ((eqcar x '!*comma!*) (cdr x)) (t (list x)))
            varlis))
      (go a0)
a     (setq hold (nconc hold (list (xread1 nil))))
      (setq x cursym!*)
      (scan)
      (cond ((not (eq x 'end)) (go a)))
      (return (mkprog varlis hold))))

(de mkprog (u v) (cons 'prog (cons u v)))

(de gostat nil 
   (prog (x) (scan) (setq x (scan)) (scan) (return (list 'go x))))

(put 'go 'stat 'gostat)

(de rlis nil
   (prog (x)
      (setq x cursym!*)
      (return (cond ((not (flagp (scan) 'delim))
                     (list x (list 'quote (list (xread1 t)))))
                    (t (list x))))))

(rds oldchan!*)

Added r33/build.sl version [17143cf8a4].





















































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
% PSL dependent file for complete rebuild of REDUCE fasl file set

% Author: Anthony C. Hearn.

(setq modules!* '(prolog rlisp rend arith mathlib alg1 alg2 entry matr
		  hephys util int solve ezgcd factor rcref rsltnt
		  algint anum gentran groebner spde mkfasl bfloat
		  excalc))
		% Note that excalc changes the meaning of various infix
		% operators, and so must be defined last.

% The following assignments are PSL dependent.

(setq *fastcar t)

(setq *usermode nil)

(setq *verboseload t)

(load compiler)

% The following is PSL dependent.

(setq !*int nil)           % prevents input buffer being saved

(setq !*msg nil)

(setq oldchan!* in!*)

%%%(setq !*comp t)    % It's faster if we compile the boot file.

(flag '(eqcar) 'lose)   % PSL dependent.

(setq *syslisp t)       % This makes a small difference to rlisp and rend.

(dskin "symget.dat")    % For fast plist access.

(dskin "boot.sl")

% Note that the call of "rds" at the end of the boot file seems to be
% needed to make the system continue reading this input file after later
% exits from calls of rds.

%%(setq !*comp t)

(setq *argnochk t)

(begin2)
rds open("prolog.red",'input);
(begin2)
rds open("rlisp.red",'input);
(begin2)
infile "rend.red"$
infile "mkfasl.red"$
end;
(initreduce)
(begin2)
on gc,msg;
ipl!* := list("util/build.sl" .  oldchan!*);   %to fool IN

!*quotenewnam := nil;   % We need to compile prolog with this off.

for each x in modules!* do 
       <<if x eq 'bfloat then load nbig
	  else if x eq 'alg2
           then eval list('load,bldmsg("%w%w",rfasl!*,"alg1"))
	  else if x eq 'solve
           then eval list('load,bldmsg("%w%w",rfasl!*,"alg2"));
     terpri(); terpri();
     semic!* := '!$;   % to fool IN
     mkfasl x;
     !*quotenewnam := t>>$

bye;

Added r33/compat.sl version [e8df961d83].











































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
% Compat.sl.  Useful definitions for Cray and Sun 4 PSL versions.

% Author: Winfried Neun.

(remflag '(digit) 'lose)

(ds digit (u) ((lambda (x) (eq 1 (wshift
                      (wand (wdifference 8#057 (inf x))
                            (wdifference (inf x) 8#072))
                                 -31))) u))

(flag '(digit) 'lose)

(ds orderp (u v) (not (wgreaterp (inf u) (inf v))))

(flag '(orderp) 'lose)

(ds flagp** (u v)
          (flagp u v))

(flag '(flagp**) 'lose)

(dm terminalp (u)
    '(and *int (null ifl*)))

(flag '(terminalp) 'lose)

(ds liter (u)
  ((lambda (&u& &infu&)
    (setq &infu& (inf &u&))
     (eq 0 (wor (wxor (tag &u&) id-tag)
               (wshift
                  (wand (wor (wdifference &infu& 8#141) % a
                             (wdifference 8#172 &infu&)) % z
                        (wor (wdifference &infu& 8#101) % A
                             (wdifference 8#132 &infu&)) % Z
                   ) -31)))) u 0))

Added r33/dbuild.sl version [4faa8ced56].

























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
% Build a PSL REDUCE "in core" without the use of fasl files.

(setq modules!* '(prolog rlisp rend arith alg1 rend alg2 % entry
		  matr hephys)) % util int solve ezgcd factor rcref
		  % rsltnt bfloat))

% The following three assignments are PSL dependent.

(setq *fastcar t)

(setq *usermode nil)

(setq *verboseload t)

(load compiler)

(setq !*int nil)           % prevents input buffer being saved

(setq !*msg nil)

(setq oldchan!* in!*)

(setq !*comp nil)

(flag '(eqcar) 'lose)

(dskin "symget.dat")    % For fast plist access.

(dskin "boot.sl")

% Note that the call of "rds" at the end of the boot file seems to be
% needed to make the system continue reading this input file after later
% exits from calls of rds.

(setq !*comp t)

(setq *argnochk t)

(begin2)
rds open("prolog.red",'input);
(begin2)
rds open("rlisp.red",'input);
(begin2)
rds open("rend.red",'input);
(begin2)
put('!~imports,'stat,'rlis);
for each x in cdddr modules!* do
    infile concat(string!-downcase x,".red");
end;

(load nbig)

(load init!-file)

(setq !*comp nil)

(setq !*verboseload nil)

(initreduce)

Added r33/dosrend.red version [d043457fdf].









































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
module rend; % 386 MS-DOS PSL REDUCE "back-end".

% Authors: Martin L. Griss, Anthony C. Hearn and Winfried Neun.

% Except where noted, this works with both PSL 3.2 and PSL 3.4.

fluid '(!*break
        !*eolinstringok
        !*gc
        !*int
        !*mode
        !*usermode
        currentreadmacroindicator!*
        currentscantable!*
%       current!-modulus
        errout!*
        lispscantable!*
        promptstring!*
        rlispscantable!*);

global '(!$eol!$
         !$cr!$
         !*echo
         !*extraecho
         !*loadversion
         !*raise
         !*rlisp2
         crchar!*
         date!*
         esc!*
         e!-value!*
	 ft!-tolerance!*
         ifl!*
         ipl!*
	 largest!-small!-modulus
         ofl!*
         pi!-value!*
         spare!*
         statcounter
         systemname!*);

setq(!$cr!$,int2id 13);

switch break,gc,usermode,verboseload;

!*fastcar := t;   % Since REDUCE doesn't use car and cdr on atoms.

% One inessential reference to REVERSIP in this module (left unchanged).

% This file defines the system dependent code necessary to run REDUCE
% under PSL.

Comment The following functions, which are referenced in the basic
REDUCE source (RLISP, ALG1, ALG2, MATR and PHYS) should be defined to
complete the definition of REDUCE:

        BYE
        DELCP
        ERROR1
        FILETYPE
        MKFIL
        ORDERP
        QUIT
        SEPRP
        SETPCHAR.

Prototypical descriptions of these functions are as follows;

remprop('bye,'stat);

symbolic procedure bye;
   %Returns control to the computer's operating system command level.
   %The current REDUCE job cannot be restarted;
   <<close!-output!-files(); exitlisp()>>;

deflist('((bye endstat)),'stat);

symbolic procedure delcp u;
   %Returns true if U is a semicolon, dollar sign, or other delimiter.
   %This definition replaces one in the BOOT file;
   u eq '!; or u eq '!$;

symbolic procedure seprp u;
   %returns true if U is a blank or other separator (eg, tab or ff).
   %This definition replaces one in the BOOT file;
   u eq '!  or u eq '!	 or u eq !$eol!$  or u eq !$cr!$;

symbolic procedure error1;
   %This is the simplest error return, without a message printed. It can
   %be defined as ERROR(99,NIL) if necessary;
   throw('!$error!$,99);

symbolic procedure filetype u;
   %determines if string U has a specific file type.
   begin scalar v,w;
      v := cdr explode u;
      while v and not(car v eq '!.) do
        <<if car v eq '!< then while not(car v eq '!>) do v := cdr v;
          v := cdr v>>;
      if null v then return nil;
      v := cdr v;
      while v and not(car v eq '!") do <<w := car v . w; v := cdr v>>;
      return intern compress reversip w
   end;

symbolic procedure mkfil u;
   %converts file descriptor U into valid system filename;
   if stringp u then u
    else if not idp u then typerr(u,"file name")
    else string!-downcase id2string u;

% The following is a pretty crude definition, but since it isn't used
% very much, its performance doesn't really matter.

symbolic procedure string!-downcase u;
   begin scalar z;
      if not stringp u then u := id2string u;
      for each x in explode u do
	 if x memq
	      '(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)
		  then z := cdr atsoc(x,
		      '((A . !a) (B . !b) (C . !c) (D . !d) (E . !e)
		       (F . !f) (G . !g) (H . !h) (I . !i) (J . !j)
		       (K . !k) (L . !l) (M . !m) (N . !n) (O . !o)
		       (P . !p) (Q . !q) (R . !r) (S . !s) (T . !t)
		       (U . !u) (V . !v) (W . !w) (X . !x) (Y . !y)
		       (Z . !z))) . z
	  else z := x . z;
      return compress reverse z
   end;


symbolic procedure orderp8(u,v);
   % Returns true if U has same or higher order than id V by some
   % consistent convention (eg unique position in memory).
   wleq(inf u,inf v);       % PSL 3.4 form.
%  id2int u <= id2int v;    % PSL 3.2 form.

loadtime copyd('orderp,'orderp8);

procedure setpchar c;
   % Set prompt, return old one.
   begin scalar oldprompt;
    oldprompt := promptstring!*;
    promptstring!* := if stringp c then c
                      else if idp c then copystring id2string c
                      else bldmsg("%W", c);
    return oldprompt
   end;


Comment The following functions are only referenced if various flags are
set, or the functions are actually defined. They are defined in another
module, which is not needed to build the basic system. The name of the
flag follows the function name, enclosed in parentheses:

        BFQUOTIENT!: (BIGFLOAT)
        CEDIT (?)
        COMPD (COMP)
        EDIT1   This function provides a link to an editor. However, a
                definition is not necessary, since REDUCE checks to see
                if it has a function value.
        EMBFN (?)
        EZGCDF (EZGCD)
        FACTORF (FACTOR)
        LOAD!-MODULE (defined in prolog)
        PRETTYPRINT (DEFN --- also called by DFPRINT)
                This function is used in particular for output of RLISP
                expressions in LISP syntax. If that feature is needed,
                and the prettyprint module is not available, then it
                should be defined as PRINT
        RPRINT (PRET)
        TEXPT!: (BIGFLOAT)
        TEXPT!:ANY (BIGFLOAT)
        TIME (TIME) returns elapsed time from some arbitrary initial
                    point in milliseconds;


Comment The FACTOR module also requires a definition for GCTIME. Since
this is currently undefined in PSL, we provide the following definition;

symbolic procedure gctime; gctime!*;


Comment The following operator is used to save a REDUCE session as a
file for later use;

symbolic procedure savesession u;
   savesystem("Saved session",u,nil);

flag('(savesession),'opfn);

flag('(savesession),'noval);


Comment make "cd" and "system" available as operators;

flag('(cd system),'opfn);

flag('(cd system),'noval);


Comment The current REDUCE model allows for the availability of fast
arithmetical operations on small integers (called "inums").  All modern
LISPs provide such support.  However, the program will still run without
these constructs.  The relevant functions that should be defined for
this purpose are as follows;

remflag('(iplus itimes),'lose);

remprop('iplus,'infix);   % to allow for redefinition.

remprop('itimes,'infix);

symbolic macro procedure iplus u; expand(cdr u,'iplus2);

symbolic macro procedure itimes u; expand(cdr u,'itimes2);

flag('(iplus itimes iplus2 itimes2 iadd1 isub1 iminus iminusp
       idifference iquotient iremainder ilessp igreaterp), 'lose);

Comment There are also a number of system constants required for each
implementation. In systems that don't support inums, the equivalent
single precision integers should be used;

% E!-VALUE and PI!-VALUE are values for these constants that fit in
% the single precision floating point range of the machine.
% FT!-TOLERANCE is the tolerance of floating point calculations.
% LARGEST!-SMALL!-MODULUS is the largest power of two that can
% fit in the fast arithmetic (inum) range of the implementation.
% These four are constant for the life of the system and could be
% compiled in-line if the compiler permits it.

e!-value!* := 2.718282;

pi!-value!* := 3.141593;

ft!-tolerance!* := 0.000001;

largest!-small!-modulus := 2**23;

% If the (small) modular arithmetic is always limited to LARGEST-SMALL-
% MODULUS, it all fits in the inum range of the machine, with the
% exception of modular-times, that needs to use generic arithmetic for
% the multiplication.  However, on some machines (e.g., the VAX), it is
% possible to 'borrow' the extra precision needed, so that the following
% definition works.  This will not work of course for non-inums.

% remflag('(modular!-times),'lose);

% smacro procedure modular!-times(u,v);
%    iremainder(itimes2(u,v),current!-modulus);

% flag('(modular!-times),'lose);


% The following two definitions are commented out as they lead to
% unchecked vector ranges;

% symbolic smacro procedure getv(a,b); igetv(a,b);

% symbolic smacro procedure putv(a,b,c); iputv(a,b,c);

flag('(intersection),'lose);


Comment PSL Specific patches;

Comment We need to define a function BEGIN, which acts as the top-level
call to REDUCE, and sets the appropriate variables;

% global '(startuproutine!* toploopread!* toploopeval!* toploopprint!*
%          toploopname!*);

remflag('(begin),'go);

symbolic procedure begin;
   begin
        !*echo := not !*int;
        !*extraecho := t;
        ifl!* := ipl!* := ofl!* := nil;
        if null date!* then go to a;
        if !*loadversion then errorset('(load entry),nil,nil);
        !*gc := nil;
        !*usermode := nil;
        linelength if !*int then 80 else 115;
        prin2 "REDUCE 3.3, ";
        prin2 date!*;
        prin2t " ...";
        !*mode := if getd 'addsq then 'algebraic else 'symbolic;
        if !*mode eq 'algebraic then !*break := nil;
           %since most REDUCE users won't use LISP
        date!* := nil;
a:      crchar!* := '! ;
        if errorp errorset('(begin1),nil,nil) then go to a;
           %until PSL fixed
        prin2t "Entering LISP ... "
 end;

flag('(begin),'go);


Comment Initial setups for REDUCE;

spare!* := 11;   % We need this for bootstrapping.

symbolic procedure initreduce;
  % Initial declarations for REDUCE
  <<statcounter := 0;
    spare!* := 11;
    !*int := t;
    !*eolinstringok := t;  % we don't want the "string continued" msg.
    remd 'main;
    copyd('main,'rlispmain);
    date!* := date()>>;

symbolic procedure rlispmain;
  begin scalar l;
    rlispscantable!* := mkvect 128;
    l := '(17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11
           11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11
           11 11 13 11 11 11 20 11 00 01 02 03 04 05 06 07 08 09 13 11
           13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
           10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10
           10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
           10 10 10 11 11 11 11 11 rlispdipthong);
    for i:=0:128 do <<putv(rlispscantable!*,i,car l); l := cdr l>>;
    currentreadmacroindicator!* := 'rlispreadmacro;
    currentscantable!* := rlispscantable!*;
    errout!* := 1;  % Errors to standard output, not special stream;
    eval '(begin);
    currentscantable!* := lispscantable!*; % But Slisp should use same
                                           % syntax as RLISP?
    standardlisp()
  end;

flag('(dskin savesystem reclaim),'opfn);

flag('(dskin savesystem),'noval);

flag('(load),'noform);

deflist('((load rlis)),'stat);

flag('(tr trst untr untrst),'noform);

deflist('((tr rlis) (trst rlis) (untr rlis) (untrst rlis)),'stat);

% The following is PSL 3.4 specific.

switch fulltrace;   % Prevents node renaming in trace output.

!*fulltrace := t;   % Since we usually want it this way.

Comment The global variable ESC* is used by the interactive string
editor (defined in CEDIT) as a terminator for input strings.  In PSL
we use the escape character;

esc!* := '!;


Comment The following declarations are needed to build various modules;

flag('(nth pnth spaces subla),'lose);   % used in ALG1

flag('(explode2 explode21),'lose);      % used in RPRINT

flag('(flag1 remflag1),'lose);          % used in RCREF


Comment The following are only needed for PSL 3.2;

% symbolic fexpr procedure definebop u; u;

% symbolic fexpr procedure definerop u; u;


Comment Specific Optimizations for Cray and Sun 4 version;

remflag('(quotdd),'lose);

symbolic procedure quotdd(u,v);
   % U and V are domain elements.  Value is U/V if division is exact,
   % NIL otherwise.
   if atom u then if atom v
          %%%        then if remainder(u,v)=0 then u/v else nil
                     then (if cdr div = 0 then car div else NIL)
                                   where div = divide (u,v)
                    else quotdd(apply1(get(car v,'i2d),u),v)
   else if atom v then quotdd(u,apply1(get(car u,'i2d),v))
        else dcombine(u,v,'quotient);

flag('(quotdd),'lose);

remflag('(mchk),'lose);

symbolic procedure mchk(u,v);
   IF u eq v then cons(nil,nil)
    else mchk!-aux (u,v);

symbolic procedure mchk!-aux(U,V);
   if not idp u and not idp v and u=v then cons(nil,nil)
    else if atom v
	 then if v memq frlis!* then list list (v . u) else nil
    else if atom u      %special check for negative number match;
     then if numberp u and u<0 then mchk!-aux(list('minus,-u),v)
	 else nil
    else if car u eq car v then mcharg(cdr u,cdr v,car u)
    else nil;

flag('(mchk),'lose);

remflag('(update!-pline),'lose);

symbolic procedure update!-pline(x,y,pline);
   for each j in pline collect
       ((iplus2(caaar j,x) . iplus2(cdaar j,x))
                                 . iplus2(cdar j ,y)) . cdr j;

flag('(update!-pline),'lose);

remflag('(peq ordpp noncomp),'lose);

symbolic smacro procedure peq(u,v);
   %tests for equality of powers U and V;
  (( eq(cdu1,cdu2) and
     if eq(cu1,cu2) then t
        else if atom cu1 or atom cu2 then NIL
                else equal(cu1,cu2)
   ) where cu1 = car u1,cu2 = car u2,cdu1 = cdr u1,cdu2 = cdr u2
  ) where u1 = u,u2 = v;

symbolic smacro procedure ordpp(uu,vv);
   % This used to check (incorrectly) for NCMP!*;
 ((if caru eq carv then igreaterp(cdru,cdrv) else ordop(caru,carv)
  ) where caru = car u, carv = car v, cdru = cdr u, cdrv = cdr v
 )where u=uu,v=vv;

symbolic smacro procedure noncomp uu;
  ( pairp u and ((idp caru and flagp(caru,'noncom)
                )where caru = car u)) where u = uu;

flag('(peq ordpp noncomp),'lose);


Comment Now set the system name;

systemname!* := 'sparc;

endmodule;

end;

Added r33/entry.red version [aeee3f82a5].









































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
module entry;   % Table of entry points of self-loading modules.

% Author: Anthony C. Hearn.

% Using a modified version of the defautoload function of Eric Benson
% and Martin L. Griss.

global '(!*msg modules!* systemname!* system!*);

symbolic procedure safe!-putd(name,type,body);
   % So that stubs will not clobber REAL entries preloaded.
   if getd name
     then !*msg
        and printf("%n*** Autoload stub for %p not defined%n",name)
    else putd(name,type,body);

symbolic macro procedure defautoload u;
% (defautoload name), (defautoload name loadname),
% (defautoload name loadname fntype), or
% (defautoload name loadname fntype numargs)
% Default is 1 Arg EXPR in module of same name;
  begin scalar name,numargs,loadname,fntype,x;
    u := cdr u;
    name := car u;
    u := cdr u;
    if u then <<loadname := car u; u :=cdr u>> else loadname := name;
    if eqcar(name, 'quote) then name := cadr name;
    if atom loadname
      then if (x := get(loadname,'loadnames)) then loadname := x
            else loadname := list loadname
     else if car loadname eq 'quote then loadname := cadr loadname;
    if u then <<fntype := car u; u := cdr u>> else fntype := 'expr;
    if u then numargs := car u else numargs := 1;
    numargs := if numargs=0 then nil
                else if numargs=1 then '(x1)
                else if numargs=2 then '(x1 x2)
                else if numargs=3 then '(x1 x2 x3)
                else if numargs=4 then '(x1 x2 x3 x4)
                else error(99,list(numargs,"too large in defautoload"));
    return
       list('safe!-putd,
            mkquote name,
            mkquote fntype,
            list('function,
                 list('lambda, numargs,
                      'progn .
                      aconc(for each j in loadname
                               collect list('load!-module,mkquote j),
                            list('apply,
                                 mkquote name,
                                 'list . numargs)))))
  end;


COMMENT Actual Entry Point Definitions;

% Bigfloat module entry point.

put('bigfloat,'module!-name,'bfloat);


% Compiler and LAP entry points.

% defautoload(compd,compiler,expr,3);

defautoload(compile,compiler);

defautoload(lap,compiler);


% Cross-reference module entry points.

put('cref,'simpfg,'((t (crefon)) (nil (crefoff))));

defautoload(crefon,rcref,expr,0);


% Factorizer module entry points.

remprop('factor,'stat);

defautoload(ezgcdf,ezgcd,expr,2);

defautoload(factorf,'(ezgcd factor));

defautoload(factoreval,'(ezgcd factor));

put('factorize,'psopfn,'factoreval);

defautoload(pfactor,'(ezgcd factor),expr,2);

% defautoload(simpnprimitive,'(ezgcd factor));

% put('nprimitive,'simpfn,'simpnprimitive);

defautoload(simpresultant,rsltnt);

defautoload(resultant,rsltnt,expr,3);

put('resultant,'simpfn,'simpresultant);

put('factor,'stat,'rlis);


% FASL module entry points.

%defautoload(faslout,compiler);

flag('(faslout),'opfn);

put('faslend,'stat,'endstat);


% High energy physics module entry points.

remprop('index,'stat); remprop('mass,'stat);

remprop('mshell,'stat); remprop('vecdim,'stat);

remprop('vector,'stat);

defautoload(index,hephys);

defautoload(mass,hephys);

defautoload(mshell,hephys);

defautoload(vecdim,hephys);

defautoload(vector,hephys);

put('index,'stat,'rlis);

put('mshell,'stat,'rlis);

put('mass,'stat,'rlis);

put('vecdim,'stat,'rlis);

put('vector,'stat,'rlis);

flagop nospur;


% Input editor entry points.

defautoload(cedit,util);

defautoload(display,util);

put('display,'stat,'rlis);

defautoload(editdef,util);

put('editdef,'stat,'rlis);


% Integrator module entry point.

defautoload(simpint,int);

put('int,'simpfn,'simpint);


% Matrix module entry points.

defautoload(detq,matr);

defautoload(generateident,matr);

defautoload(matp,matr);

defautoload(matrix,matr);

put('matrix,'stat,'rlis);

flag('(mat),'struct);

put('mat,'formfn,'formmat);

defautoload(formmat,matr,expr,3);

defautoload(lnrsolve,matr,expr,2);


% Prettyprint module entry point.

defautoload(prettyprint,util);


% Rprint module entry point.

defautoload(rprint,util);


% SOLVE module entry point.

defautoload(solveeval,solve);

defautoload(solve0,solve,expr,2);

put('solve,'psopfn,'solveeval);


% Debug module entry points.

% defautoload(embfn,debug,expr,3);

endmodule;


end;

Added r33/excalc.red version [f2c96049e8].



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
module excalc;  % header for EXCALC --- a differential geometry package.

% Author: Eberhard Schruefer;

%************ patches ***************;

% Meaning of ^ and # changed.  !!!! BE AWARE OF THIS "!!!

remprop('!^,'newnam);

% plus and difference changed because we are dealing with non-
% homogenous terms

deflist('
  ((difference getrtypeor)
   (plus getrtypeor)
 ),'rtypefn);

share bndeq!*,detm!*;


%*********************************************************************;
%*********************************************************************;
%                   Differential Geometry Package                     ;
%*********************************************************************;
% This version runs in REDUCE 3.3
%*********************************************************************;
% Version: 2.z                                                        ;
% E.Schruefer 03/12/87                                                ;
%*********************************************************************;
%                       testsite copy                                 ;
% ====== this program must not be redistributed or copied ======      ;
%*********************************************************************;

endmodule;

module indxprin; % Functions for special print.

% Author: Eberhard Schruefer;

global '(ycoord!* ymax!* ymin!* obrkp!* !*nat orig!* !*eraise !*revpri
         posn!* pline!* spare!* !*nero);

symbolic procedure indvarprt u;
    if null !*nat then <<prin2!* car u;
                         prin2!* "(";
                         if cddr u then inprint('!*comma!*,0,cdr u)
                          else maprin cadr u;
                         prin2!* ")" >>
     else begin scalar y; integer l;
            l := flatsizec flatindxl u+length cdr u-1;
            if l>(linelength nil-spare!*)-posn!* then terpri!* t;
            %avoid breaking of an indexed variable over a line;
            y := ycoord!*;
            prin2!* car u;
            for each j on cdr u do
              <<ycoord!* :=  y + if atom car j then 1 else -1;
                if ycoord!*>ymax!* then ymax!* := ycoord!*;
                if ycoord!*<ymin!* then ymin!* := ycoord!*;
                prin2!* if atom car j then car j else cadar j;
                if cdr j then prin2!* " ">>;
            ycoord!* := y
          end;

symbolic procedure rembras u;
   if !*nat and (atom u or null get(car u,'infix))
       then <<prin2!* " ";
              maprin u>>
    else <<prin2!* "(";
           maprin u;
           prin2!* ")">>;

put('form!-with!-free!-indices,'tag,'form!-with!-free!-indices);

put('form!-with!-free!-indices,'prifn,'indxpri1);

flag('(form!-with!-free!-indices),'sprifn);

put('indvarprt,'expt,'inbrackets);


endmodule;


%*********************************************************************;
%*****         Global variables and declaration commands          ****;
%*********************************************************************;

module exintro;

% Author: Eberhard Schruefer;

 global '(dimex!* lftshft!* detm!*
          basisforml!* sgn!* wedgemtch!* bndeq!* depl!*
          basisvectorl!* indxl!* nosuml!* !*nosum coord!*
          keepl!* metricd!* metricu!* !*product!-rule);

%Some initialiations;

dimex!* := !*q2f simp 'dim;
sgn!* := !*k2q 'sgn;
!*product!-rule := t;

rlistat('(pform fdomain remfdomain tvector spacedim forder remforder
          frame dualframe keep closedform xpnd noxpnd
          isolate remisolate));

symbolic procedure spacedim u;
   begin
     dimex!* := !*q2f simp car u
   end;

symbolic procedure fdomain u;
   %Sets up implicit dependencies;
   while u do
     <<if not eqexpr car u then errpri2(car u,'hold)
        else begin scalar y;
               rmsubs();
               y := get(cadar u,'rtype);
               remprop(cadar u,'rtype);
               for each x  in cdr caddar u do
                 <<if indvarp x then
                     for each j in mkaindxc flatindxl cdr x do
                        depend1(cadar u,prepsq simpindexvar
                                sublis(pair(flatindxl cdr x,j),x),t)
                    else depend1(cadar u,x,t)>>;
               flag(list cadar u,'impfun);
               if y then put(cadar u,'rtype,y)
             end;
       u := cdr u>>;

smacro procedure get!-impfun!-args u;
   cdr assoc(u,depl!*);

symbolic procedure remfdomain u;
%Removes implicit dependencies;
   begin scalar x;
     for each j in u do
         if x := assoc(j,depl!*) then <<depl!* := delete(x,depl!*);
                                        remflag(list j,'impfun)>>
          else rederr list(j," had no dependencies");
   end;

symbolic procedure putform(u,v);
     if atom u then put(!*a2k u,'fdegree,list !*q2f simp v)
      else
       begin scalar x,y; integer n;
         n := length cdr u;
         if (x := get(car u,'ifdegree)) and (y := assoc(n,x))
             then x := delete(y,x);
         put(car u,'ifdegree,if x then (n . !*q2f simp v) . x
                              else list(n . !*q2f simp v));
         x := car u;
         flag(list x,'indexvar); %this should go.
         put(x,'rtype,'indexed!-form);
         put(x,'simpfn,'simpindexvar);
         put(x,'partitfn,'partitindexvar);
         flag(list x,'full);
         put(x,'prifn,'indvarprt);
         if null numr simp v then flag(list x,'covariant)
      end;

symbolic procedure pform u;
   begin rmsubs();
     for each j in u do
       if not eqexpr j then errpri2(j,'hold)
        else putform(cadr j,caddr j)
   end;

symbolic procedure tvector u;
   for each j in u do putform(j,-1);

symbolic procedure getlower u;
   cdr atsoc(u,metricd!*);

symbolic procedure getupper u;
   cdr atsoc(u,metricu!*);

symbolic procedure xpnd u;
   <<rmsubs(); remflag(u,'noxpnd)>>;

symbolic procedure noxpnd u;
   <<rmsubs(); flag(u,'noxpnd)>>;

symbolic procedure closedform u;
   <<rmsubs(); flag(u,'closed)>>;


symbolic procedure memqcar(u,v);
   null atom u and car u memq v;

smacro procedure lowerind u;
   list('minus,u);

smacro procedure raiseind u;
   list('minus,u);

endmodule;

%*********************************************************************;
%*****       Functions for calculating the degree of a form       ****;
%*********************************************************************;

module degform;

% Author: Eberhard Schruefer;

global '(frlis!*);

symbolic procedure deg!*farg u;
   %Calculates the sum of degrees of the elements of the list u;
   if null cdr u then deg!*form car u else
    begin scalar z;
      for each j in u do z := addf(deg!*form j,z);
      return z
    end;

smacro procedure get!*fdeg u;
   (if x then car x else nil)
    where x = get!*(u,'fdegree);

smacro procedure get!*ifdeg u;
   (if x then cdr x else nil)
    where x = assoc(length cdr u,get(car u,'ifdegree));

symbolic procedure deg!*form u;
%U is a prefix expression. Result is the degree of u;
   if atom u then get!*fdeg u
    else (if flagp(x,'indexvar) then get!*ifdeg u
           else if x eq 'wedge then deg!*farg cdr u
           else if x eq 'd then addd(1,deg!*form cadr u)
           else if x eq 'hodge then addf(dimex!*,negf deg!*form cadr u)
           else if x eq 'partdf then if cddr u then nil else -1
           else if x eq 'liedf then deg!*form caddr u
           else if x eq 'innerprod then addd(-1,deg!*form caddr u)
           else if x memq '(plus minus difference quotient) then
                     deg!*form cadr u
           else if x eq 'times then deg!*farg cdr u
           else nil) where x = car u;

symbolic procedure exformp u;
   %test for exterior forms and vectors in prefix expressions;
   if null u or numberp u then nil
    else if atom u and u memq frlis!* then t
    else if atom u then get(u,'fdegree)
    else if flagp(car u,'indexvar)
            then assoc(length cdr u,get(car u,'ifdegree))
    else if car u eq '!*sq then exformp prepsq cadr u
    else if car u memq '(wedge d partdf hodge innerprod liedf) then t
    else if get(car u,'dname) then nil
    else lexformp cdr u or exformp car u;

symbolic procedure lexformp u;
   u and (exformp car u or lexformp cdr u);


endmodule;

%*********************************************************************;
%****          Partitioned standard forms                         ****;
%*********************************************************************;

module partitsf;

% Author: Eberhard Schruefer;

fluid '(alglist!* !*exp);

smacro procedure ldpf u;
   %selector for leading standard form in patitioned sf;
   caar u;

smacro procedure tpsf u;
   %selector for leading term in partitioned sf;
   car u;

smacro procedure !*k2pf u;
   u .* (1 ./ 1) .+ nil;

smacro procedure negpf u;
   multpfsq(u,(-1) ./ 1);

symbolic procedure partitop u;
   begin scalar x,alglist!*;
   return
   if atom u then if x := get(u,'avalue)
                     then partitsq!* simp!* cadr x
                   else if get!*fdeg u then mkupf u
                   else if numr(x := simp!* u)
                           then 1 .* x .+ nil
                   else nil
    else if x := get(car u,'partitfn)
            then if flagp(car u,'full) then apply1(x,u)
                  else apply1(x,cdr u)
    else if car u eq '!*sq then partitsq!* simp!* u
    else if car u eq 'plus then
            <<for each j in cdr u do
                x := addpf(partitop j,x); x>>
    else if car u eq 'minus then negpf partitop cadr u
    else if car u eq 'difference then
            addpf(partitop cadr u,
                  negpf partitop caddr u)
    else if car u eq 'times then
            <<x := partitop cadr u;
              for each j in cddr u do
                x := multpfs(partitop j,x);
              x>>
    else if car u eq 'quotient then
               multpfsq(partitop cadr u,simprecip cddr u)
    else if car u eq 'recip then
               1 .* simprecip cdr u .+ nil
    else if numr(x := simp!* u)
            then 1 .* x .+ nil
    else nil
  end;

symbolic procedure mkupf u;
   begin scalar x;
     x := mksq(u,1);
     return if null numr x then nil
             else if (denr x = 1) and (lc numr x = 1)
                     and null red numr x and null sfp mvar numr x
                     then !*k2pf mvar numr x
             else partitsq!* x
   end;


symbolic procedure partitsq(u,v);
   %U is a standardquotient. Result is a form in which expressions
   %satisfying the test v are distributed and the rest is kept
   %recursive. Leaves unexpanded structure if possible;
   (if null x then nil
     else if domainp x then 1 .* u .+ nil
     else addpsf(if sfp mvar x and apply1(v,mvar x)
                     then multpsf(exptpsf(partitsq(mvar x ./ 1,v),
                                          ldeg x),
                             partitsq(cancel(lc x ./ y),v))
                 else if null sfp mvar x and apply1(v,!*k2f mvar x)
                          then multpsf(!*p2f lpow x .* (1 ./ 1)  .+ nil,
                                       partitsq(cancel(lc x ./ y),v))
                 else multsqpsf(!*p2q lpow x,
                              partitsq(cancel(lc x ./ y),v)),
                partitsq(cancel(red x ./ y),v)))
    where x = numr u, y = denr u;


symbolic procedure exptpsf(u,n);
   begin scalar x;
    x := u;
    while (n := n-1) > 0 do x := multpsf(u,x);
   return x
   end;

symbolic procedure exptpf(u,n);
   begin scalar x;
    x := u;
    while (n := n-1) > 0 do x := multpfs(u,x);
   return x
   end;

symbolic procedure addpsf(u,v);
   if null u then v
    else if null v then u
    else if domainp ldpf u then addmpsf(u,v)
    else if domainp ldpf v then addmpsf(v,u)
    else if ldpf u = ldpf v then
       (lambda x,y;
        if null numr x then y else ldpf u .* x .+ y)
       (addsq(lc u,lc v),addpsf(red u,red v))
    else if ordpp(lpow ldpf u,lpow ldpf v) then lt u .+ addpsf(red u,v)
    else lt v .+ addpsf(u,red v);

symbolic procedure addpf(u,v);
   if null u then v
    else if null v then u
    else if ldpf u = 1 then addmpf(u,v)
    else if ldpf v = 1 then addmpf(v,u)
    else if ldpf u = ldpf v then
       (lambda x,y;
        if null numr x then y else ldpf u .* x .+ y)
       (addsq(lc u,lc v),addpf(red u,red v))
    else if ordop(ldpf u,ldpf v) then lt u .+ addpf(red u,v)
    else lt v .+ addpf(u,red v);

symbolic procedure addmpf(u,v);
   if null v then u
    else if ldpf v = 1 then 1 .* addsq(lc u,lc v) .+ nil
    else lt v .+ addmpf(u,red v);

symbolic procedure addmpsf(u,v);
   if null v then u else
   if domainp ldpf v then 1 .* addsq(multsq(ldpf u ./ 1,lc u),
                                     multsq(ldpf v ./ 1,lc v)) .+ nil
    else lt v .+ addmpsf(u,red v);

symbolic procedure multpsf(u,v);
   if null u or null v then nil
    else addpsf(addpsf(multtpsf(lt u,lt v),multpsf(red u,v)),
                multpsf(!*t2f lt u,red v));

symbolic procedure multpfs(u,v);
   if null u or null v then nil
    else if ldpf u = 1 then multpfsq(v,lc u)
    else if ldpf v = 1 then multpfsq(u,lc v)
    else addpf(addpf(multttpf(lt u,lt v),multpfs(red u,v)),
               multpfs(lt u .+ nil,red v));

symbolic procedure multttpf(u,v);
   if car u = 1 then car v .* multsq(tc u,tc v) .+ nil
    else if car v = 1 then car u .* multsq(tc u,tc v) .+ nil
    else rederr "illegal factor in pf";

symbolic procedure multpfsq(u,v);
   if null u or null numr v then nil
    else ldpf u .* multsq(lc u,v) .+ multpfsq(red u,v);

symbolic procedure multtpsf(u,v);
   begin scalar x,xexp;
    xexp := !*exp;
    !*exp := t;
    x := if car u = 1 then car v
          else if car v = 1 then car u
          else multf(tpsf u,tpsf v);
    !*exp := xexp;
   return multsqpsf(multsq(tc u,tc v),x .* (1 ./ 1)  .+ nil)
   end;

symbolic procedure multsqpsf(u,v);
   if null numr u or null v then nil
    else ldpf v .* multsq(u,lc v) .+ multsqpsf(u,red v);

symbolic procedure repartit u;
   if null u then nil
    else addpf(multpfsq(partitop ldpf u,lc u),repartit red u);

symbolic procedure partitsq!* u;
   %U is a standardquotient. Partitfunction for *sq's.
   %Leaves unexpanded structure if possible;
   (if null x then nil
     else if domainp x then 1 .* u .+ nil
     else addpf(if sfp mvar x and sfexform1p lt mvar x
                     then multpfsq(exptpf(partitsq!*(mvar x ./ 1),
                                         ldeg x),
                                   cancel(lc x ./ y))
                 else if null sfp mvar x and deg!*form mvar x
                          then mvar x .* cancel(lc x ./ y) .+ nil
                 else multpfsq(partitsq!*(lc x ./ y),
                               !*p2q lpow x),
                partitsq!*(red x ./ y)))
    where x = numr u, y = denr u;

symbolic procedure sfexform1p u;
   (if sfp tvar u then sfexform1p lt tvar u
     else deg!*form tvar u)
   or (null domainp tc u and sfexform1p lt tc u);

symbolic procedure !*pf2sq u;
   begin scalar res;
     res := nil ./ 1;
     if null u then return res;
     for each j on u do
       res := addsq(multsq(if ldpf j = 1 then 1 ./ 1
                            else !*k2q ldpf j,lc j),res);
     return res
   end;

symbolic procedure mk!*sqpf u;
   if null u then nil
    else ldpf u .* mk!*sq lc u .+ mk!*sqpf red u;

symbolic procedure !*pfsq2pf u;
   if null u then nil
    else (lambda x;
          if numr x
             then ldpf u .* x .+ !*pfsq2pf red u
           else !*pfsq2pf red u)
          simp!* lc u;

endmodule;

%*********************************************************************;
%******                Functions for ordering                    *****;
%*********************************************************************;

module forder;

% Author: Eberhard Schruefer;

global '(wedgemtch!* lftshft!* indxl!* subfg!*);

fluid '(kord!*);


symbolic procedure add2l(u,v);
   !*a2k u . if u memq v then delete(u,v) else v;

symbolic procedure forder u;
   forder1 u;

symbolic procedure forder1 u;
   (lambda x;
    while x do
    <<kord!* := add2l(car x,kord!*);
      if eqcar(car x,'wedge) then
         for each j in reverse cdar x do
             kord!* := add2l(j,kord!*);
      x:=cdr x>>)
    reverse u;

symbolic procedure remforder u;
   for each j in u do kord!* := delete(j,kord!*);

symbolic procedure isolate u;
   rederr "Sorry, ISOLATE not supported in this version";
%  for each j in u do
%    <<lftshft!* := !*a2k car u . lftshft!*;
%      kord!* := !*a2k car u . kord!*>>;

symbolic procedure remisolate u;
   for each j in u do lftshft!* := delete(j,lftshft!*);

smacro procedure wedgeordp(u,v); worderp(u,v);

symbolic procedure worderp(x,y);
   %Needs more work!
   if null atom x and flagp(car x,'indexvar) and
      null atom y and flagp(car y,'indexvar)
      then if atom cadr x and (cadr x member indxl!*) and
              atom cadr y and (cadr y member indxl!*)
              then if (car x eq car y) then indordp(cadr x,cadr y)
                    else ordop(car x,car y)
            else ordop(x,y)
    else if atom x or (x memq kord!*) then
            if atom y or (y memq kord!*) then ordop(x,y)
             else worderp(x,peel y)
    else if atom y or (y memq kord!*) then worderp(peel x,y)
    else worderp(peel x,peel y);

symbolic procedure indexvarordp(u,v);
   if null(car u eq car v) then ordop(car u,car v)
    else indordlp(flatindxl cdr u,flatindxl cdr v);

symbolic procedure indordlp(u,v);
   if null u then nil
    else if null v then t
    else if car u eq car v then indordlp(cdr u, cdr v)
    else indordp(car u,car v);

symbolic procedure peel u;
   if car u memq '(liedf innerprod) then u := caddr u
    else if car u eq 'quotient then
            if worderp(cadr u,caddr u) then u:=cadr u
             else u:=caddr u
    else u:=cadr u;

symbolic procedure indordp(u,v);
   begin scalar x;
     x := indxl!*;
     if null(u memq x) then return t;
     a: if null x then return orderp(u,v);
     if u eq car x then return t
     else if v eq car x then return nil;
     x:=cdr x;
     go to a
  end;

symbolic procedure indordn u;
   if null u then nil
    else if null cdr u then u
    else if null cddr u then indord2(car u,cadr u)
    else indordad(car u,indordn cdr u);

symbolic procedure indord2(u,v);
   if indordp(u,v) then list(u,v) else list(v,u);

symbolic procedure indordad(a,u);
   if null u then list a
    else if indordp(a,car u) then a . u
    else car u . indordad(a,cdr u);

symbolic procedure keep u;
   while u do
     <<if not eqexpr car u then errpri2(car u,'hold)
        else begin scalar x,y,z;
       z := subfg!*;
       subfg!* := nil;
       x := !*a2k cadar u;
       y := !*a2k caddar u;
       forder1 list(x,y);
       keepl!* := (x . y) . keepl!*;
       flag(list x,'keep);
       put(x,'keepl,list y);
       subfg!* := z;
       putdep(x,y);
       if null exdfk y then flag(list x,'closed);
       if eqcar(y,'wedge) then
         <<wedgemtch!*:=(cdr y . x) . wedgemtch!*;
           for each j in cdr y do
             wedgemtch!* := (list(x,j) . nil) . wedgemtch!*>>
       else let2(y,x,nil,t)
     end;
     u := cdr u>>;

symbolic procedure putdep(u,v);
   for each j in cdr v do
     if atom j then depend1(u,j,t) else putdep(u,j);

endmodule;

%*********************************************************************;
%*****                 Exterior multiplication                    ****;
%*********************************************************************;

module wedge;

% Author: Eberhard Schruefer;

global '(dimex!* lftshft!* wedgemtch!*);

newtok '((!^) wedge);

flag('(wedge),'nary);

infix wedge;

precedence wedge,times;

put('wedge,'simpfn,'simpwedge);

put('wedge,'rtypefn,'getrtypeor);

put('wedge,'partitfn,'partitwedge);

symbolic procedure partitwedge u;
   if null cdr u then partitop car u
            else mkuniquewedge xpndwedge u;


symbolic procedure oddp m;
   fixp m and remainder(m,2)=1;

symbolic procedure mksgnsq u;
   if null (u := evenfree u) then 1 ./ 1
    else if u = 1 then (-1) ./ 1
    else simpexpt list(-1,mk!*sq(u ./ 1));

symbolic procedure evenfree u;
   if null u then nil
    else if numberp u then absf cdr qremd(u,2)
    else addf(absf cdr qremd(!*t2f lt u,2),evenfree red u);

smacro procedure lwf u;
   %selector for leading factor in wedge.
   car u;

smacro procedure rwf u;
   %selector for the rest of factors in wedge.
   cdr u;

smacro procedure lftshftp u;
   smemqlp(lftshft!*,u);

symbolic procedure mkwedge u; !*k2pf u;

symbolic procedure wedgemtch u;
   begin scalar x,y,z;
     y := u;
     a: x := car y . x;
    if z := assoc(reverse x,wedgemtch!*) then
       return if cdr z then if cdr y then
                               'wedge . append(cdr z,cdr y)
                             else cdr z
               else 0;
    y := cdr y;
    if y then go to a else return nil
   end;


symbolic procedure simpwedge u;
   !*pf2sq partitwedge u;

symbolic procedure xpndwedge u;
   if null cdr u
      then mkunarywedge partitop car u
    else wedgepf2(partitop car u,xpndwedge cdr u);

symbolic procedure mkunarywedge u;
   if null u then nil
    else list ldpf u .* lc u .+ mkunarywedge red u;

symbolic procedure mkuniquewedge u;
   if null u then nil
    else addpf(multpfsq(mkuniquewedge1 ldpf u,lc u),
               mkuniquewedge red u);

symbolic procedure mkuniquewedge1 u;
   if null cdr u
      then mkupf car u
    else begin scalar x;
           return if wedgemtch!* and (x := wedgemtch u)
                     then partitop x
                   else mkupf('wedge . u)
         end;

symbolic procedure wedgepf2(u,v);
   %Basic binary exterior product routine.
   %v is an exterior product (without wedge tag), u a form.
   if null u or null v then nil
    else addpf(wedget2(lt u,lt v),
               addpf(wedgepf2(lt u .+ nil,red v),wedgepf2(red u,v)));

smacro procedure multwedgesq(u,v);
   %possible entry for lazy multiplication.
   multsq(u,v);

symbolic procedure wedget2(u,v);
   if car u = 1 then car v .* multsq(cdr u,cdr v) .+ nil
    else if caar v = 1 then list car u .* multsq(cdr u,cdr v) .+ nil
    else multpfsq(wedgek2(car u,car v,nil),multwedgesq(tc u,tc v));

symbolic procedure wedgek2(u,v,w);
   if u eq car v and null eqcar(u,'wedge)
      then if oddp deg!*form u then nil
            else multpfsq(wedgef(u . v),mksgnsq w)
    else if eqcar(car v,'wedge) then wedgek2(u,cdar v,w)
    else if eqcar(u,'wedge)
            then multpfsq(wedgewedge(cdr u,v),mksgnsq w)
    else if wedgeordp(u,car v)
            then multpfsq(wedgef(u . v),mksgnsq w)
    else if cdr v
            then wedgepf2(!*k2pf car v,
                          wedgek2(u,cdr v,addf(w,multf(deg!*form u,
                                                   deg!*form car v))))
    else multpfsq(wedgef list(car v,u),
                  mksgnsq addf(w,multf(deg!*form u,deg!*form car v)));

symbolic procedure wedgewedge(u,v);
   if null cdr u then wedgepf2(!*k2pf car u,!*k2pf v)
    else wedgepf2(!*k2pf car u,wedgewedge(cdr u,v));


symbolic procedure wedgef u;
     if dim!<deg u then nil
      else if eqcar(car u,'hodge) then
              (if m = deg!*farg cdr u then
                  multpfsq(wedgepf2(!*k2pf cadar u,
                                    mkunarywedge
                                     hodgepf if cddr u
                                              then mkuniquewedge1 cdr u
                                              else !*k2pf cadr u),
                           mksgnsq multf(m,addf(m,negf dimex!*)))
                else mkwedge u)
               where m = deg!*form cadar u
      else if eqcar(car u,'d) and (flagp('d,'noxpnd)
              or lftshftp cadar u) then
                    addpf(mkunarywedge dwedge(cadar u . cdr u),
                          multpfsq(wedgepf2(!*k2pf cadar u,
                                            mkunarywedge
                                              if cddr u
                                                 then dwedge cdr u
                                               else exdfk cadr u),
                                   negsq mksgnsq deg!*form cadar u))
      else mkwedge u;

endmodule;

%*********************************************************************;
%*****                Exterior differentiation                    ****;
%*********************************************************************;

module exdf;

% Author: Eberhard Schruefer;

global '(naturalframe2coframe dbaseform2base2form basisforml!* dimex!*
         subfg!*);


put('d,'simpfn,'simpexdf);

put('d,'rtypefn,'getrtypecar);

put('d,'partitfn,'partitexdf);

symbolic procedure partitexdf u;
   exdfpf partitop car u;

symbolic procedure simpexdf u;
   !*pf2sq partitexdf u;

symbolic procedure mkexdf u;
   begin scalar x,y;
     return if x := opmtch(y := list('d,u))
               then partitop x
             else mkupf y
   end;

symbolic procedure exdfpf u;
   if null u then nil
    else addpf(if ldpf u = 1
                  then exdf0 lc u
                else addpf(multpfsq(exdfk ldpf u,lc u),
                           mkuniquewedge wedgepf2(exdf0 lc u,
                                                  !*k2pf list ldpf u)),
               exdfpf red u);

symbolic procedure exdfk u;
   if u = 1 or eqcar(u,'d) or dim!<!=deg u
            or flagp(lid u,'closed) then nil
    else if flagp('d,'noxpnd) or lftshftp u then mkexdf u
    else if atomf u then
           if (not flagp('partdf,'noxpnd)) and
                   flagp(lid u,'impfun)
              then dimpfun(u,get!-impfun!-args lid u)
    else if coordp u then
            if subfg!*
               then !*pfsq2pf cdr atsoc(u,naturalframe2coframe)
             else mkexdf u
    else if basisformp u and dbaseform2base2form then
             !*pfsq2pf cdr atsoc(u,dbaseform2base2form)
          else mkexdf u
    else if (car u eq 'wedge) then dwedge cdr u
    else if car u memq '(hodge innerprod liedf) then mkexdf u
    else if car u eq 'partdf then
           if not flagp('partdf,'noxpnd) and atomf cadr u
              then dimpfun(u,get!-impfun!-args lid cadr u)
          else mkexdf u
    else begin scalar x,y,z;
           if null(x := get(car u,'dfn)) then return mkexdf u;
           z := cdr u;
           for each j in
               for each k in z collect partitexdf list k do
            <<if j then
               y := addpf(multpfsq(j,simp subla(pair(caar x,z),cdar x)),
                          y);
              x := cdr x>>;
           return y
         end;

symbolic procedure lid u;
   if atom u then u else car u;

symbolic procedure atomf u;
   atom u or flagp(car u,'indexvar);

symbolic procedure dim!<!=deg u;
   (null x or (fixp x and x<=0))
    where x = addf(dimex!*,negf deg!*form u);

symbolic procedure dim!<deg u;
   begin scalar x;
     x := addf(dimex!*,negf deg!*farg u);
     return if numberp x and minusp x then t
             else nil
   end;

symbolic procedure dimpfun(u,v);
   if null v then nil
    else addpf(multpfsq(exdfp0(car v . 1),partdfsq(simp u,car v)),
               dimpfun(u,cdr v));

symbolic procedure exdf0 u;
   multpfsq(addpf(exdff0 numr u,multpfsq(exdff0 negf denr u,u)),
            1 ./ denr u);

symbolic procedure exdff0 u;
   if domainp u then nil
    else addpf(addpf(multpfsq(exdff0 lc u,!*p2q lpow u),
                     multpfsq(exdfp0 lpow u,lc u ./ 1)),
               exdff0 red u);

symbolic procedure exdfp0 u; %weighted vars ??
   begin scalar pv,n,z;
     pv := car u;
      n := pdeg u;
     return if (sfp pv or exformp pv or null subfg!*)
               and (z := if sfp pv then exdff0 pv
                          else exdfk pv)
               then if n = 1 then z
                     else multpfsq(z,!*t2q((pv to (n - 1)) .* n))
             else nil
   end;

symbolic procedure dwedge u;
   %u is a wedge argument, result is a pf.
   mkuniquewedge dwedge1(u,nil);

symbolic procedure dwedge1(u,v);
   if null rwf u
      then mkunarywedge multpfsq(exdfk lwf u,mksgnsq v)
    else addpf(wedgepf2(!*k2pf lwf u,
                       dwedge1(rwf u,addf(v,deg!*form lwf u))),
               multpfsq(wedgepf2(exdfk lwf u,!*k2pf rwf u),mksgnsq v));

symbolic procedure exdfprn u;
   <<prin2!* "d"; rembras cadr u>>;

put('d,'prifn,'exdfprn);

endmodule;

%*********************************************************************;
%*****                 Partial differentiation                    ****;
%*********************************************************************;

module partdf;

% Author: Eberhard Schruefer;
%adapted df module;

global '(naturalvector2framevector depl!* wtl!* keepl!*);

fluid '(alglist!*);

newtok '((!@) partdf);

symbolic procedure simppartdf0 u;
   begin scalar v;
     if null cdr u then
           if coordp(u := reval car u)
              and (v := atsoc(u,naturalvector2framevector))
              then return !*pf2sq !*pfsq2pf cdr v
            else return mksq(list('partdf,u),1);
     if null subfg!* or freeindp car u or freeindp cadr u
                     or (cddr u and freeindp caddr u)
           then return mksq('partdf . revlis u,1);
     v := cdr u;
     u := simp!* car u;
     for each j in v do
         u := partdfsq(u,!*a2k j);
    return u
   end;

put('partdf,'simpfn,'simppartdf);

put('partdf,'rtypefn,'getrtypeor);

put('partdf,'partitfn,'partitpartdf);

symbolic procedure partitpartdf u;
   if null cdr u then mknatvec !*a2k car u
    else 1 .* simppartdf0 u .+ nil;

symbolic procedure simppartdf u;
   !*pf2sq partitpartdf u;

symbolic procedure mknatvec u;
   begin scalar x,y;
     return if x := atsoc(u,naturalvector2framevector)
               then !*pfsq2pf cdr x
             else if x := opmtch(y := list('partdf,u))
               then partitop x
             else mkupf y
   end;

symbolic procedure partdfsq(u,v);
   multsq(addsq(partdff(numr u,v),
                  multsq(u,partdff(negf denr u,v))),
                 1 ./ denr u);

symbolic procedure partdff(u,v);
   if domainp u then nil ./ 1
    else addsq(if null !*product!-rule then partdft(lt u,v)
                else addsq(multpq(lpow u,partdff(lc u,v)),
                           multsq(partdfpow(lpow u,v),lc u ./ 1)),
                partdff(red u,v));

symbolic procedure partdft(u,v);
   begin scalar x,y;
   x := partdft1(!*t2q u,v);
   y := nil ./ 1;
   for each j on x do
     if null domainp ldpf j then
        y := addsq(multsq(if domainp lc ldpf j then
                             multsq(partdfpow(lpow ldpf j,v),
                                    lc ldpf j ./ 1)
                           else mksq(list('partdf,prepf ldpf j,v),1),
                          lc j),y);
   return y
   end;

symbolic procedure partdft1(u,v);
   (if null x then nil
     else if domainp x then 1 .* u .+ nil
     else addpsf(if sfp mvar x and numr partdfpow(lpow mvar x,v)
                     then multpsf(exptpsf(partdft1(mvar u ./ 1,v),
                                          ldeg x),
                             partdft1(cancel(lc x ./ y),v))
                 else if null sfp mvar x and numr partdfpow(lpow x,v)
                          then multpsf(!*p2f lpow x .* (1 ./ 1)  .+ nil,
                                       partdft1(cancel(lc x ./ y),v))
                 else multsqpsf(!*p2q lpow x,
                              partdft1(cancel(lc x ./ y),v)),
                partdft1(cancel(red x ./ y),v)))
    where x = numr u, y = denr u;

symbolic procedure partdfpow(u,v);
   begin scalar x,z; integer n;
       n := cdr u;
       u := car u;
       z := nil ./ 1;
       if u eq v then z := 1 ./ 1
        else if atomf u then
                if x := assoc(u,keepl!*) then
                       begin scalar alglist!*;
                         z := partdfsq(simp0 cdr x,v)
                       end
                 else if ndepends(if x := get(lid u,'varlist)
                                     then lid u . cdr x
                                   else lid u,v)
                      then z := mksq(list('partdf,u,v),1)
                 else return nil ./ 1
        else if sfp u then z := partdff(u,v)
        else if car u eq '!*sq then z := partdfsq(cadr u,v)
        else if x := get(car u,'dfn) then
                 for each j in
                    for each k in cdr u collect partdfsq(simp k,v)
                  do <<if numr j then
                        z := addsq(multsq(j,simp
                                     subla(pair(caar x,cdr u),cdar x)),
                                   z);
                 x := cdr x>>
        else if car u eq 'partdf then
                if ndepends(lid cadr u,v) then
                   if assoc(list('partdf,cadr u,v),
                            get('partdf,'kvalue)) then
                       <<z := mksq(list('partdf,cadr u,v),1);
                         for each j in cddr u do
                             z := partdfsq(z,j)>>
                    else
                       <<z := 'partdf . cadr u . ordn(v . cddr u);
                         z := if x := opmtch z then simp x
                               else mksq(z,1)>>
                 else return nil ./ 1;
       if x := atsoc(u,wtl!*) then z := multpq('k!* to (-cdr x),z);
   return if n=1 then z
           else multsq(!*t2q((u to (n-1)) .* n),z)
   end;

symbolic procedure ndepends(u,v);
   if null u or numberp u or numberp v then nil
    else if u=v then u
    else if atom u and u memq frlis!* then t
    else if (lambda x; x and lndepends(cdr x,v)) assoc(u,depl!*)
     then t
    else if not atom u and idp car u and get(car u,'dname) then nil
    else if not atomf u
      and (lndepends(cdr u,v) or ndepends(car u,v)) then t
    else if atomf v or idp car v and get(car v,'dname) then nil
    else ndependsl(u,cdr v);

symbolic procedure lndepends(u,v);
   u and (ndepends(car u,v) or lndepends(cdr u,v));

symbolic procedure ndependsl(u,v);
   u and (ndepends(u,car v) or ndependsl(u,cdr v));

symbolic procedure partdfprn u;
    if null !*nat then <<prin2!* '!@;
                         prin2!* "(";
                         if cddr u then inprint('!*comma!*,0,cdr u)
                          else maprin cadr u;
                         prin2!* ")" >>
     else begin scalar y; integer l;
            l := flatsizec flatindxl cdr u+1;
            if l>(linelength nil-spare!*)-posn!* then terpri!* t;
            %avoids breaking of the operator over a line;
            y := ycoord!*;
            prin2!* '!@;
            ycoord!* :=  y - if (null cddr u and indexvp cadr u) or
                                (cddr u and indexvp caddr u) then 2
                              else 1;
                if ycoord!*<ymin!* then ymin!* := ycoord!*;
                if null cddr u then <<maprin cadr u;
                                     ycoord!* := y>>
                 else <<for each j on cddr u do
                          <<maprin car j;
                            if cdr j then prin2!* " ">>;
                        ycoord!* := y;
                        if atom cadr u then prin2!* cadr u
                         else <<prin2!* "(";
                                maprin cadr u;
                                prin2!* ")">>>>
          end;

put('partdf,'prifn,'partdfprn);

symbolic procedure indexvp u;
   null atom u and flagp(car u,'indexvar);


endmodule;

%*********************************************************************;
%*****                  Hodge-* duality operator                  ****;
%*********************************************************************;

module hodge;

% Author: Eberhard Schruefer;

global '(dimex!* sgn!* detm!* basisforml!*);

symbolic procedure formhodge(u,vars,mode);
   if mode eq 'symbolic then 'hash . formlis(cdr u,vars,mode)
    else 'list . mkquote 'hodge . formlis(cdr u,vars,mode);

put('hash,'formfn,'formhodge);

put('hodge,'simpfn,'simphodge);

put('hodge,'rtypefn,'getrtypecar);

put('hodge,'partitfn,'partithodge);

symbolic procedure partithodge u;
   hodgepf partitop car u;

symbolic procedure simphodge u;
   !*pf2sq partithodge u;

symbolic procedure mkhodge u;
   begin scalar x,y;
     return if x := opmtch(y := list('hodge,u))
               then partitop x
             else if deg!*form u = dimex!*
                     then 1 .* mksq(y,1) .+ nil
                   else mkupf y
   end;

smacro procedure mkbaseform u;
   mkupf list(caar basisforml!*,u);

symbolic procedure basisformp u;
   null atom u and (u memq basisforml!*);

symbolic procedure hodgepf u;
   if null u then nil
    else addpf(multpfsq(hodgek ldpf u,lc u),hodgepf red u);

symbolic procedure hodgek u;
   if eqcar(u,'hodge)
      then cadr u .* multsq(mksgnsq multf(deg!*form cadr u,
                              addf(dimex!*,negf deg!*form cadr u)),
                                   sgn!*) .+ nil
    else if basisformp u then dual list u
    else if eqcar(u,'wedge) and boundindp(cdr u,basisforml!*) then
            dual cdr u
    else mkhodge u;

symbolic procedure dual u;
   (multpfsq(mkdual xpnddual u,
             simpexpt list(mk!*sq(absf numr x ./
                                  absf denr x),'(quotient 1 2))))
    where x = simp!* detm!*;

symbolic procedure !*met2pf u;
   metpf1 getupper cadr u;

symbolic procedure xpnddual u;
   if null cdr u
      then mkunarywedge !*met2pf car u
    else wedgepf2(!*met2pf car u,xpnddual cdr u);

symbolic procedure metpf1 u;
   if null u then nil
    else addpf(multpfsq(mkbaseform caar u,simp cdar u),metpf1 cdr u);

symbolic procedure mkdual u;
   if null u then nil
    else addpf(multpfsq(((if null x then nil
                           else if cdr ldpf x
                                   then multpfsq(mkuniquewedge1 ldpf x,
                                                 lc x)
                           else car ldpf x .* lc x .+ nil)
                          where x = dualk ldpf u),
                         lc u),mkdual red u);

symbolic procedure dualk u;
   begin scalar x;
     x := !*k2pf basisforml!*;
     a: x := dualk2(car u,x);
        if null(u := cdr u) then return x;
        go to a
   end;


symbolic procedure dualk2(u,v);
   dualk0(u,v,nil);

symbolic procedure dualk0(u,v,w);
   if u eq car ldpf v
      then if null cdr ldpf v
              then list 1 .* multsq(mksgnsq w,lc v) .+ nil
            else cdr ldpf v .* multsq(mksgnsq w,lc v) .+ nil
    else if null cdr ldpf v then nil
    else wedgepf2(!*k2pf ldpf car v,
                  dualk0(u,cdr ldpf v .* lc v .+ nil,addf(w,1)));

symbolic procedure hodgeprn u;
   <<prin2!* "#"; rembras cadr u>>;

put('hodge,'prifn,'hodgeprn);

endmodule;

%*********************************************************************;
%*****                       Inner product                        ****;
%*********************************************************************;

module innerprod;

% Author: Eberhard Schruefer;

newtok '((!_ !|) innerprod);

infix innerprod;

precedence innerprod,times;

%flag('(innerprod),'nary); %not done for now, but might be worthwhile.

put('innerprod,'simpfn,'simpinnerprod);

put('innerprod,'rtypefn,'getrtypeor);

put('innerprod,'partitfn,'partitinnerprod);

symbolic procedure partitinnerprod u;
   innerprodpf(partitop car u,
               partitop cadr u);

symbolic procedure mkinnerprod(u,v);
   begin scalar x,y;
     return if x := opmtch(y := list('innerprod,u,v))
               then partitop x
             else if deg!*form v = 1
                     then if numr(x := mksq(y,1)) then 1 .* x .+ nil
                           else nil
                   else mkupf y
   end;

symbolic procedure simpinnerprod u;
   !*pf2sq partitinnerprod u;


symbolic procedure innerprodpf(u,v);
   if null u or null v then nil
    else if ldpf v = 1 then nil
    else
      begin scalar res,x;
        for each j on u do
          for each k on v do
            if x := innerprodf(ldpf j,ldpf k)
               then res := addpf(multpfsq(x,multsq(lc j,lc k)),res);
        return res
      end;

symbolic procedure basisvectorp u;
   null atom u and u memq basisvectorl!*;

symbolic procedure tvectorp u;
   (numberp x and x<0) where x = deg!*form ldpf u;

symbolic procedure innerprodf(u,v);
   %Inner product dispatching routine.
   if null tvectorp !*k2pf u then
        rederr "first argument of inner product must be a vector"
    else if v = 1 then nil %is this test necessary??
    else if eqcar(v,'wedge)
            then innerprodwedge(u,cdr v)
    else if eqcar(u,'partdf) and null freeindp cadr u
            then innerprodnvec(u,v)
    else if basisvectorp u and basisformp v
            then innerprodbasis(u,v)
    else if eqcar(v,'innerprod)
            then if u eq cadr v then nil
                  else if ordop(u,cadr v) then mkinnerprod(u,v)
                        else negpf innerprodpf(!*k2pf cadr v,
                                               innerprodf(u,caddr v))
    else mkinnerprod(u,v);

symbolic procedure innerprodwedge(u,v);
   mkuniquewedge innerprodwedge1(u,v,nil);

symbolic procedure innerprodwedge1(u,v,w);
   if null rwf v then mkunarywedge
                      multpfsq(innerprodf(u,lwf v),mksgnsq w)
    else addpf(if null rwf rwf v and (deg!*form lwf rwf v = 1)
                  then multpfsq(!*k2pf list lwf v,
                       multsq(mksgnsq addf(deg!*form lwf v,w),
                              !*pf2sq innerprodf(u,lwf rwf v)))
                else wedgepf2(!*k2pf lwf v,
                              innerprodwedge1(u,rwf v,
                                    addf(w,deg!*form lwf v))),
               if deg!*form lwf v = 1
                  then multpfsq(!*k2pf rwf v,
                                multsq(!*pf2sq innerprodf(u,lwf v),
                                       mksgnsq w))
                else wedgepf2(innerprodf(u,lwf v),
                              rwf v .* mksgnsq w .+ nil));


symbolic procedure innerprodnvec(u,v);
   if eqcar(v,'d) and null deg!*form cadr v
      and null freeindp cadr v
      then if cadr u eq cadr v then 1 .* (1 ./ 1) .+ nil
            else nil
    else if basisformp v
            then begin scalar x,osubfg;
                   osubfg := subfg!*;
                   subfg!* := nil;
                   x := innerprodpf(!*k2pf u,
                                    partitop cdr assoc(v,keepl!*));
                   subfg!* := osubfg;
                   return repartit x
                 end;

symbolic procedure innerprodbasis(u,v);
   if freeindp u or freeindp v then mkinnerprod(u,v)
    else if cadadr u eq cadr v then 1 .* (1 ./ 1) .+ nil
          else nil;


endmodule;

%*********************************************************************;
%*****                    Lie derivative                          ****;
%*********************************************************************;

module liedf;

% Author: Eberhard Schruefer;

global '(commutator!-of!-framevectors);

newtok '((!| !_ ) liedf);

infix liedf;

%flag('(liedf),'nary); %Not done for now, but should be considered.

precedence liedf,innerprod;

put('liedf,'simpfn,'simpliedf);

put('liedf,'rtypefn,'getrtypeor);

symbolic procedure simpliedf u;
   !*pf2sq partitliedf u;

put('liedf,'partitfn,'partitliedf);

symbolic procedure partitliedf u;
   liedfpf(partitop car u,partitop cadr u);

symbolic procedure mkliedf(u,v);
   begin scalar x,y;
     return if x := opmtch(y := list('liedf,u,v))
               then partitop x
             else mkupf y
   end;


symbolic procedure liedfpf(u,v);
   if null tvectorp u then
      rederr "first argument of lie derivative must be a vector"
    else if null tvectorp v then
             addpf(exdfpf innerprodpf(u,v),
                   innerprodpf(u,exdfpf v))
    else begin scalar x;
           for each k on u do
             for each l on v do
               x := addpf(liedftt(lt k,lt l),x);
           return x
         end;

symbolic procedure liedftt(u,v);
   begin scalar x;
     return addpf(multpfsq(liedfk(car u,car v),multsq(tc u,tc v)),
                  addpf(if x := innerprodpf(!*k2pf car u,exdf0 tc v)
                           then car v .*
                                multsq(!*pf2sq x,tc u) .+ nil
                         else nil,
                        if x := innerprodpf(!*k2pf car v,exdf0 tc u)
                           then car u .*
                                negsq multsq(!*pf2sq x,tc v) .+ nil
                   else nil))
   end;

symbolic procedure liedfk(u,v);
   if u eq v then nil
    else if eqcar(u,'partdf) and eqcar(v,'partdf) then nil
    else if basisvectorp u and basisvectorp v
            then if null ordop(u,v)
                    then negpf liedfk(v,u)
                  else if commutator!-of!-framevectors
                          then get!-structure!-const(u,v)
                  else mkliedf(u,v)
    else if eqcar(v,'liedf)
            then if ordop(u,cadr v) then mkliedf(u,v)
                  else addpf(liedfpf(liedfk(u,cadr v),!*k2pf caddr v),
                             liedfpf(!*k2pf cadr v,
                                     liedfpf(!*k2pf u,!*k2pf caddr v)))
    else if worderp(u,v) then mkliedf(u,v)
          else negpf mkliedf(v,u);

symbolic procedure get!-structure!-const(u,v);
   %We currently assume that only the basis has structure consts.
   begin scalar x;
     return if x := assoc(list(cadadr u,cadadr v),
                          commutator!-of!-framevectors)
               then !*pfsq2pf cdr x
             else nil
   end;


endmodule;

%*********************************************************************;
%*****                  Variational derivative                    ****;
%*********************************************************************;

module vardf;

% Author: Eberhard Schruefer;

global '(depl!* keepl!* bndeq!*);

fluid '(kord!*);

symbolic procedure simpvardf u;
   if indvarpf numr simp0 cadr u then mksq('vardf . u,1)
    else begin scalar b,r,v,w,x,y,z;
         v := !*a2k cadr u;
         if null cddr u
          then w := intern compress append(explode '!',
                           explode if atom v then v
                                    else car v)
          else w := caddr u;
         if null atom v then w := w . cdr v;
         putform(w,deg!*form v);
         kord!* := append(list(w := !*a2k w),kord!*);
         if x := assoc(v,depl!*) then
            for each j in cdr x do depend1(w,j,t);
         x := varysq(simp!* car u,v,w);
         b := y := nil ./ 1;
          while x do
              if (z := mvar ldpf x) eq w then
                              <<y := addsq(lc x,y);
                                x := red x>>
               else if eqcar(z,'wedge) then
                        if cadr z eq w then
                           <<y := addsq(multsq(!*k2q('wedge . cddr z),
                                               lc x),y);
                             x := red x>>
                         else if eqcar(cadr z,'d) then
                             <<y := addsq(simp list('wedge,list('d,
                                           list('times,'wedge . cddr z,
                                                 prepsq lc x))),y);
                               b := addsq(multsq(!*k2q('wedge . w .
                                                       cddr z),lc x),
                                          b);
                               x := red x>>
                         else rederr list("wrong ordering ",z)
               else if eqcar(z,'partdf) then
                     <<r := reval list('innerprod,
                                        list('partdf,caddr z),
                                        prepsq lc x);
                       x := addpsf((if cdddr z then
                                      !*k2f('partdf . w . cdddr z)
                                     else !*k2f w)
                                      .* negsq simp list('d,r)
                                      .+ nil,red x);
                       b := addsq(multsq(if cdddr z then
                                          !*k2q('partdf . w . cdddr z)
                                          else !*k2q w,simp r),b)>>
               else << b := addsq(multsq(simp cadr z,lc x),b);
                       x := red x>>;
     kord!* := cdr kord!*;
     bndeq!* := mk!*sq b;
     return y
     end;

put('vardf,'simpfn,'simpvardf);

put('vardf,'rtypefn,'getrtypeor);

put('vardf,'partitfn,'partitvardf);

symbolic procedure partitvardf u;
   partitsq!* simpvardf u;

symbolic procedure varysq(u,v,w);
   multpsf(addpsf(varyf(numr u,v,w),
                  multpsf(1 .* u .+ nil,varyf(negf denr u,v,w))),
           1 .* (1 ./ denr u) .+ nil);

symbolic procedure varyf(u,v,w);
   if domainp u then nil
    else addpsf(addpsf(multpsf(1 .* !*p2q lpow u .+ nil,
                               varyf(lc u,v,w)),
                       multpsf(varyp(lpow u,v,w),
                               1 .* (lc u ./ 1) .+ nil)),
                varyf(red u,v,w));

symbolic procedure varyp(u,v,w);
   begin scalar x,z; integer n;
       n := cdr u;
       u := car u;
       if u eq v then z := !*k2f w .* (1 ./ 1) .+ nil
        else if atomf u then
                if x := assoc(u,keepl!*) then
                   begin scalar alglist!*;
                         z := varysq(simp0 cdr x,v,w)
                   end
                 else if null atom u and null atom v then
                         if u=v then !*k2f w .* (1 ./ 1) .+ nil
                          else nil
                 else if null atom v then nil
                 else if depends(u,v) then
                         z := !*k2f w .* simp list('partdf,u,v) .+ nil
                 else nil
        else if sfp u then z := varyf(u,v,w)
        else if car u eq '!*sq then z := varysq(cadr u,v,w)
        else if x := get(car u,'dfn) then
                 for each j in
                    for each k in cdr u collect varysq(simp k,v,w)
                  do <<if j then
                        z := addpsf(multpsf(j,1 .* simp
                                     subla(pair(caar x,cdr u),cdar x)
                                   .+ nil),z);
                 x := cdr x>>
        else if x := get(car u,'varyfn) then z := apply3(x,cdr u,v,w)
        else if ndepends(u,v) then
                   z := !*k2f w .* simp list('partdf,u,v) .+ nil
        else nil;
   return if n=1 then z
           else multpsf(1 .* !*t2q((u to (n-1)) .* n) .+ nil,z)
   end;

symbolic procedure varywedge(u,v,w);
   begin scalar x,y,z;
   x := list 'wedge;
   for each j on u do
     <<y := varysq(simp car j,v,w);
       if y then
        z := addpsf(if deg!*form w then
                       !*a2f append(x,prepf ldpf y . cdr j)
                                      .* lc y .+ nil
                     else ldpf y .* multsq(1 ./ denr lc y,simp
                             append(x,prepf numr lc y . cdr j))
                             .+ nil,z);
       x := append(x,list car j)>>;
   return z
   end;

put('wedge,'varyfn,'varywedge);

symbolic procedure varyexdf(u,v,w);
   begin scalar x;
    for each j on varysq(simp car u,v,w) do
      if j then
       x := addpsf(!*a2f list('d,mvar ldpf j) .* lc j .+ nil,x);
   return x
   end;

put('d,'varyfn,'varyexdf);

symbolic procedure varyhodge(u,v,w);
   begin scalar x;
    for each j on varysq(simp car u,v,w) do
      if j then
       x := addpsf(!*a2f list('hodge,mvar ldpf j) .* lc j .+ nil,x);
   return x
   end;

put('hodge,'varyfn,'varyhodge);

symbolic procedure varypartdf(u,v,w);
   begin scalar x;
    for each j on varysq(simp car u,v,w) do
      if j then
       x := addpsf(!*a2f('partdf . mvar ldpf j . cdr u) .* lc j .+ nil,
                   x);
   return x
   end;

put('partdf,'varyfn,'varypartdf);

symbolic procedure simpnoether u;
   if indvarpf numr simp0 caddr u then mksq('noether . u,1)
    else begin scalar x,y;
           simpvardf list(car u,cadr u);
           x := simp!* bndeq!*;
           y := intern compress append(explode '!',
                                       explode if atom cadr u
                                                  then cadr u
                                                else caadr u);
           if null atom cadr u then y := y . cdadr u;
           y := list(y . list('liedf,caddr u,cadr u));
           return addsq(multsq(subf(numr x,y),1 ./ denr x),
                        negsq simp list('innerprod,caddr u,car u))
         end;

put('noether,'simpfn,'simpnoether);

symbolic procedure noetherind u;
   caddr u;

put('noether,'indexfun,'noetherind);

put('noether,'rtypefn,'getrtypeor);

endmodule;

%**********************************************************************;
%******                Non-scalar valued forms                   ******;
%**********************************************************************;

module indices;

% Author: Eberhard Schruefer;

fluid '(!*exp !*sub2 alglist!*);

global '(!*msg frasc!* mcond!*);

symbolic procedure indexeval(u,u1);
   %toplevel evaluation function for indexed quantities;
   begin scalar v,x,alglist!*;
     v := simp!* u;
     x := subfg!*;
     subfg!* := nil;
     %we don't substitute values here, since indexsymmetries can
     %save us a lot of work;
     v := quotsq(xpndind partitsq(numr v ./ 1,'indvarpf),
                 xpndind partitsq(denr v ./ 1,'indvarpf));
     subfg!* := x;
     %if there are no free indices, we have already the result;
     %otherwise indxlet does the further simplification;
     if numr v and
        null indvarpf !*t2f lt numr v then v := exc!-mk!*sq2 resimp v
      else v := prepsqxx v;
     % We have to convert to prefix here, since we don't have a tag.
     % This is a big source of inefficency.
     return v
   end;

symbolic procedure exc!-mk!*sq2 u;  %this is taken from matr;
   begin scalar x;
        x := !*sub2;   %since we need value for each element;
        u := subs2 u;
        !*sub2 := x;
        return mk!*sq u
   end;

symbolic procedure xpndind u;
   %performs the implied summation over repeated indices;
   begin scalar x,y;
     y := nil ./ 1;
     a: if null u then return y;
     if null(x := contind ldpf u) then
        y := addsq(multsq(!*f2q ldpf u,lc u),y)
      else for each k in mkaindxc x do
        y := addsq(multsq(subcindices(ldpf u,pair(x,k)),lc u),y);
     u := red u;
     go to a
   end;

symbolic procedure subcindices(u,l);
   %Substitutes dummy indices from a-list l into s.f. u;
   %discriminates indices from variables;
   begin scalar alglist!*;
     return if domainp u then u ./ 1
             else addsq(multsq(
                           exptsq(if flagp(car mvar u,'indexvar) then
                                        simpindexvar subla(l,mvar u)
                                   else simp subindk(l,mvar u),ldeg u),
                               subcindices(lc u,l)),
                       subcindices(red u,l))
   end;

symbolic procedure subindk(l,u);
   %Substitutes indices from a-list l into kernel u;
   %discriminates indices from variables;
   car u . for each j in cdr u collect
               if atom j then j
                else if idp car j and get(car j,'dname) then j
                else if flagp(car j,'indexvar) then
                                  car j . subla(l,cdr j)
                else subindk(l,j);

put('form!-with!-free!-indices,'evfn,'indexeval);

put('indexed!-form,'rtypefn,'freeindexchk);

put('form!-with!-free!-indices,'setprifn,'indxpri);

symbolic procedure freeindexchk u;
   if u and indxl!* and indxchk u then 'form!-with!-free!-indices
    else nil;

symbolic procedure indvarp u;
   %typechecking for variables with free indices on prefix forms;
   null !*nosum and indxl!* and
    if eqcar(u,'!*sq) then
       indvarpf numr cadr u or indvarpf denr cadr u
     else freeindp u;

symbolic procedure indvarpf u;
   %typechecking for free indices in s.f.'s;
   if domainp u then nil
    else or(if sfp mvar u then indvarpf mvar u
             else freeindp mvar u,
            indvarpf lc u,indvarpf red u);

symbolic procedure freeindp u;
   begin scalar x;
     return if null u or numberp u then nil
             else if atom u then nil
             else if car u eq '!*sq then freeindp prepsq cadr u
             else if idp car u and get(car u,'dname) then nil
             else if flagp(car u,'indexvar) then indxchk cdr u
             else if (x := get(car u,'indexfun)) then
                                      freeindp apply1(x,cdr u)
             else if car u eq 'partdf then
                     if null cddr u then freeindp cadr u
                      else freeindp cadr u or freeindp caddr u
             else lfreeindp cdr u or freeindp car u
   end;

symbolic procedure lfreeindp u;
   u and (freeindp car u or lfreeindp cdr u);

symbolic procedure indxchk u;
   %returns t if u contains at least one free index;
   begin scalar x,y;
   x := u;
   y := union(indxl!*,nosuml!*);
   a: if null x then return nil;
      if null ((if atom car x
                 then if numberp car x then !*num2id abs car x
                       else car x
                 else if numberp cadar x then !*num2id cadar x
                       else cadar x) memq y)
                then return t;
      x := cdr x;
      go to a
   end;

symbolic procedure indexrange u;
   <<indxl!* := mkindxl u; nil>>;

symbolic procedure nosum u;
   <<nosuml!* := union(mkindxl u,nosuml!*); nil>>;

symbolic procedure renosum u;
   <<nosuml!* := setdiff(mkindxl u,nosuml!*); nil>>;

symbolic procedure mkindxl u;
   for each j in u collect if numberp j then !*num2id j
                            else j;

rlistat('(indexrange nosum renosum));

smacro procedure upindp u;
%tests if u is a contravariant index;
   atom revalind u;

symbolic procedure allind u;
   %returns a list of all unbound indices found in standard form u;
   allind1(u,nil);

symbolic procedure allind1(u,v);
   if domainp u then v
    else allind1(red u,allind1(lc u,append(v,allindk mvar u)));

symbolic procedure allindk u;
   begin scalar x;
     return if atom u then nil
             else if flagp(car u,'indexvar) then
                     <<for each j in cdr u do
                         if atom(j := revalind j)
                            then if null(j memq indxl!*)
                                    then x := j . x
                                  else nil
                          else if null(cadr j memq indxl!*)
                                  then x := j . x;
                       reverse x>>
             else if (x := get(car u,'indexfun)) then
                           allindk apply1(x,cdr u)
             else if car u eq 'partdf then
                     if null cddr u then
                        for each j in allindk cdr u collect lowerind j
                      else append(allindk cadr u,
                                  for each j in allindk cddr u collect
                                                lowerind j)
             else append(allindk car u,allindk cdr u)
   end;

symbolic procedure contind u;
   %returns a list of indices over which summation has to be performed;
   begin scalar dnlist,uplist;
     for each j in allind u do
       if upindp j then uplist := j . uplist
        else dnlist := cadr j . dnlist;
     return setdiff(xn(uplist,dnlist),nosuml!*)
   end;

symbolic procedure mkaindxc u;
    %u is a list of free indices. result is a list of lists of all
    %possible index combinations;
    begin scalar r,x;
      r := list u;
      for each k in u do
        if x := getindexr k then r := mappl(x,k,r);
      return r
    end;

symbolic procedure mappl(u,v,w);
   if null u then nil
    else append(subst(car u,v,w),mappl(cdr u,v,w));

symbolic procedure getindexr u;
   %Kludge to indexclasses;
   if memq(u,indxl!*) then nil else indxl!*;

symbolic procedure flatindxl u;
   for each j in u collect if atom j then j else cadr j;

symbolic procedure indexlet(u,v,ltype,b,rtype);
   if flagp(car u,'indexvar) then
      if b then setindexvar(u,v)
       else begin scalar y,z,msg;
              msg := !*msg;
              !*msg := nil; %for now.
              u := mvar numr simp0 u;    %is this right?
              z := flatindxl cdr u;
              for each j in if flagp(car u,'antisymmetric) then
                               comb(indxl!*,length z)
                             else mkaindxc z do
                let2(mvar numr simp0 subla(pair(z,j),u),nil,nil,nil);
              !*msg := msg;
              y := get(car u,'ifdegree);
              z := assoc(length cdr u,y);
              y := delete(z,y);
              remprop(car u,'ifdegree);
              if y then put(car u,'ifdegree,y)
               else <<remprop(car u,'rtype);
                      remflag(list car u,'indexvar)>>
             end
    else if subla(frasc!*,u) neq u then
         put(car(u := subla(frasc!*,u)),'opmtch,
             xadd!*((for each j in cdr u collect revalind j) .
                  list(nil . (if mcond!* then mcond!* else t),v,nil),
          get(car u,'opmtch),b))
    else setindexvar(u,v);

put('form!-with!-free!-indices,'typeletfn,'indexlet);

symbolic procedure setindexvar(u,v);
   begin scalar r,s,w,x,y,z,z1,alglist!*;
     x := metricu!* . flagp(car u,'covariant);
     metricu!* := nil; %index position must not be changed here;
     if cdr x then remflag(list car u,'covariant);
     u := simp0 u;
     if red numr u
        or (denr u neq 1) then rederr "illegal assignment";
     u := numr u;
     r := cancel(1 ./ lc u);
     u := mvar u;
     metricu!* := car x;
     if cdr x then flag(list car u,'covariant);
     z1 := allindk u;
     z := flatindxl z1;
    if indxl!* and metricu!* then
      <<z1 := for each j in z1 collect
                if flagp(car u,'covariant)
                   then if upindp j then
                           <<u := car u . subst(lowerind j,j,cdr u);
                             'lower . j>>
                         else cadr j
                 else if upindp j then j
                       else <<u := car u . subst(j,cadr j,cdr u);
                              'raise . cadr j>>;
        u := car u . for each j in cdr u collect revalind j>>
     else z1 := z;
    r := multsq(simp!* v,r);
    w := for each j in if flagp(car u,'antisymmetric) then
                            comb(indxl!*,length z)
                   else mkaindxc z collect
      <<x := mkletindxc pair(z1,j);
        s := nil ./ 1;
        y := subfg!*;
        subfg!* := nil;
        for each k in x do
          s := addsq(multsq(car k,subfindices(numr r,cdr k)),s);
        subfg!* := y;
        y := !*q2f simp0 subla(pair(z,j),u);
        mvar y . exc!-mk!*sq2 multsq(subf(if minusf y then negf numr s
                                      else numr s,nil),
                               invsq subf(multf(denr r,denr s),nil))>>;
      for each j in w do let2(car j,cdr j,nil,t)
    end;

symbolic procedure mkletindxc u;
   %u is a list of dotted pairs. Left part is unbound index and action.
   %Right part is bound index.
   begin scalar r; integer n;
     r := list((1 ./ 1) . for each j in u collect
                            if atom car j then car j else cdar j);
     for each k in u do
       <<n := n + 1;
         if atom car k then
             r := for each j in r collect car j . subindexn(k,n,cdr j)
        else r := mapletind(if caar k eq 'raise then getupper cdr k
                             else getlower cdr k,
                            cdar k,r,n)>>;
     return r
   end;

symbolic procedure subindexn(u,n,v);
   if n=1 then u . cdr v
    else car v . subindexn(u,n-1,cdr v);

symbolic procedure mapletind(u,v,w,n);
   if null u then nil
    else append(for each j in w collect
                 multsq(simp!* cdar u,car j) .
                 subindexn(v . caar u,n,cdr j),
                mapletind(cdr u,v,w,n));

put('form!-with!-free!-indices,'setelemfn,'setindexvar);

symbolic procedure clear u;
   begin
     rmsubs();
     remflag('(t),'reserved);  %t is very often used as a coordinate;
     for each x in u do
       <<let2(x,nil,nil,nil); let2(x,nil,t,nil);
         if atom x and get(x,'fdegree) then
            <<remprop(x,'fdegree); remprop(x,'rtype)>>>>;
     mcond!* := frasc!* := nil;
     flag('(t),'reserved)
   end;

symbolic procedure subfindices(u,l);
   %Substitutes free indices from a-list l into s.f. u;
   %discriminates indices from variables;
   begin scalar alglist!*;
     return if domainp u then u ./ 1
             else addsq(multsq(if atom mvar u then !*p2q lpow u
                                else if sfp mvar u then
                                   exptsq(subfindices(mvar u,l),ldeg u)
                                else if flagp(car mvar u,'indexvar)
                                        then  exptsq(simpindexvar
                                               subla(l,mvar u),ldeg u)
                                else if car mvar u memq
                                       '(wedge d partdf innerprod
                                         liedf hodge vardf) then
                                   exptsq(simp
                                            subindk(l,mvar u),ldeg u)
                              else !*p2q lpow u,subfindices(lc u,l)),
                       subfindices(red u,l))
   end;

symbolic procedure indxpri1 u;
   begin scalar metricu,il,dnlist,uplist,r,x,y,z;
     metricu := metricu!*;
     metricu!* := nil;
     il := allind !*t2f lt numr simp0 u;
     for each j in il do
          if upindp j
             then uplist := j . uplist
           else dnlist := cadr j . dnlist;
         for each j in xn(uplist,dnlist) do
             il := delete(j,delete(revalind
                                  lowerind j,il));
         metricu!* := metricu;
     y := flatindxl il;
     r := simp!* u;
     for each j in mkaindxc y do
       <<x := pair(y,j);
         z := exc!-mk!*sq2 multsq(subfindices(numr r,x),1 ./ denr r);
         maprin list('setq,subla(x,'ns . il),z);
         if not !*nat then prin2!* "$";
         terpri!* t>>
       end;

symbolic procedure indxpri(v,u);
   begin scalar x,y,z;
     y := flatindxl allindk v;
     for each j in if flagp(car v,'antisymmetric) and
                      coposp cdr v then comb(indxl!*,length y)
                    else mkaindxc y do
       <<x := pair(y,j);
         z := aeval subla(x,v);
         maprin list('setq,subla(x,v),z);
         if not !*nat then prin2!* "$";
         terpri!* t>>
    end;

symbolic procedure coposp u;
   %checks if all indices in list u are either in a covariant or
   %a contravariant position.;
   null cdr u or if atom car u then contposp cdr u
                  else covposp cdr u;

symbolic procedure contposp u;
   %checks if all indices in list u are contravariant;
   null u or (atom car u and contposp cdr u);

symbolic procedure covposp u;
   %checks if all indices in list u are covariant;
   null u or (null atom car u and covposp cdr u);

put('ns,'prifn,'indvarprt);

symbolic procedure simpindexvar u;
   %simplification function for indexed quantities;
   !*pf2sq partitindexvar u;

symbolic procedure partitindexvar u;
   %partition function for indexed quantities;
   begin scalar freel,x,y,z,v,sgn,w;
     x := for each j in cdr u collect
              (if atom k then
                  if numberp k then
                     if minusp k then lowerind !*num2id abs k
                      else !*num2id k
                   else k
                else if numberp cadr k then lowerind !*num2id cadr k
                      else k) where k = revalind j;
     w := deg!*form u;
     if null metricu!* then go to a;
     z := x;
     if null flagp(car u,'covariant) then
        <<while z and (atom car z or
                       not(cadar z memq indxl!*)) do
             <<y := car z . y;
               if null atom car z then freel := cadar z . freel;
               z := cdr z>>;
               if z then <<v := nil;
                           y := reverse y;
                           for each j in getlower cadar z do
                            v := addpf(multpfsq(partitindexvar(car u .
                                   append(y,car j . cdr z)),
                                               simp cdr j),v);
                           return v>>>>
      else
        <<while z and (null atom car z or
                       not(car z memq indxl!*)) do
             <<y := car z . y;
               if atom car z then freel := car z . freel;
               z := cdr z>>;
               if z then <<v := nil;
                           y := reverse y;
                           for each j in getupper car z do
                             v := addpf(multpfsq(partitindexvar(car u .
                                   append(y,lowerind car j . cdr z)),
                                          simp cdr j),v);
                           return v>>>>;
    a: if null coposp x or (null flagp(car u,'symmetric) and
                            null flagp(car u,'antisymmetric)) then
              return if w then mkupf(car u . x)
                      else 1 .* mksq(car u . x,1) .+ nil;
       x := for each j in x collect if atom j then j else cadr j;
       if flagp(car u,'symmetric) then x := indordn x
        else if flagp(car u,'antisymmetric) then
            <<if repeats x then return nil
               else if not permp(z := indordn x,x) then sgn := t;
               x := z>>;
       if flagp(car u,'covariant) then
          x := for each j in x collect
                 if j memq freel then j else lowerind j
        else if null metricu!* and null atom cadr u then
          x := for each j in x collect lowerind j
        else
          x := for each j in x collect
                 if j memq freel then lowerind j else j;
       return if w then if sgn then  negpf mkupf(car u . x)
                         else mkupf(car u . x)
               else if sgn then 1 .* negsq mksq(car u . x,1) .+ nil
                     else 1 .* mksq(car u . x,1) .+ nil
    end;

symbolic procedure !*num2id u;
%converts a numeric index to an id;
  %if u = 0 then rederr "0 not allowed as index" else
   if u<10 then intern cdr assoc(u,
             '((0 . !0) (1 . !1) (2 . !2) (3 . !3) (4 . !4)
               (5 . !5) (6 . !6) (7 . !7) (8 . !8) (9 . !9)))
    else intern compress append(explode '!!,explode u);

symbolic procedure revalind u;
   begin scalar x,y,alglist!*;
     alglist!* := list(0 . (nil . mksq(!*num2id 0,1)));
     %the above line is used to avoid the simplifaction of -0 to 0.
     x := subfg!*;
     subfg!* := nil;
     y := prepsq simp u;
     subfg!* := x;
     return y
   end;


endmodule;

%**********************************************************************;
%*****                     Cartan frames                         ******;
%**********************************************************************;

module frames;

% Author: Eberhard Schruefer;

global '(naturalframe2coframe dbaseform2base2form dimex!* indxl!*
         naturalvector2framevector subfg!*
         metricd!* metricu!* coord!* cursym!* detm!*
         commutator!-of!-framevectors);

fluid '(alglist!* kord!*);

symbolic procedure coframestat;
   begin scalar framel,metric;
     flag('(with),'delim);
     framel := cdr rlis();
     remflag('(with),'delim);
     if cursym!* eq '!*semicol!* then go to a;
     if scan() eq 'metric then metric := xread t
      else if cursym!* eq 'signature then metric := rlis()
      else symerr('coframe,t);
     a: cofram(framel,metric)
   end;

put('coframe,'stat,'coframestat);


%put('cofram,'formfn,'formcofram);

symbolic procedure cofram(u,v);
   begin scalar alglist!*;
     rmsubs();
     u := for each j in u collect
              if car j eq 'equal then cdr j else list j;
     putform(caar u,1);
     basisforml!* := for each j in u collect !*a2k car j;
     indxl!* := for each j in basisforml!* collect cadr j;
     dimex!* := length u;
     basisvectorl!* := nil;
     if null v then
          metricd!* := nlist(1,dimex!*)
      else if car v eq 'signature then
          metricd!* := for each j in cdr v collect aeval j;
     if null v or (car v eq 'signature) then
       <<detm!* := simp car metricd!*;
         for each j in cdr metricd!* do
             detm!* := multsq(simp j,detm!*);
           detm!* := mk!*sq detm!*;
           metricu!* := metricd!*:= pair(indxl!*,for each j in
                           pair(indxl!*,metricd!*) collect list j)>>
      else mkmetric v;
     if flagp('partdf,'noxpnd) then remflag('(partdf),'noxpnd);
     putform('eps . indxl!*,0);
     flag('(eps),'antisymmetric);
     flag('(eps),'covariant);
     setk('eps . for each j in indxl!* collect lowerind j,1);
     if null cdar u then return;
     keepl!* := append(for each j in u collect
                         !*a2k car j . cadr j,keepl!*);
     coframe1 for each j in u collect cadr j
  end;

symbolic procedure coframe1 u;
   begin scalar osubfg,coords,v,y,w;
     osubfg := subfg!*;
     subfg!* := nil;
     v := for each j in u collect
            <<y := partitop j;
              coords := pickupcoords(y,coords);
              y>>;
     if length coords neq dimex!* then rederr "badly formed basis";
     w := !*pf2matwrtcoords(v,coords);
     naturalvector2framevector := v;
     subfg!* := nil;
     naturalframe2coframe := pair(coords,
          for each j in lnrsolve(w,for each k in basisforml!*
                                       collect list !*k2q k)
              collect mk!*sqpf partitsq!* car j);
     subfg!* := osubfg;
     coord!* := coords;
     dbaseform2base2form := pair(basisforml!*,
          for each j in v collect mk!*sqpf repartit exdfpf j)
   end;

symbolic procedure pickupcoords(u,v);
   %u is a pf, v a list. Picks up vars in exdf and declares them as
   %zero forms.
   if null u then v
    else if null eqcar(ldpf u,'d)
      then rederr "badly formed basis"
    else if null v then <<putform(cadr ldpf u,0);
                          pickupcoords(red u,cadr ldpf u . nil)>>
    else if ordop(cadr ldpf u,car v)
      then if cadr ldpf u eq car v
              then pickupcoords(red u,v)
            else <<putform(cadr ldpf u,0);
                   pickupcoords(red u,cadr ldpf u . v)>>
    else pickupcoords(red u,car v . pickupcoords(!*k2pf ldpf u,cdr v));

symbolic procedure !*pf2matwrtcoords(u,v);
   if null u then nil
    else !*pf2colwrtcoords(car u,v) . !*pf2matwrtcoords(cdr u,v);

symbolic procedure !*pf2colwrtcoords(u,v);
   if null v then nil
    else if u and (cadr ldpf u eq car v)
            then lc u . !*pf2colwrtcoords(red u,cdr v)
    else (nil ./ 1) . !*pf2colwrtcoords(u,cdr v);

symbolic procedure coordp u;
   u memq coord!*;

symbolic procedure mkmetric u;
   begin scalar x,y,okord;
     putform(list(cadr u,nil,nil),0);
     flag(list cadr u,'symmetric);
     flag(list cadr u,'covariant);
     okord := kord!*;
     kord!* := basisforml!*;
     x := simp!* caddr u;
     y := indxl!*;
     metricu!* := t; %to make simpindexvar work;
     for each j in indxl!* do
       <<for each k in y do
           setk(list(cadr u,lowerind j,lowerind k),0);
         y := cdr y>>;
     for each j on partitsq(x,'basep) do
       if ldeg ldpf j = 2 then
           setk(list(cadr u,lowerind cadr mvar ldpf j,
                            lowerind cadr mvar ldpf j),
                mk!*sq lc j)
        else
           setk(list(cadr u,lowerind cadr mvar ldpf j,
                            lowerind cadr mvar lc ldpf j),
                mk!*sq multsq(lc j,1 ./ 2));
     kord!* := okord;
     x := for each j in indxl!* collect
            for each k in indxl!* collect
               simpindexvar list(cadr u,lowerind j,lowerind k);
     y := lnrsolve(x,generateident length indxl!*);
     metricd!* := mkasmetric x;
     metricu!* := mkasmetric y;
     detm!* := mk!*sq detq x
   end;

symbolic procedure mkasmetric u;
   for each j in pair(indxl!*,u) collect
        car j . begin scalar w,z;
                  w := indxl!*;
                  for each k in cdr j do
                    <<if numr k then
                         z := (car w . mk!*sq k) . z;
                         w := cdr w>>;
                  return z
                 end;

symbolic procedure frame u;
   begin scalar y;
     putform(list(car u,nil),-1);
     flag(list car u,'covariant);
     basisvectorl!* :=
         for each j in indxl!* collect !*a2k list(car u,lowerind j);
     if null dbaseform2base2form then return;
     commutator!-of!-framevectors :=
       for each j in pickupwedges dbaseform2base2form collect
         list(cadadr j,cadadr cdr j) . mk!*sqpf mkcommutatorfv(j,
                                                 dbaseform2base2form);
     y := pair(basisvectorl!*,
               naturalvector2framevector);
     naturalvector2framevector := for each j in coord!* collect
                                      j . mk!*sqpf mknat2framv(j,y)
   end;

symbolic procedure pickupwedges u;
   pickupwedges1(u,nil);

Symbolic procedure pickupwedges1(u,v);
   if null u then v
    else if null cdar u then pickupwedges1(cdr u,v)
    else if null v then pickupwedges1((caar u . red cdar u) . cdr u,
                                      ldpf cdar u . nil)
    else if ldpf cdar u memq v
            then pickupwedges1(if red cdar u
                                  then (caar u . red cdar u) . cdr u
                                else cdr u,v)
          else   pickupwedges1(if red cdar u
                                  then (caar u . red cdar u) . cdr u
                                else cdr u,ldpf cdar u . v);

symbolic procedure mkbasevector u;
   !*a2k list(caar basisvectorl!*,lowerind u);

symbolic procedure mkcommutatorfv(u,v);
   if null v then nil
    else addpf(mkcommutatorfv1(u,mkbasevector cadaar v,cdar v),
               mkcommutatorfv(u,cdr v));

symbolic procedure mkcommutatorfv1(u,v,w);
   if null w then nil
    else if u eq  ldpf w
            then v .* negsq simp!* lc w .+ nil
    else if ordop(u,ldpf w) then nil
    else mkcommutatorfv1(u,v,red w);

symbolic procedure mknat2framv(u,v);
   if null v then nil
    else addpf(mknat2framv1(u,caar v,cdar v),mknat2framv(u,cdr v));

symbolic procedure mknat2framv1(u,v,w);
   if null w then nil
    else if u eq cadr ldpf w
            then v .* lc w .+ nil
    else if ordop(u,cadr ldpf w) then nil
    else mknat2framv1(u,v,red w);

symbolic procedure dualframe u;
   rederr "dualframe no longer supported - use frame instead";

symbolic procedure riemannconx u;
   riemconnection car u;

put('riemannconx,'stat,'rlis);

smacro procedure mkbasformsq u;
   mksq(list(caar basisforml!*,u),1);

symbolic procedure riemconnection u;
   %calculates the riemannian connection and stores it in u;
   begin scalar indx1,indx2,indx3,covbaseform,varl,w,x,z,dgkl;
     putform(list(u,nil,nil),1);
     flag(list u,'covariant);
     flag(list u,'antisymmetric);
     for each j in indxl!* do
       for each k in indxl!* do if (j neq k) and indordp(j,k) then
                                 setk(list(u,lowerind j,lowerind k),0);
     for each l in dbaseform2base2form do
       <<covbaseform := partitindexvar list(caar l,
                                            lowerind cadar l);
       for each j on cdr l do
         <<varl := cdr ldpf j;
           indx1 := cadar varl;
           indx2 := cadadr varl;
           for each y on covbaseform do
             <<w := list(u,lowerind indx1,lowerind indx2);
               z := multsq(-1 ./ 2,!*pf2sq multpfsq(lt y .+ nil,
                                                    simp!* lc j));
               setk(w,mk!*sq addsq(z,mksq(w,1)));
               indx3 := cadr ldpf y;
               z := multsq(-1 ./ 2,multsq(lc y,simp!* lc j));
               if indx1 neq indx3 then
                  if indordp(indx1,indx3) then
                     <<w := list(u,lowerind indx1,lowerind indx3);
                       setk(w,mk!*sq addsq(multsq(z,mkbasformsq indx2),
                                           mksq(w,1)))>>
                else
                     <<w := list(u,lowerind indx3,lowerind indx1);
                       setk(w,mk!*sq addsq(multsq(negsq z,
                                      mkbasformsq indx2),mksq(w,1)))>>;
               if indx2 neq indx3 then
                  if indordp(indx2,indx3) then
                     <<w := list(u,lowerind indx2,lowerind indx3);
                       setk(w,mk!*sq addsq(multsq(negsq z,
                                       mkbasformsq indx1),mksq(w,1)))>>
                else
                     <<w := list(u,lowerind indx3,lowerind indx2);
                       setk(w,mk!*sq addsq(multsq(z,
                                       mkbasformsq indx1),mksq(w,1)))>>
      >>>>>>;
      if dgkl := mkmetricconx metricd!* then
       <<for each j in dgkl do
           <<for each y on cdr j do
              <<varl := ldpf y;
                indx1 := cadar varl;
                indx2 := cadadr varl;
                w := list(u,lowerind indx1,lowerind indx2);
                z := multsq(-1 ./ 2,multsq(!*k2q car j,lc y));
                setk(w,mk!*sq addsq(z,mksq(w,1)))>>>>;
         remflag(list u,'antisymmetric);
         for each j in indxl!* do
           for each k in indxl!* do
             if indordp(j,k) then
             <<w := list(u,lowerind j,lowerind k);
               x := if j eq k then nil ./ 1 else mksq(w,1);
               z := atsoc(j,cdr atsoc(k,metricd!*));
               if z then z := exdf0 simp!* cdr z;
               z := multsq(1 ./ 2,!*pf2sq z);
               setk(w,mk!*sq addsq(z,x));
               w := list(u,lowerind k,lowerind j);
               setk(w,mk!*sq addsq(z,negsq x))>>>>
    end;

symbolic procedure mkmetricconx u;
   if null u then nil
    else (if x then (ldpf mkupf list(caar basisforml!*,caar u) . x)
                     . mkmetricconx cdr u
           else mkmetricconx cdr u)
          where x = mkmetricconx1 cdar u;

symbolic procedure mkmetricconx1 u;
   if null u then nil
    else addpf(wedgepf2(exdf0 simp!* cdar u,
               !*k2pf list ldpf mkupf list(caar basisforml!*,caar u)),
               mkmetricconx1 cdr u);

symbolic procedure basep u;
   if domainp u then nil
    else or(if sfp mvar u then basep mvar u
             else eqcar(mvar u,caar basisforml!*),
            basep lc u,basep red u);


symbolic procedure wedgefp u;
   if domainp u then nil
    else or(if sfp mvar u then wedgefp mvar u
             else eqcar(mvar u,'wedge),
            wedgefp lc u,wedgefp red u);

endmodule;

%**********************************************************************;
%**********             Auxiliary functions                ************;
%**********************************************************************;

module aux;

% Author: Eberhard Schruefer;

symbolic procedure boundindp(u,v);
   if null u then t else member(car u,v) and boundindp(cdr u,v);

symbolic procedure memblp(u,v);
   if null u then nil
    else if atom u then member(u,v)
    else memblp(car u,v) or memblp(cdr u,v);

symbolic procedure displayframe;
   begin scalar x,coords;
     terpri!* t;
     coords := coord!*;
     coord!* := nil;
     for each j in basisforml!* do
       <<x := assoc(j,keepl!*);
         maprin car x;
         prin2!* " = ";
         maprin reval cdr x;
         terpri!* t>>;
%was     varpri(reval cdr x,list mkquote car x,t)>>;
     if !*nat then terpri!* t;
     coord!* := coords
   end;

put('displayframe,'stat,'endstat);

%symbolic procedure form!*coeff u;
%begin scalar x,inds; %integer n;
 %inds:=cdr u;
 %n:=length inds;
 %x:=simp!* car u;
 %y:=dstrsdf numr x;


 %put('fcoeff,'simpfn,'form!*coeff);


endmodule;

%*********************************************************************;
%                Lie-Algebra valued forms                             ;
%*********************************************************************;

module lievalform;

% Author: Eberhard Schruefer

symbolic procedure liebrackstat;
   begin scalar x;
     x := xread nil;
     scan();
     return 'lie . cdr x
   end;

flag(list '!},'delim); %Since Liebrackets can be nested we can't
                       %remove the flag in the stat proc;

put('!{,'stat,'liebrackstat); %We'd rather liked to use squarebrackets;
                       %but they are not available on most terminals;


put('lie,'prifn,'lieprn);

symbolic procedure lieprn u;
   <<prin2!* "{";
     inprint('!*comma!*,0,u);
     prin2!* "}">>;

endmodule;

%********************************************************************;
%****                    Exterior Ideals                        *****;
%********************************************************************;


module idexf;

% Author: Eberhard Schruefer

global '(exfideal!*);

symbolic procedure exterior!-ideal u;
   begin scalar x,y;
     rmsubs();
     for each j in u do
       if indexvp j then
          for each k in mkaindxc(y := flatindxl cdr j) do
             x := partitsq(simpindexvar(car j . subla(pair(y,k),cdr j)),
                           'wedgefp) . x
        else x := partitsq(simp!* j,'wedgefp) . x;
     exfideal!* := append(x,exfideal!*);
   end;

rlistat '(exterior!-ideal);

symbolic procedure remexf(u,v);
   begin scalar lu,lv,x,y,z;
     lv := ldpf v;
     a: if null u or domainp(lu := ldpf u) then
           return u;
        if x := divexf(lu,lv) then
         <<y := partitsq(simp list('wedge,prepf v,x),'wedgefp);
           z := negsq quotsq(lc u,lc y);
           u := addpsf(u,multpsf(1 .* z .+ nil,y))>>
         else return u;
        go to a
   end;

symbolic procedure divexf(u,v);
   begin scalar x,y;
     x := prepf u;
     y := prepf v;
     if atom x then x := list x
      else if car x eq 'wedge then x := cdr x;
     if atom y then y := list y
      else if car y eq 'wedge then y := cdr y;
     a: if null y then return 'wedge . x;
        if null(x := delform(car y,x)) then return nil;
        y := cdr y;
        go to a
   end;

symbolic procedure delform(u,v);
   delform1(u,v,nil);

symbolic procedure delform1(u,v,w);
   if null v then nil
    else if u = car v then if w or cdr v
                              then append(reverse w,cdr v)
                            else list 1
    else delform1(u,cdr v,car v . w);

symbolic procedure exf!-mod!-ideal u;
   begin
     for each j in exfideal!* do u := remexf(u,j);
     return u
   end;

endmodule;

%*********************************************************************;
%               3-d Vectoranalysis Interface                          ;
%*********************************************************************;

module vectoranalys;

%author: Eberhard Schruefer;

symbolic procedure basis u;
   cofram(for each j in u collect cdr j,nil);

rlistat '(basis);

symbolic procedure simpgrad u;
   simp!*('d . u);

put('grad,'simpfn,'simpgrad);

symbolic procedure simpcurl u;
   simp!* list('hodge,'d . u);

put('curl,'simpfn,'simpcurl);

symbolic procedure simpdiv u;
   simp!* list('hodge,list('d,'hodge . u));

put('div,'simpfn,'simpdiv);

newtok '((!. !* !.) crossprod);
infix crossprod;

symbolic procedure simpcrossprod u;
   simp!* list('hodge,'wedge . u);

put('crossprod,'simpfn,'simpcrossprod);

symbolic procedure simpdotprod u;
   simp!* list('hodge,list('wedge,car u,list('hodge,cadr u)));

put('cons,'simpfn,'simpdotprod);

symbolic procedure hodge3dpri u;
   %converts the form notation to vector notation for output;
   if caar u eq 'd then
        if eqcar(cadar u,'hodge) then maprin('div . cdadar u)
         else maprin('curl . cdar u)
    else if caar u eq 'wedge then
              if eqcar(cadar u,'hodge) then
                     inprint('cons,0,cdadar u)
               else inprint('crossprod,0,cdar u);

endmodule;

end;

Added r33/ezgcd.red version [16eb2cc935].









































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
module fac!-intro;  % Support for factorizer.

% Authors: A. C. Norman and P. M. A. Moore, 1981.

fluid '(!*timings !*trallfac !*trfac factor!-level factor!-trace!-list);

global '(!*ifactor posn!* spare!*);

switch ifactor,overview,timings,trallfac,trfac;

factor!-level:=0;  % start with a numeric value;

comment This factorizer should be used with a system dependent file
containing a setting of the variable LARGEST!-SMALL!-MODULUS. If at all
possible the integer arithmetic operations used here should be mapped
onto corresponding ones available in the underlying Lisp implementation,
and the support for modular arithmetic (perhaps based on these integer
arithmetic operations) should be reviewed.  This file provides
placeholder definitions of functions that are used on some
implementations to support block compilation, car/cdr access checks and
the like.  The front-end files on the systems that can use these
features will disable the definitions given here by use of a 'LOSE flag;

deflist('((minus!-one -1)),'newnam);   %so that it EVALs properly;

symbolic smacro procedure carcheck u; nil;

symbolic procedure errorf u;
   rederr list("Factorizer error:",u);

symbolic smacro procedure factor!-trace action;
begin scalar stream;
  if !*trallfac or (!*trfac and factor!-level = 1) then
    stream := nil . nil
  else
    stream := assoc(factor!-level,factor!-trace!-list);
  if stream then <<
    stream:=wrs cdr stream;
    action;
    wrs stream >>
 end;
 
symbolic smacro procedure irecip u; 1/u;

symbolic smacro procedure isdomain u; domainp u;

symbolic smacro procedure readgctime; gctime();

symbolic smacro procedure readtime; time()-gctime();

symbolic smacro procedure ttab n; spaces(n-posn());


%   ***** The remainder of this module used to be in FLUIDS.

% Macro definitions for functions that create and access reduce-type
% datastructures.

smacro procedure tvar a; caar a;

smacro procedure polyzerop u; null u;

smacro procedure didntgo q; null q;

smacro procedure depends!-on!-var(a,v);
  (lambda !#!#a; (not domainp !#!#a) and (mvar !#!#a=v)) a;

smacro procedure l!-numeric!-c(a,vlist); lnc a;

% Macro definitions for use in berlekamps algorithm.

% SMACROs used in linear equation package.

smacro procedure getm2(a,i,j);
% Store by rows, to ease pivoting process.
    getv(getv(a,i),j);

smacro procedure putm2(a,i,j,v);
    putv(getv(a,i),j,v);

%%%smacro procedure !*d2n a;
%%%% converts domain elt into number.
%%%  (lambda !#a!#;
%%%    if null !#a!# then 0 else !#a!#) a;

symbolic procedure !*d2n a; if null a then 0 else a;

smacro procedure !*num2f n;
% converts number to s.f.
  (lambda !#n!#; if !#n!#=0 then nil else !#n!#) n;

smacro procedure !*mod2f u; u;

smacro procedure !*f2mod u; u;

smacro procedure comes!-before(p1,p2);
% Similar to the REDUCE function ORDPP, but does not cater for
% non-commutative terms and assumes that exponents are small integers.
    (car p1=car p2 and igreaterp(cdr p1,cdr p2)) or
       (not car p1=car p2 and ordop(car p1,car p2));

%%%smacro procedure adjoin!-term (p,c,r);
%%%  (lambda !#c!#; % Lambda binding prevents repeated evaluation of C.
%%%    if null !#c!# then r else (p .* !#c!#) .+ r) c;

symbolic procedure adjoin!-term (p,c,r);
   if null c then r else (p .* c) .+ r;

% A load of access smacros for image sets follow:

smacro procedure get!-image!-set s; car s;

smacro procedure get!-chosen!-prime s; cadr s;

smacro procedure get!-image!-lc s; caddr s;

smacro procedure get!-image!-mod!-p s; cadr cddr s;

smacro procedure get!-image!-content s; cadr cdr cddr s;

smacro procedure get!-image!-poly s; cadr cddr cddr s;

smacro procedure get!-f!-numvec s; cadr cddr cdddr s;

smacro procedure put!-image!-poly!-and!-content(s,imcont,impol);
  list(get!-image!-set s,
       get!-chosen!-prime s,
       get!-image!-lc s,
       get!-image!-mod!-p s,
       imcont,
       impol,
       get!-f!-numvec s);

% !*timings:=nil; % Default not to displaying timings.

% !*overshoot:=nil; % Default not to show overshoot occurring.

% reconstructing!-gcd:=nil;  % This is primarily a factorizer!

symbolic procedure ttab!* n;
<<if n>(linelength nil - spare!*) then n:=0;
  if posn!* > n then terpri!*(nil);
  while not(posn!*=n) do prin2!* '!  >>;

smacro procedure printstr l; << prin2!* l; terpri!*(nil) >>;

smacro procedure printvar v; printstr v;

smacro procedure prinvar v; prin2!* v;

symbolic procedure printvec(str1,n,str2,v);
<< for i:=1:n do <<
    prin2!* str1;
    prin2!* i;
    prin2!* str2;
    printsf getv(v,i) >>;
   terpri!*(nil) >>;

smacro procedure display!-time(str,mt);
% Displays the string str followed by time mt (millisecs).
  << prin2 str; prin2 mt; printc " millisecs." >>;

% trace control package.

smacro procedure trace!-time action; if !*timings then action;

smacro procedure new!-level(n,c); (lambda factor!-level; c) n;

symbolic procedure set!-trace!-factor(n,file);
    factor!-trace!-list:=(n . (if file=nil then nil
                               else open(mkfil file,'output))) .
                                                factor!-trace!-list;

symbolic procedure clear!-trace!-factor n;
  begin
    scalar w;
    w := assoc(n,factor!-trace!-list);
    if w then <<
       if cdr w then close cdr w;
       factor!-trace!-list:=delasc(n,factor!-trace!-list) >>;
    return nil
  end; 

symbolic procedure close!-trace!-files();
 << while factor!-trace!-list
       do clear!-trace!-factor(caar factor!-trace!-list);
    nil >>;

endmodule;


module alphas;

% Authors: A. C. Norman and P. M. A. Moore, 1981;

fluid '(alphalist current!-modulus hensel!-growth!-size
        number!-of!-factors);


%********************************************************************;
%
% this section contains access and update functions for the alphas;


symbolic procedure get!-alpha poly;
% gets the poly and its associated alpha from the current alphalist
% if poly is not on the alphalist then we force an error;
  begin scalar w;
    w:=assoc!-alpha(poly,alphalist);
    if null w then errorf list("Alpha not found for ",poly," in ",
        alphalist);
    return w
  end;

symbolic procedure divide!-all!-alphas n;
% multiply the factors by n mod p and alter the alphas accordingly;
  begin scalar om,m;
    om:=set!-modulus hensel!-growth!-size;
    m:=modular!-expt(
          modular!-reciprocal modular!-number n,
          number!-of!-factors #- 1);
    alphalist:=for each a in alphalist collect
      (times!-mod!-p(n,car a) . times!-mod!-p(m,cdr a));
    set!-modulus om
  end;

symbolic procedure multiply!-alphas(n,oldpoly,newpoly);
% multiply all the alphas except the one associated with oldpoly
% by n mod p. also replace oldpoly by newpoly in the alphalist;
  begin scalar om,faca;
    om:=set!-modulus hensel!-growth!-size;
    n:=modular!-number n;
    oldpoly:=reduce!-mod!-p oldpoly;
    faca:=get!-alpha oldpoly;
    alphalist:=delete(faca,alphalist);
    alphalist:=for each a in alphalist collect
      car a . times!-mod!-p(cdr a,n);
    alphalist:=(reduce!-mod!-p newpoly . cdr faca) . alphalist;
    set!-modulus om
  end;

symbolic procedure multiply!-alphas!-recip(n,oldpoly,newpoly);
% multiply all the alphas except the one associated with oldpoly
% by the reciprocal mod p of n. also replace oldpoly by newpoly;
  begin scalar om,w;
    om:=set!-modulus hensel!-growth!-size;
    n:=modular!-reciprocal modular!-number n;
    w:=multiply!-alphas(n,oldpoly,newpoly);
    set!-modulus om;
    return w
  end;

endmodule;


module coeffts;

% Authors: A. C. Norman and P. M. A. Moore, 1981;

fluid '(!*timings
        !*trfac
        alphalist
        best!-known!-factor!-list
        best!-known!-factors
        coefft!-vectors
        deg!-of!-unknown
        difference!-for!-unknown
        divisor!-for!-unknown
        factor!-level
        factor!-trace!-list
        full!-gcd
        hensel!-growth!-size
        image!-factors
        m!-image!-variable
        multivariate!-factors
        multivariate!-input!-poly
        non!-monic
        number!-of!-factors
        polyzero
        reconstructing!-gcd
        true!-leading!-coeffts
        unknown
        unknowns!-list);


%**********************************************************************;
%  code for trying to determine more multivariate coefficients
%  by inspection before using multivariate hensel construction.  ;


symbolic procedure determine!-more!-coeffts();
% ...;
  begin scalar unknowns!-list,uv,r,w,best!-known!-factor!-list;
    best!-known!-factors:=mkvect number!-of!-factors;
    uv:=mkvect number!-of!-factors;
    for i:=number!-of!-factors step -1 until 1 do
      putv(uv,i,convert!-factor!-to!-termvector(
        getv(image!-factors,i),getv(true!-leading!-coeffts,i)));
    r:=red multivariate!-input!-poly;
            % we know all about the leading coeffts;
    if not depends!-on!-var(r,m!-image!-variable)
      or null(w:=try!-first!-coefft(
              ldeg r,lc r,unknowns!-list,uv)) then <<
      for i:=1:number!-of!-factors do
        putv(best!-known!-factors,i,force!-lc(
          getv(image!-factors,i),getv(true!-leading!-coeffts,i)));
      coefft!-vectors:=uv;
      return nil >>;
    factor!-trace <<
      printstr
         "By exploiting any sparsity wrt the main variable in the";
      printstr "factors, we can try guessing some of the multivariate";
      printstr "coefficients." >>;
    try!-other!-coeffts(r,unknowns!-list,uv);
    w:=convert!-and!-trial!-divide uv;
    trace!-time
      if full!-gcd then printc "Possible gcd found"
      else printc "Have found some coefficients";
    return set!-up!-globals(uv,w)
  end;

symbolic procedure convert!-factor!-to!-termvector(u,tlc);
% ...;
  begin scalar termlist,res,n,slist;
    termlist:=(ldeg u . tlc) . list!-terms!-in!-factor red u;
    res:=mkvect (n:=length termlist);
    for i:=1:n do <<
      slist:=(caar termlist . i) . slist;
      putv(res,i,car termlist);
      termlist:=cdr termlist >>;
    putv(res,0,(n . (n #- 1)));
    unknowns!-list:=(reversewoc slist) . unknowns!-list;
    return res
  end;

symbolic procedure try!-first!-coefft(n,c,slist,uv);
% ...;
  begin scalar combns,unknown,w,l,d,v,m;
    combns:=get!-term(n,slist);
    if (combns='no) or not null cdr combns then return nil;
    l:=car combns;
    for i:=1:number!-of!-factors do <<
      w:=getv(getv(uv,i),car l);    % degree . coefft ;
      if null cdr w then <<
         if unknown then <<c := nil; i := number!-of!-factors + 1>>
          else <<unknown := i . car l; d := car w>>>>
      else <<
        c:=quotf(c,cdr w);
        if didntgo c then i := number!-of!-factors+1>>;
      l:=cdr l >>;
    if didntgo c then return nil;
    putv(v:=getv(uv,car unknown),cdr unknown,(d . c));
    m:=getv(v,0);
    putv(v,0,(car m . (cdr m #- 1)));
    if cdr m = 1 and factors!-complete uv then return 'complete;
    return c
  end;

symbolic procedure solve!-next!-coefft(n,c,slist,uv);
% ...;
  begin scalar combns,w,unknown,deg!-of!-unknown,divisor!-for!-unknown,
    difference!-for!-unknown,v;
    difference!-for!-unknown:=polyzero;
    divisor!-for!-unknown:=polyzero;
    combns:=get!-term(n,slist);
    if combns='no then return 'nogood;
    while combns do <<
      w:=split!-term!-list(car combns,uv);
      if w='nogood then combns := nil else combns:=cdr combns >>;
    if w='nogood then return w;
    if null unknown then return;
    w:=quotf(addf(c,negf difference!-for!-unknown),
             divisor!-for!-unknown);
    if didntgo w then return 'nogood;
    putv(v:=getv(uv,car unknown),cdr unknown,(deg!-of!-unknown . w));
    n:=getv(v,0);
    putv(v,0,(car n . (cdr n #- 1)));
    if cdr n = 1 and factors!-complete uv then return 'complete;
    return w
  end;

symbolic procedure split!-term!-list(term!-combn,uv);
% ...;
  begin scalar a,v,w;
    a:=1;
    for i:=1:number!-of!-factors do <<
      w:=getv(getv(uv,i),car term!-combn);  % degree . coefft ;
      if null cdr w then
        if v or (unknown and not((i.car term!-combn)=unknown)) then
          <<v:='nogood; i := number!-of!-factors+1>>
        else <<
          unknown:=(i . car term!-combn);
          deg!-of!-unknown:=car w;
          v:=unknown >>
      else a:=multf(a,cdr w);
      if not(v eq 'nogood) then term!-combn:=cdr term!-combn >>;
    if v='nogood then return v;
    if v then divisor!-for!-unknown:=addf(divisor!-for!-unknown,a)
    else difference!-for!-unknown:=addf(difference!-for!-unknown,a);
    return 'ok
  end;

symbolic procedure factors!-complete uv;
% ...;
  begin scalar factor!-not!-done,r;
    r:=t;
    for i:=1:number!-of!-factors do
      if not(cdr getv(getv(uv,i),0)=0) then
        if factor!-not!-done then <<r:=nil; i:=number!-of!-factors+1>>
        else factor!-not!-done:=t;
    return r
  end;

symbolic procedure convert!-and!-trial!-divide uv;
% ...;
  begin scalar w,r,fdone!-product!-mod!-p,om;
    om:=set!-modulus hensel!-growth!-size;
    fdone!-product!-mod!-p:=1;
    for i:=1:number!-of!-factors do <<
      w:=getv(uv,i);
      w:= if (cdr getv(w,0))=0 then termvector2sf w
        else merge!-terms(getv(image!-factors,i),w);
      r:=quotf(multivariate!-input!-poly,w);
      if didntgo r then best!-known!-factor!-list:=
        ((i . w) . best!-known!-factor!-list)
      else if reconstructing!-gcd and i=1
       then <<full!-gcd:=if non!-monic then car primitive!.parts(
          list w,m!-image!-variable,nil) else w;
          i := number!-of!-factors+1>>
      else <<
        multivariate!-factors:=w . multivariate!-factors;
        fdone!-product!-mod!-p:=times!-mod!-p(
          reduce!-mod!-p getv(image!-factors,i),
          fdone!-product!-mod!-p);
        multivariate!-input!-poly:=r >> >>;
    if full!-gcd then return;
    if null best!-known!-factor!-list then multivariate!-factors:=
      primitive!.parts(multivariate!-factors,m!-image!-variable,nil)
    else if null cdr best!-known!-factor!-list then <<
      if reconstructing!-gcd then
        if not(caar best!-known!-factor!-list=1) then
          errorf("gcd is jiggered in determining other coeffts")
        else full!-gcd:=if non!-monic then car primitive!.parts(
          list multivariate!-input!-poly,
          m!-image!-variable,nil)
          else multivariate!-input!-poly
      else multivariate!-factors:=primitive!.parts(
        multivariate!-input!-poly . multivariate!-factors,
        m!-image!-variable,nil);
      best!-known!-factor!-list:=nil >>;
    factor!-trace <<
      if null best!-known!-factor!-list then
        printstr
           "We have completely determined all the factors this way"
      else if multivariate!-factors then <<
        prin2!* "We have completely determined the following factor";
        printstr if (length multivariate!-factors)=1 then ":" else "s:";
        for each ww in multivariate!-factors do printsf ww >> >>;
    set!-modulus om;
    return fdone!-product!-mod!-p
  end;

symbolic procedure set!-up!-globals(uv,f!-product);
  if null best!-known!-factor!-list or full!-gcd then 'done
  else begin scalar i,r,n,k,flist!-mod!-p,imf,om,savek;
    n:=length best!-known!-factor!-list;
    best!-known!-factors:=mkvect n;
    coefft!-vectors:=mkvect n;
    r:=mkvect n;
    k:=if reconstructing!-gcd then 1 else 0;
    om:=set!-modulus hensel!-growth!-size;
    for each w in best!-known!-factor!-list do <<
      i:=car w; w:=cdr w;
      if reconstructing!-gcd and i=1 then << savek:=k; k:=1 >>
      else k:=k #+ 1;
            % in case we are reconstructing gcd we had better know
            % which is the gcd and which the cofactor - so don't move
            % move the gcd from elt one;
      putv(r,k,imf:=getv(image!-factors,i));
      flist!-mod!-p:=(reduce!-mod!-p imf) . flist!-mod!-p;
      putv(best!-known!-factors,k,w);
      putv(coefft!-vectors,k,getv(uv,i));
      if reconstructing!-gcd and k=1 then k:=savek;
            % restore k if necessary;
      >>;
    if not(n=number!-of!-factors) then <<
      alphalist:=for each modf in flist!-mod!-p collect
        (modf . remainder!-mod!-p(times!-mod!-p(f!-product,
          cdr get!-alpha modf),modf));
      number!-of!-factors:=n >>;
    set!-modulus om;
    image!-factors:=r;
    return 'need! to! reconstruct
  end;

symbolic procedure get!-term(n,l);
% ...;
  if n#<0 then 'no
  else if null cdr l then get!-term!-n(n,car l)
  else begin scalar w,res;
    for each fterm in car l do <<
      w:=get!-term(n#-car fterm,cdr l);
      if not(w='no) then res:=
        append(for each v in w collect (cdr fterm . v),res) >>;
    return if null res then 'no else res
  end;

symbolic procedure get!-term!-n(n,u);
  if null u or n #> caar u then 'no
  else if caar u = n then list(cdar u . nil)
  else get!-term!-n(n,cdr u);



endmodule;


module ezgcdf; % Polynomial GCD algorithms.

% Author: A. C. Norman, 1981;

fluid '(!*exp
        !*gcd
        !*heugcd
        !*overview
        !*timings
        !*trfac
        alphalist
        bad!-case
        best!-known!-factors
        current!-modulus
        dmode!*
        factor!-level
        factor!-trace!-list
        full!-gcd
        hensel!-growth!-size
        image!-factors
        image!-set
        irreducible
        kord!*
        m!-image!-variable
        multivariate!-factors
        multivariate!-input!-poly
        non!-monic
        no!-of!-primes!-to!-try
        number!-of!-factors
        prime!-base
        reconstructing!-gcd
        reduced!-degree!-lclst
        reduction!-count
        target!-factor!-count
        true!-leading!-coeffts
        unlucky!-case);

symbolic procedure ezgcdf(u,v);
   %entry point for REDUCE call in GCDF;
   begin scalar factor!-level;
      factor!-level := 0;
      return poly!-abs gcdlist list(u,v)
   end;
 
%symbolic procedure simpezgcd u;
% calculate the gcd of the polynomials given as arguments;
%  begin
%    scalar factor!-level,w;
%    factor!-level:=0;
%    u := for each p in u collect <<
%        w := simp!* p;
%        if (denr w neq 1) then
%           rederr "EZGCD requires polynomial arguments";
%        numr w >>;
%    return (poly!-abs gcdlist u) ./ 1
%  end;

%put('ezgcd,'simpfn,'simpezgcd);

symbolic procedure simpnprimitive p;
% Remove any simple numeric factors from the expression P;
  begin
    scalar np,dp;
    if atom p or not atom cdr p then
       rederr "NPRIMITIVE requires just one argument";
    p := simp!* car p;
    if polyzerop(numr p) then return nil ./ 1;
    np := quotfail(numr p,numeric!-content numr p);
    dp := quotfail(denr p,numeric!-content denr p);
    return (np ./ dp)
  end;
 
put('nprimitive,'simpfn,'simpnprimitive);
 
 
symbolic procedure poly!-gcd(u,v);
   %U and V are standard forms.
   %Value is the gcd of U and V;
   begin scalar xexp,z;
        if polyzerop u then return poly!-abs v
         else if polyzerop v then return poly!-abs u
         else if u=1 or v=1 then return 1;
        xexp := !*exp;
        !*exp := t;
        % The case of one argument exactly dividing the other is
        % detected specially here because it is perhaps a fairly
        % common circumstance;
        if quotf1(u,v) then z := v
        else if quotf1(v,u) then z := u
        else if !*gcd then  z := gcdlist list(u,v)
        else z := 1;
        !*exp := xexp;
        return poly!-abs z
   end;
 
% moved('gcdf,'poly!-gcd);
 
 
 
symbolic procedure ezgcd!-comfac p;
  %P is a standard form
  %CAR of result is lowest common power of leading kernel in
  %every term in P (or NIL). CDR is gcd of all coefficients of
  %powers of leading kernel;
  if domainp p then nil . poly!-abs p
  else if null red p then lpow p . poly!-abs lc p
  else begin
    scalar power,coeflist,var;
    % POWER will be the first part of the answer returned,
    % COEFLIST will collect a list of all coefs in the polynomial
    % P viewed as a poly in its main variable,
    % VAR is the main variable concerned;
    var := mvar p;
    while mvar p=var and not domainp red p do <<
      coeflist := lc p . coeflist;
      p:=red p >>;
    if mvar p=var then <<
      coeflist := lc p . coeflist;
      if null red p then power := lpow p
      else coeflist := red p . coeflist >>
    else coeflist := p . coeflist;
    return power . gcdlist coeflist
  end;
 
symbolic procedure gcd!-with!-number(n,a);
% n is a number, a is a polynomial - return their gcd, given that
% n is non-zero;
    if n=1 or not atom n or flagp(dmode!*,'field) then 1
    else if domainp a
     then if a=nil then abs n
           else if not atom a then 1
           else gcddd(n,a)
    else gcd!-with!-number(gcd!-with!-number(n,lc a),red a);

% moved('gcdfd,'gcd!-with!-number);
 
 
symbolic procedure contents!-with!-respect!-to(p,v);
    if domainp p then nil . poly!-abs p
    else if mvar p=v then ezgcd!-comfac p
    else begin
      scalar y,w;
      y := setkorder list v;
      p := reorder p;
      w := ezgcd!-comfac p;
      setkorder y;
      p := reorder p;
      return reorder w
    end;
 
symbolic procedure numeric!-content form;
% Find numeric content of non-zero polynomial;
   if domainp form then abs form
   else if null red form then numeric!-content lc form
   else begin
     scalar g1;
     g1 := numeric!-content lc form;
     if not (g1=1) then g1 := gcddd(g1,numeric!-content red form);
     return g1
   end;
 
symbolic procedure gcdlist l;
% Return the GCD of all the polynomials in the list L.
%
% First find all variables mentioned in the polynomials in L,
% and remove monomial content from them all. If in the process
% a constant poly is found, take special action. If then there
% is some variable that is mentioned in all the polys in L, and
% which occurs only linearly in one of them establish that as
% main variable and proceed to GCDLIST3 (which will take
% a special case exit). Otherwise, if there are any variables that
% do not occur in all the polys in L they can not occur in the GCD,
% so take coefficients with respect to them to get a longer list of
% smaller polynomials - restart. Finally we have a set of polys
% all involving exactly the same set of variables;
  if null l then nil
  else if null cdr l then poly!-abs car l
  else if domainp car l then gcdld(cdr l,car l)
  else begin
    scalar l1,gcont,x;
    % Copy L to L1, but on the way detect any domain elements
    % and deal with them specially;
    while not null l do <<
        if null car l then l := cdr l
        else if domainp car l then <<
          l1 := list list gcdld(cdr l,gcdld(mapcarcar l1,car l));
          l := nil >>
        else <<
          l1 := (car l . powers1 car l) . l1;
          l := cdr l >> >>;
    if null l1 then return nil
    else if null cdr l1 then return poly!-abs caar l1;
    % Now L1 is a list where each polynomial is paired with information
    % about the powers of variables in it;
    gcont := nil; % Compute monomial content on things in L;
    x := nil; % First time round flag;
    l := for each p in l1 collect begin
        scalar gcont1,gcont2,w;
        % Set GCONT1 to least power information, and W to power
        % difference;
        w := for each y in cdr p
                collect << gcont1 := (car y . cddr y) . gcont1;
                           car y . (cadr y-cddr y) >>;
        % Now get the monomial content as a standard form (in GCONT2);
        gcont2 := numeric!-content car p;
        if null x then << gcont := gcont1; x := gcont2 >>
        else << gcont := vintersection(gcont,gcont1);
                   % Accumulate monomial gcd;
                x := gcddd(x,gcont2) >>;
        for each q in gcont1 do if not cdr q=0 then
            gcont2 := multf(gcont2,!*p2f mksp(car q,cdr q));
        return quotfail1(car p,gcont2,"Term content division failed")
                  . w
        end;
    % Here X is the numeric part of the final GCD;
    for each q in gcont do x := multf(x,!*p2f mksp(car q,cdr q));
    trace!-time <<
      prin2!* "Term gcd = ";
      printsf x >>;
    return poly!-abs multf(x,gcdlist1 l)
  end;
 
 
symbolic procedure gcdlist1 l;
% Items in L are monomial-primitive, and paired with power information.
% Find out what variables are common to all polynomials in L and
% remove all others;
  begin
    scalar unionv,intersectionv,vord,x,l1,reduction!-count;
    unionv := intersectionv := cdar l;
    for each p in cdr l do <<
       unionv := vunion(unionv,cdr p);
       intersectionv := vintersection(intersectionv,cdr p) >>;
    if null intersectionv then return 1;
    for each v in intersectionv do
       unionv := vdelete(v,unionv);
    % Now UNIONV is list of those variables mentioned that
    % are not common to all polynomials;
    intersectionv := sort(intersectionv,function lesspcdr);
    if cdar intersectionv=1 then <<
       % I have found something that is linear in one of its variables;
       vord := mapcarcar append(intersectionv,unionv);
       l1 := setkorder vord;
       trace!-time <<
         prin2 "Selecting "; prin2 caar intersectionv;
         printc " as main because some poly is linear in it" >>;
       x := gcdlist3(for each p in l collect reorder car p,nil,vord);
       setkorder l1;
       return reorder x >>
    else if null unionv then return gcdlist2(l,intersectionv);
    trace!-time <<
      prin2 "The variables "; prin2 unionv; printc " can be removed" >>;
    vord := setkorder mapcarcar append(unionv,intersectionv);
    l1 := nil;
    for each p in l do
        l1:=split!-wrt!-variables(reorder car p,mapcarcar unionv,l1);
    setkorder vord;
    return gcdlist1(for each p in l1 collect
      (reorder p . total!-degree!-in!-powers(p,nil)))
  end;
 
 
symbolic procedure gcdlist2(l,vars);
% Here all the variables in VARS are used in every polynomial
% in L. Select a good variable ordering;
  begin
    scalar x,x1,gg,lmodp,onestep,vord,oldmod,image!-set,gcdpow,
           unlucky!-case;
% In the univariate case I do not need to think very hard about
% the selection of a main variable!! ;
    if null cdr vars
      then return
         if !*heugcd then
            if (x:=heu!-gcd!-list(mapcarcar l))
            then x
            else gcdlist3(mapcarcar l,nil,list caar vars)
         else gcdlist3(mapcarcar l,nil,list caar vars);
    oldmod := set!-modulus nil;
% If some variable appears at most to degree two in some pair of the
% polynomials then that will do as a main variable.  Note that this is
% not so useful if the two polynomials happen to be duplicates of each
% other, but still... ;

    vars := mapcarcar sort(vars,function greaterpcdr);
% Vars is now arranged with the variable that appears to highest
% degree anywhere in L first, and the rest in descending order;
    l := for each p in l collect car p .
      sort(cdr p,function lesspcdr);
    l := sort(l,function lesspcdadr);
% Each list of degree information in L is sorted with lowest degree
% vars first, and the polynomial with the lowest degree variable
% of all will come first;
    x := intersection(deg2vars(cdar l),deg2vars(cdadr l));
    if not null x then <<
       trace!-time << prin2 "Two inputs are at worst quadratic in ";
                      printc car x >>;
      go to x!-to!-top >>;   % Here I have found two polys with a common
                             % variable that they are quadratic in;
% Now generate modular images of the gcd to guess its degree wrt
% all possible variables;
 
% If either (a) modular gcd=1 or (b) modular gcd can be computed with
% just 1 reduction step, use that information to choose a main variable;
try!-again:  % Modular images may be degenerate;
    set!-modulus random!-prime();
    unlucky!-case := nil;
    image!-set := for each v in vars
                   collect (v . modular!-number next!-random!-number());
    trace!-time <<
      prin2 "Select variable ordering using P=";
      prin2 current!-modulus;
      prin2 " and substitutions from ";
      printc image!-set >>;
    x1 := vars;
try!-vars:
    if null x1 then go to images!-tried;
    lmodp := for each p in l collect make!-image!-mod!-p(car p,car x1);
    if unlucky!-case then go to try!-again;
    lmodp := sort(lmodp,function lesspdeg);
    gg := gcdlist!-mod!-p(car lmodp,cdr lmodp);
    if domainp gg or (reduction!-count<2 and (onestep:=t)) then <<
           trace!-time << prin2 "Select "; printc car x1 >>;
           x := list car x1; go to x!-to!-top >>;
    gcdpow := (car x1 . ldeg gg) . gcdpow;
    x1 := cdr x1;
    go to try!-vars;
images!-tried:
  % In default of anything better to do, use image variable such that
  % degree of gcd wrt it is as large as possible;
    vord := mapcarcar sort(gcdpow,function greaterpcdr);
    trace!-time << prin2 "Select order by degrees: ";
                   printc gcdpow >>;
    go to order!-chosen;
 
x!-to!-top:
    for each v in x do vars := delete(v,vars);
    vord := append(x,vars);
order!-chosen:
    trace!-time << prin2 "Selected Var order = "; printc vord >>;
    set!-modulus oldmod;
    vars := setkorder vord;
    x := gcdlist3(for each p in l collect reorder car p,onestep,vord);
    setkorder vars;
    return reorder x
  end;
 
symbolic procedure gcdlist!-mod!-p(gg,l);
   if null l then gg
   else if gg=1 then 1
   else gcdlist!-mod!-p(gcd!-mod!-p(gg,car l),cdr l);
 
symbolic procedure deg2vars l;
    if null l then nil
    else if cdar l>2 then nil
    else caar l . deg2vars cdr l;
 
symbolic procedure vdelete(a,b);
    if null b then nil
    else if car a=caar b then cdr b
    else car b . vdelete(a,cdr b);
 
symbolic procedure intersection(u,v);
    if null u then nil
    else if member(car u,v) then car u . intersection(cdr u,v)
    else intersection(cdr u,v);
 
 
symbolic procedure vintersection(a,b);
  begin
    scalar c;
    return if null a then nil
    else if null (c:=assoc(caar a,b)) then vintersection(cdr a,b)
    else if cdar a>cdr c then
      if cdr c=0 then vintersection(cdr a,b)
      else c . vintersection(cdr a,b)
    else if cdar a=0 then vintersection(cdr a,b)
    else car a . vintersection(cdr a,b)
  end;
 
 
symbolic procedure vunion(a,b);
  begin
    scalar c;
    return if null a then b
    else if null (c:=assoc(caar a,b)) then car a . vunion(cdr a,b)
    else if cdar a>cdr c then car a . vunion(cdr a,delete(c,b))
    else c . vunion(cdr a,delete(c,b))
  end;
 
 
symbolic procedure mapcarcar l;
    for each x in l collect car x;
 
 
symbolic procedure gcdld(l,n);
% GCD of the domain element N and all the polys in L;
    if n=1 or n=-1 then 1
    else if l=nil then abs n
    else if car l=nil then gcdld(cdr l,n)
    else gcdld(cdr l,gcd!-with!-number(n,car l));
 
symbolic procedure split!-wrt!-variables(p,vl,l);
% Push all the coeffs in P wrt variables in VL onto the list L
% Stop if 1 is found as a coeff;
    if p=nil then l
    else if not null l and car l=1 then l
    else if domainp p then abs p . l
    else if member(mvar p,vl) then
        split!-wrt!-variables(red p,vl,split!-wrt!-variables(lc p,vl,l))
    else p . l;
 
 
symbolic procedure gcdlist3(l,onestep,vlist);
% GCD of the nontrivial polys in the list L given that they all
% involve all the variables that any of them mention,
% and they are all monomial-primitive.
% ONESTEP is true if it is predicted that only one PRS step
% will be needed to compute the gcd - if so try that PRS step;
  begin
    scalar unlucky!-case,image!-set,gg,gcont,l1,w,
           reduced!-degree!-lclst,p1,p2;
    % Make all the polys primitive;
    l1:=for each p in l collect p . ezgcd!-comfac p;
    l:=for each c in l1 collect
        quotfail1(car c,comfac!-to!-poly cdr c,
                  "Content divison in GCDLIST3 failed");
    % All polys in L are now primitive;
    % Because all polys were monomial-primitive, there should
    % be no power of V to go in the result;
    gcont:=gcdlist for each c in l1 collect cddr c;
    if domainp gcont then if not gcont=1
      then errorf "GCONT has numeric part";
    % GCD of contents complete now;
    % Now I will remove duplicates from the list;
    trace!-time <<
       printc "GCDLIST3 on the polynomials";
       for each p in l do print p >>;
    l := sort(for each p in l collect poly!-abs p,function ordp);
    w := nil;
    while l do <<
       w := car l . w;
       repeat l := cdr l until null l or not car w = car l >>;
    l := reversewoc w;
    w := nil;
    trace!-time <<
       printc "Made positive, with duplicates removed...";
       for each p in l do print p >>;
    if null cdr l then return multf(gcont,car l);
       % That left just one poly;
    if domainp (gg:=car (l:=sort(l,function degree!-order))) then
      return gcont;
         % Primitive part of one poly is a constant (must be +/-1);
    if ldeg gg=1 then <<
    % True gcd is either GG or 1;
       if division!-test(gg,l) then return multf(poly!-abs gg,gcont)
       else return gcont >>;
    % All polys are now primitive and nontrivial. Use a modular
    % method to extract GCD;
    if onestep then <<
       % Try to take gcd in just one pseudoremainder step, because some
       % previous modular test suggests it may be possible;
       p1 := poly!-abs car l; p2 := poly!-abs cadr l;
       if p1=p2 then <<
             if division!-test(p1,cddr l) then return multf(p1,gcont) >>
       else <<
       trace!-time printc "Just one pseudoremainder step needed?";
       gg := poly!-gcd(lc p1,lc p2);
       gg := ezgcd!-pp addf(multf(red p1,
           quotfail1(lc p2,gg,
        "Division failure when just one pseudoremainder step needed")),
        multf(red p2,negf quotfail1(lc p1,gg,
        "Division failure when just one pseudoremainder step needed")));
       trace!-time printsf gg;
       if division!-test(gg,l) then return multf(gg,gcont) >>
       >>;
      return gcdlist31(l,vlist,gcont,gg,l1)
   end;

symbolic procedure gcdlist31(l,vlist,gcont,gg,l1);
   begin scalar cofactor,lcg,old!-modulus,prime,w,w1,zeros!-list;
    old!-modulus:=set!-modulus nil; %Remember modulus;
    lcg:=for each poly in l collect lc poly;
     trace!-time << printc "L.C.S OF L ARE:";
       for each lcpoly in lcg do printsf lcpoly >>;
    lcg:=gcdlist lcg;
     trace!-time << prin2!* "LCG (=GCD OF THESE) = ";
       printsf lcg >>;
try!-again:
    unlucky!-case:=nil;
    image!-set:=nil;
    set!-modulus(prime:=random!-prime());
    % Produce random univariate modular images of all the
    % polynomials;
    w:=l;
    if not zeros!-list then <<
      image!-set:=
         zeros!-list:=try!-max!-zeros!-for!-image!-set(w,vlist);
      trace!-time << printc image!-set;
        prin2 " Zeros-list = ";
        printc zeros!-list >> >>;
    trace!-time printc list("IMAGE SET",image!-set);
    gg:=make!-image!-mod!-p(car w,car vlist);
    trace!-time printc list("IMAGE SET",image!-set," GG",gg);
    if unlucky!-case then <<
      trace!-time << printc "Unlucky case, try again";
        print image!-set >>;
      go to try!-again >>;
    l1:=list(car w . gg);
make!-images:
    if null (w:=cdr w) then go to images!-created!-successfully;
    l1:=(car w . make!-image!-mod!-p(car w,car vlist)) . l1;
    if unlucky!-case then <<
     trace!-time << printc "UNLUCKY AGAIN...";
       printc l1;
       print image!-set >>;
      go to try!-again >>;
    gg:=gcd!-mod!-p(gg,cdar l1);
    if domainp gg then <<
      set!-modulus old!-modulus;
      trace!-time print "Primitive parts are coprime";
      return gcont >>;
    go to make!-images;
images!-created!-successfully:
    l1:=reversewoc l1; % Put back in order with smallest first;
    % If degree of gcd seems to be same as that of smallest item
    % in input list, that item should be the gcd;
    if ldeg gg=ldeg car l then <<
        gg:=poly!-abs car l;
        trace!-time <<
          prin2!* "Probable GCD = ";
          printsf gg >>;
        go to result >>
    else if (ldeg car l=add1 ldeg gg) and
            (ldeg car l=ldeg cadr l) then <<
    % Here it seems that I have just one pseudoremainder step to
    % perform, so I might as well do it;
        trace!-time <<
           printc "Just one pseudoremainder step needed"
           >>;
        gg := poly!-gcd(lc car l,lc cadr l);
        gg := ezgcd!-pp addf(multf(red car l,
            quotfail1(lc cadr l,gg,
         "Division failure when just one pseudoremainder step needed")),
         multf(red cadr l,negf quotfail1(lc car l,gg,
         "Divison failure when just one pseudoremainder step needed")));
        trace!-time printsf gg;
        go to result >>;
    w:=l1;
find!-good!-cofactor:
    if null w then go to special!-case; % No good cofactor available;
    if domainp gcd!-mod!-p(gg,cofactor:=quotient!-mod!-p(cdar w,gg))
      then go to good!-cofactor!-found;
    w:=cdr w;
    go to find!-good!-cofactor;
good!-cofactor!-found:
    cofactor:=monic!-mod!-p cofactor;
    trace!-time printc "*** Good cofactor found";
    w:=caar w;
     trace!-time << prin2!* "W= ";
       printsf w;
       prin2!* "GG= ";
       printsf gg;
       prin2!* "COFACTOR= ";
       printsf cofactor >>;
    image!-set:=sort(image!-set,function ordopcar);
     trace!-time << prin2 "IMAGE-SET = ";
       printc image!-set;
       prin2 "PRIME= ";   printc prime;
       printc "L (=POLYLIST) IS:";
       for each ll in l do printsf ll >>;
    gg:=reconstruct!-gcd(w,gg,cofactor,prime,image!-set,lcg);
    if gg='nogood then go to try!-again;
    go to result;
special!-case: % Here I have to do the first step of a PRS method;
    trace!-time << printc "*** SPECIAL CASE IN GCD ***";
      printc l;
      printc "----->";
      printc gg >>;
    reduced!-degree!-lclst:=nil;
try!-reduced!-degree!-again:
    trace!-time << printc "L1 =";
      for each ell in l1 do print ell >>;
    w1:=reduced!-degree(caadr l1,caar l1);
    w:=car w1; w1:=cdr w1;
    trace!-time << prin2 "REDUCED!-DEGREE = "; printsf w;
      prin2 " and its image = "; printsf w1 >>;
            % reduce the degree of the 2nd poly using the 1st. Result is
            % a pair : (new poly . image new poly);
    if domainp w and not null w then <<
      set!-modulus old!-modulus; return gcont >>;
            % we're done as they're coprime;
    if w and ldeg w = ldeg gg then <<
      gg:=w; go to result >>;
            % possible gcd;
    if null w then <<
            % the first poly divided the second one;
      l1:=(car l1 . cddr l1);  % discard second poly;
      if null cdr l1 then <<
         gg := poly!-abs caar l1;
         go to result >>;
      go to try!-reduced!-degree!-again >>;
            % haven't made progress yet so repeat with new polys;
    if ldeg w<=ldeg gg then <<
       gg := poly!-abs w;
       go to result >>
    else if domainp gcd!-mod!-p(gg,cofactor:=quotient!-mod!-p(w1,gg))
     then <<
       w := list list w;
       go to good!-cofactor!-found >>;
    l1:= if ldeg w <= ldeg caar l1 then
      ((w . w1) . (car l1 . cddr l1))
      else (car l1 . ((w . w1) . cddr l1));
            % replace first two polys by the reduced poly and the first
            % poly ordering according to degree;
    go to try!-reduced!-degree!-again;
            % need to repeat as we still haven't found a good cofactor;
result: % Here GG holds a tentative gcd for the primitive parts of
        % all input polys, and GCONT holds a proper one for the content;
    if division!-test(gg,l) then <<
      set!-modulus old!-modulus;
      return multf(gg,gcont) >>;
    trace!-time printc list("Trial division by ",gg," failed");
    go to try!-again
  end;
 
symbolic procedure make!-a!-list!-of!-variables l;
  begin scalar vlist;
    for each ll in l do vlist:=variables!.in!.form(ll,vlist);
    return make!-order!-consistent(vlist,kord!*)
  end;
 
symbolic procedure make!-order!-consistent(l,m);
% L is a subset of M. Make its order consistent with that
% of M;
    if null l then nil
    else if null m then errorf("Variable missing from KORD*")
    else if car m member l then car m .
       make!-order!-consistent(delete(car m,l),cdr m)
    else make!-order!-consistent(l,cdr m);
 
symbolic procedure try!-max!-zeros!-for!-image!-set(l,vlist);
  if null vlist then error(50,"VLIST NOT SET IN TRY-MAX-ZEROS-...")
  else begin scalar z;
    z:=for each v in cdr vlist collect
      if domainp lc car l or null quotf(lc car l,!*k2f v) then
        (v . 0) else (v . modular!-number next!-random!-number());
    for each ff in cdr l do
      z:=for each w in z collect
        if zerop cdr w then
          if domainp lc ff or null quotf(lc ff,!*k2f car w) then w
          else (car w . modular!-number next!-random!-number())
        else w;
    return z
  end;
 
symbolic procedure
   reconstruct!-gcd(full!-poly,gg,cofactor,p,imset,lcg);
  if null addf(full!-poly,negf multf(gg,cofactor)) then gg
  else (lambda factor!-level;
    begin scalar number!-of!-factors,image!-factors,
    true!-leading!-coeffts,multivariate!-input!-poly,
    no!-of!-primes!-to!-try,
    irreducible,non!-monic,bad!-case,target!-factor!-count,
    multivariate!-factors,hensel!-growth!-size,alphalist,
    best!-known!-factors,prime!-base,
    m!-image!-variable, reconstructing!-gcd,full!-gcd;
    if not(current!-modulus=p) then
      errorf("GCDLIST HAS NOT RESTORED THE MODULUS");
            % *WARNING* GCDLIST does not restore the modulus so
              % I had better reset it here!  ;
    if poly!-minusp lcg then error(50,list("Negative GCD: ",lcg));
    full!-poly:=poly!-abs full!-poly;
    initialise!-hensel!-fluids(full!-poly,gg,cofactor,p,lcg);
     trace!-time << printc "TRUE LEADING COEFFTS ARE:";
       for i:=1:2 do <<
         printsf getv(image!-factors,i);
         prin2!* " WITH L.C.:";
         printsf getv(true!-leading!-coeffts,i) >> >>;
    if determine!-more!-coeffts()='done then
      return full!-gcd;
    if null alphalist then alphalist:=alphas(2,
      list(getv(image!-factors,1),getv(image!-factors,2)),1);
    if alphalist='factors! not! coprime then
      errorf list("image factors not coprime?",image!-factors);
    if not !*overview then factor!-trace <<
      printstr
         "The following modular polynomials are chosen such that:";
      terpri();
      prin2!* "   a(2)*f(1) + a(1)*f(2) = 1 mod ";
      printstr hensel!-growth!-size;
      terpri();
      printstr "  where degree of a(1) < degree of f(1),";
      printstr "    and degree of a(2) < degree of f(2),";
      printstr "    and";
      for i:=1:2 do <<
        prin2!* "    a("; prin2!* i; prin2!* ")=";
        printsf cdr get!-alpha getv(image!-factors,i);
        prin2!* "and f("; prin2!* i; prin2!* ")=";
        printsf getv(image!-factors,i);
        terpri!* t >>
    >>;
    reconstruct!-multivariate!-factors(
      for each v in imset collect (car v . modular!-number cdr v));
    if irreducible or bad!-case then return 'nogood
    else return full!-gcd
  end) (factor!-level+1) ;
 
symbolic procedure initialise!-hensel!-fluids(fpoly,fac1,fac2,p,lcf1);
% ... ;
  begin scalar lc1!-image,lc2!-image;
    reconstructing!-gcd:=t;
    multivariate!-input!-poly:=multf(fpoly,lcf1);
    no!-of!-primes!-to!-try := 5;
    prime!-base:=hensel!-growth!-size:=p;
    number!-of!-factors:=2;
    lc1!-image:=make!-numeric!-image!-mod!-p lcf1;
    lc2!-image:=make!-numeric!-image!-mod!-p lc fpoly;
% Neither of the above leading coefficients will vanish;
    fac1:=times!-mod!-p(lc1!-image,fac1);
    fac2:=times!-mod!-p(lc2!-image,fac2);
    image!-factors:=mkvect 2;
    true!-leading!-coeffts:=mkvect 2;
    putv(image!-factors,1,fac1);
    putv(image!-factors,2,fac2);
    putv(true!-leading!-coeffts,1,lcf1);
    putv(true!-leading!-coeffts,2,lc fpoly);
    % If the GCD is going to be monic, we know the lc
    % of both cofactors exactly;
    non!-monic:=not(lcf1=1);
    m!-image!-variable:=mvar fpoly
  end;
 
symbolic procedure division!-test(gg,l);
% Predicate to test if GG divides all the polynomials in the list L;
    if null l then t
    else if null quotf(car l,gg) then nil
    else division!-test(gg,cdr l);
 
 

symbolic procedure degree!-order(a,b);
% Order standard forms using their degrees wrt main vars;
    if domainp a then t
    else if domainp b then nil
    else ldeg a<ldeg b;
 
symbolic procedure make!-image!-mod!-p(p,v);
% Form univariate image, set UNLUCKY!-CASE if leading coefficient
% gets destroyed;
  begin
    scalar lp;
    lp := degree!-in!-variable(p,v);
    p := make!-univariate!-image!-mod!-p(p,v);
    if not degree!-in!-variable(p,v)=lp then unlucky!-case := t;
    return p
  end;
 
 
symbolic procedure make!-univariate!-image!-mod!-p(p,v);
% Make a modular image of P, keeping only the variable V;
  if domainp p then
     if p=nil then nil
     else !*n2f modular!-number p
  else if mvar p=v then
     adjoin!-term(lpow p,
                  make!-univariate!-image!-mod!-p(lc p,v),
                  make!-univariate!-image!-mod!-p(red p,v))
    else plus!-mod!-p(
      times!-mod!-p(image!-of!-power(mvar p,ldeg p),
                    make!-univariate!-image!-mod!-p(lc p,v)),
      make!-univariate!-image!-mod!-p(red p,v));
 
symbolic procedure image!-of!-power(v,n);
  begin
    scalar w;
    w := assoc(v,image!-set);
    if null w then <<
       w := modular!-number next!-random!-number();
       image!-set := (v . w) . image!-set >>
    else w := cdr w;
    return modular!-expt(w,n)
  end;
 
symbolic procedure make!-numeric!-image!-mod!-p p;
% Make a modular image of P;
  if domainp p then
     if p=nil then 0
     else modular!-number p
    else modular!-plus(
      modular!-times(image!-of!-power(mvar p,ldeg p),
                    make!-numeric!-image!-mod!-p lc p),
      make!-numeric!-image!-mod!-p red p);
 
 
symbolic procedure total!-degree!-in!-powers(form,powlst);
% Returns a list where each variable mentioned in FORM is paired
% with the maximum degree it has. POWLST collects the list, and should
% normally be NIL on initial entry;
  if null form or domainp form then powlst
  else begin scalar x;
    if (x := atsoc(mvar form,powlst))
      then ldeg form>cdr x and rplacd(x,ldeg form)
    else powlst := (mvar form . ldeg form) . powlst;
    return total!-degree!-in!-powers(red form,
      total!-degree!-in!-powers(lc form,powlst))
  end;
 
 
symbolic procedure powers1 form;
% For each variable V in FORM collect (V . (MAX . MIN)) where
% MAX and MIN are limits to the degrees V has in FORM;
  powers2(form,powers3(form,nil),nil);
 
symbolic procedure powers3(form,l);
% Start of POWERS1 by collecting power information for
% the leading monomial in FORM;
    if domainp form then l
    else powers3(lc form,(mvar form . (ldeg form . ldeg form)) . l);
 
symbolic procedure powers2(form,powlst,thismonomial);
    if domainp form then
        if null form then powlst else powers4(thismonomial,powlst)
    else powers2(lc form,
                 powers2(red form,powlst,thismonomial),
                 lpow form . thismonomial);
 
symbolic procedure powers4(new,old);
% Merge information from new monomial into old information,
% updating MAX and MIN details;
  if null new then for each v in old collect (car v . (cadr v . 0))
  else if null old then for each v in new collect (car v . (cdr v . 0))
  else if caar new=caar old then <<
    % variables match - do MAX and MIN on degree information;
    if cdar new>cadar old then rplaca(cdar old,cdar new);
    if cdar new<cddar old then rplacd(cdar old,cdar new);
    rplacd(old,powers4(cdr new,cdr old)) >>
  else if ordop(caar new,caar old) then <<
    rplacd(cdar old,0); % Some variable not mentioned in new monomial;
    rplacd(old,powers4(new,cdr old)) >>
  else (caar new . (cdar new  . 0)) . powers4(cdr new,old);
 
 
symbolic procedure ezgcd!-pp u;
   %returns the primitive part of the polynomial U wrt leading var;
   quotf1(u,comfac!-to!-poly ezgcd!-comfac u);
 
symbolic procedure ezgcd!-sqfrf p;
   %P is a primitive standard form;
   %value is a list of square free factors;
  begin
    scalar pdash,p1,d,v;
    pdash := diff(p,v := mvar p);
    d := poly!-gcd(p,pdash); % p2*p3**2*p4**3*... ;
    if domainp d then return list p;
    p := quotfail1(p,d,"GCD division in FACTOR-SQFRF failed");
    p1 := poly!-gcd(p,
       addf(quotfail1(pdash,d,"GCD division in FACTOR-SQFRF failed"),
            negf diff(p,v)));
    return p1 . ezgcd!-sqfrf d
  end;

symbolic procedure reduced!-degree(u,v);
   %U and V are primitive polynomials in the main variable VAR;
   %result is pair: (reduced poly of U by V . its image) where by
   % reduced I mean using V to kill the leading term of U;
   begin scalar var,w,x;
    trace!-time << printc "ARGS FOR REDUCED!-DEGREE ARE:";
     printsf u;  printsf v >>;
    if u=v or quotf1(u,v) then return (nil . nil)
    else if ldeg v=1 then return (1 . 1);
    trace!-time printc "CASE NON-TRIVIAL SO TAKE A REDUCED!-DEGREE:";
    var := mvar u;
    if ldeg u=ldeg v then x := negf lc u
    else x:=(mksp(var,ldeg u - ldeg v) .* negf lc u) .+ nil;
    w:=addf(multf(lc v,u),multf(x,v));
    trace!-time printsf w;
    if degr(w,var)=0 then return (1 . 1);
    trace!-time << prin2 "REDUCED!-DEGREE-LCLST = ";
      print reduced!-degree!-lclst >>;
    reduced!-degree!-lclst := addlc(v,reduced!-degree!-lclst);
    trace!-time << prin2 "REDUCED!-DEGREE-LCLST = ";
      print reduced!-degree!-lclst >>;
    if x := quotf1(w,lc w) then w := x
    else for each y in reduced!-degree!-lclst do
      while (x := quotf1(w,y)) do w := x;
    u := v; v := ezgcd!-pp w;
    trace!-time << printc "U AND V ARE NOW:";
      printsf u; printsf v >>;
    if degr(v,var)=0 then return (1 . 1)
    else return (v . make!-univariate!-image!-mod!-p(v,var))
  end;
 
 
% moved('comfac,'ezgcd!-comfac);

% moved('pp,'ezgcd!-pp);
 
endmodule;


module facmisc;  % Miscellaneous routines used from several sections.
 
% Authors: A. C. Norman and P. M. A. Moore, 1979.
 
fluid '(base!-time
        current!-modulus
        gc!-base!-time
        image!-set!-modulus
        last!-displayed!-gc!-time
        last!-displayed!-time
        modulus!/2
        othervars
        polyzero
        pt
        save!-zset
        zerovarset);

global '(!*test exp!-value e!-value!* largest!-small!-modulus
         pseudo!-primes teeny!-primes);


% (1) investigate variables in polynomial;
 
symbolic procedure multivariatep(a,v);
    if domainp a then nil
    else if not(mvar a eq v) then t
    else if multivariatep(lc a,v) then t
    else multivariatep(red a,v);
 
symbolic procedure variables!-in!-form a;
% collect variables that occur in the form a;
    variables!.in!.form(a,nil);
 
symbolic procedure get!.coefft!.bound(poly,degbd);
% calculates a coefft bound for the factors of poly. this simple
% bound is that suggested by paul wang and linda p. rothschild in
% math.comp.vol29 july 75 p.940 due to gel'fond;
% Note that for tiny polynomials the bound is forced up to be
% larger than any prime that will get used in the mod-p splitting;
  max(get!-height poly * fixexpfloat sumof degbd,110);
 
symbolic procedure sumof degbd;
  if null degbd then 0
  else cdar degbd + sumof cdr degbd;
 
% The following vector is used by FIXEXPFLOAT to compute 2+fix exp float
% n using the appropriate constant values.  If exp were available from
% the underlying LISP support system, it would be better to use that so
% that the code would be independent of the following table.

exp!-value := mkvect 10;

putv(exp!-value,0,1);
putv(exp!-value,1,3);
putv(exp!-value,2,8);
putv(exp!-value,3,21);
putv(exp!-value,4,55);
putv(exp!-value,5,149);
putv(exp!-value,6,404);
putv(exp!-value,7,1097);
putv(exp!-value,8,2981);
putv(exp!-value,9,8104);
putv(exp!-value,10,22027);

symbolic procedure fixexpfloat n;
% Compute exponential function e**n for potentially large N,
% rounding result up somewhat. Note that exp(10)=22027 or so,
% so if the basic floating point exponential function is accurate
% to 6 or so digits we are protected here against roundoff.
  if n>10 then begin
     scalar n2;
     n2 := n/2;
     return fixexpfloat(n2)*fixexpfloat(n-n2)
  end
% else 2+fix exp float n;
  else getv(exp!-value,n);

 
% (2) timer services;
 
 
symbolic procedure set!-time();
 << last!-displayed!-time:=base!-time:=readtime();
    last!-displayed!-gc!-time:=gc!-base!-time:=readgctime();
    nil >>;
 
 
symbolic procedure print!-time m;
% display time used so far, with given message;
  begin scalar total,incr,gctotal,gcincr,w;
    if not !*test then return nil;
    w:=readtime();
    total:=w-base!-time;
    incr:=w-last!-displayed!-time;
    last!-displayed!-time:=w;
    w:=readgctime();
    gctotal:=w-gc!-base!-time;
    gcincr:=w-last!-displayed!-gc!-time;
    last!-displayed!-gc!-time:=w;
    if atom m then prin2 m else <<
        prin2 car m;
        m:=cdr m;
        while not atom m do << prin2 '! ; prin2 car m; m:=cdr m >>;
        if not null m then << prin2 '! ; prin2 m >> >>;
    prin2 " after ";
    prinmilli incr;
    prin2 "+";
    prinmilli gcincr;
    prin2 " seconds (total = ";
    prinmilli total;
    prin2 "+";
    prinmilli gctotal;
    prin2 ")";
    terpri()
  end;
 
 
symbolic procedure prinmilli n;
% print n/1000 as a decimal fraction with 2 decimal places;
  begin
    scalar u,d1,d01;
    n:=n+5; %rounding;
    n:=quotient(n,10); %now centiseconds;
    n:=divide(n,10);
    d01:=cdr n;
    n:=car n;
    n:=divide(n,10);
    d1:=cdr n;
    u:=car n;
    prin2 u;
    prin2 '!.;
    prin2 d1;
    prin2 d01;
    return nil
  end;
 
 
 
 
% (3) minor variations on ordinary algebraic operations;
 
symbolic procedure quotfail(a,b);
% version of quotf that fails if the division does;
  if polyzerop a then polyzero
  else begin scalar w;
    w:=quotf(a,b);
    if didntgo w then errorf list("UNEXPECTED DIVISION FAILURE",a,b)
    else return w
  end;
 
symbolic procedure quotfail1(a,b,msg);
% version of quotf that fails if the division does, and gives
% custom message;
  if polyzerop a then polyzero
  else begin scalar w;
    w:=quotf(a,b);
    if didntgo w then errorf msg
    else return w
  end;
 
 
 
% (4) pseudo-random prime numbers - small and large;
 
 
symbolic procedure set!-teeny!-primes();
  begin scalar i;
    i:=-1;
    teeny!-primes:=mkvect 9;
    putv(teeny!-primes,i:=iadd1 i,3);
    putv(teeny!-primes,i:=iadd1 i,5);
    putv(teeny!-primes,i:=iadd1 i,7);
    putv(teeny!-primes,i:=iadd1 i,11);
    putv(teeny!-primes,i:=iadd1 i,13);
    putv(teeny!-primes,i:=iadd1 i,17);
    putv(teeny!-primes,i:=iadd1 i,19);
    putv(teeny!-primes,i:=iadd1 i,23);
    putv(teeny!-primes,i:=iadd1 i,29);
    putv(teeny!-primes,i:=iadd1 i,31)
  end;
 
set!-teeny!-primes();
 
 
symbolic procedure random!-small!-prime();
  begin
    scalar p;
    repeat <<p:=small!-random!-number(); if evenp p then p := iadd1 p>>
       until primep p;
    return p
  end;
 
symbolic procedure small!-random!-number();
% Returns a smallish number from a distribution strongly favouring
% smaller numbers;
  begin scalar w;
% The next lines generate a random value in the range 0 to 1000000.
    w:=remainder(next!-random!-number(),1000)
                    +1000*remainder(next!-random!-number(),1000);
    if w < 0 then w := w + 1000000;
    w:=1.0+1.5*float w/1000000.0;  % 1.0 to 2.5
    w:=times(w,w);                 % In range 1.0 to 6.25
    return fix fac!-exp w;         % Should be in range 3 to 518,
                                   % < 21 about half the time;
  end;
 
symbolic procedure fac!-exp u;
   % Simple exp routine.  Assumes that Lisp has a routine for
   % exponentiation of floats by integers.  Relative accuracy 4.e-5.
   begin scalar x; integer n;
     n := fix u;
     if (x := (u - float n)) > 0.5 then <<x := x - 1.0; n := n + 1>>;
     u := e!-value!***n;
     return u*((x+6.0)*x+12.0)/((x-6.0)*x+12.0)
   end;
 
symbolic procedure random!-teeny!-prime l;
% get one of the first 10 primes at random providing it is
% not in the list L or that L says we have tried them all;
  if l='all or (length l = 10) then nil
  else begin scalar p;
    repeat
       p:=getv(teeny!-primes,remainder(next!-random!-number(),10))
    until not member(p,l);
    return p
  end;
 
% symbolic procedure primep n;
% Test if prime. Only for use on small integers.
%    n=2 or
%    (n>2 and not evenp n and primetest(n,3));

% symbolic procedure primetest(n,trial);
%    if igreaterp(itimes(trial,trial),n) then t
%    else if iremainder(n,trial)=0 then nil
%    else primetest(n,iplus(trial,2));

 
% PSEUDO-PRIMES will be a list of all composite numbers which are
% less than 2^24 and where 2926^(n-1) = 3315^(n-1) = 1 mod n.
 
pseudo!-primes:=mkvect 87;

begin
  scalar i,l;
  i:=0;
  l:= '(2047     4033     33227    38503    56033
        137149   145351   146611   188191   226801
        252601   294409   328021   399001   410041
        488881   512461   556421   597871   636641
        665281   722261   742813   873181   950797
        1047619  1084201  1141141  1152271  1193221
        1373653  1398101  1461241  1584133  1615681
        1627921  1755001  1857241  1909001  2327041
        2508013  3057601  3363121  3542533  3581761
        3828001  4069297  4209661  4335241  4510507
        4588033  4650049  4877641  5049001  5148001
        5176153  5444489  5481451  5892511  5968873
        6186403  6189121  6733693  6868261  6955541
        7398151  7519441  8086231  8134561  8140513
        8333333  8725753  8927101  9439201  9494101
        10024561 10185841 10267951 10606681 11972017
        13390081 14063281 14469841 14676481 14913991
        15247621 15829633 16253551);
    while l do <<
       putv(pseudo!-primes,i,car l);
       i:=i+1;
       l:=cdr l >>
  end;
 
symbolic procedure random!-prime();
  begin
% I want a random prime that is smaller than largest-small-modulus.
% I do this by generating random odd integers in the range lsm/2 to
% lsm and filtering them for primality. Prime testing is done using
% a Fermat test followed by lookup in an exception table that was
% laboriously precomputed. This process should be distinctly faster
% than trial-division testing of candidate primes, but the exception
% table is tedious to compute, so I limit lsm to 2**24 here. This is
% both the value that Cambridge Lisp can support directly, an indication
% of how large an exception table I computed using 48 hours of CPU time
% and large enough that primes selected this way will hardly ever
% be unlucky just through being too small.
    scalar p,w,oldmod,lsm, lsm2;
    lsm := largest!-small!-modulus;
    if lsm > 2**24 then lsm := 2**24;
    lsm2 := lsm/2;
    % W will become 1 when P is prime;
    oldmod := current!-modulus;
    while not (w=1) do <<
      p := remainder(next!-random!-number(), lsm);
      if p < lsm2 then p := p + lsm2;
      if evenp p then p := p + 1;
      set!-modulus p;
      w:=modular!-expt(modular!-number 2926,isub1 p);
      if w=1
         and (modular!-expt(modular!-number 3315,isub1 p) neq 1
                 or pseudo!-prime!-p p)
        then w:=0>>;
    set!-modulus oldmod;
    return p
  end;
 
symbolic procedure pseudo!-prime!-p n;
  begin
    scalar low,mid,high,v;
    low:=0;
    high:=87; % Size of vector of pseudo-primes;
    while not (high=low) do << % Binary search in table;
      mid:=iquotient(iplus(iadd1 high,low),2);
         % Mid point of (low,high);
      v:=getv(pseudo!-primes,mid);
      if igreaterp(v,n) then high:=isub1 mid else low:=mid >>;
    return (getv(pseudo!-primes,low)=n)
  end;
 
 
% (5) useful routines for vectors;
 
 
symbolic procedure form!-sum!-and!-product!-mod!-p(avec,fvec,r);
% sum over i (avec(i) * fvec(i));
  begin scalar s;
    s:=polyzero;
    for i:=1:r do
      s:=plus!-mod!-p(times!-mod!-p(getv(avec,i),getv(fvec,i)),
        s);
    return s
  end;
 
symbolic procedure form!-sum!-and!-product!-mod!-m(avec,fvec,r);
% Same as above but AVEC holds alphas mod p and want to work
% mod m (m > p) so minor difference to change AVEC to AVEC mod m;
  begin scalar s;
    s:=polyzero;
    for i:=1:r do
      s:=plus!-mod!-p(times!-mod!-p(
        !*f2mod !*mod2f getv(avec,i),getv(fvec,i)),s);
    return s
  end;
 
symbolic procedure reduce!-vec!-by!-one!-var!-mod!-p(v,pt,n);
% substitute for the given variable in all elements creating a
% new vector for the result. (all arithmetic is mod p);
  begin scalar newv;
    newv:=mkvect n;
    for i:=1:n do
      putv(newv,i,evaluate!-mod!-p(getv(v,i),car pt,cdr pt));
    return newv
  end;
 
symbolic procedure make!-bivariate!-vec!-mod!-p(v,imset,var,n);
  begin scalar newv;
    newv:=mkvect n;
    for i:=1:n do
      putv(newv,i,make!-bivariate!-mod!-p(getv(v,i),imset,var));
    return newv
  end;

symbolic procedure times!-vector!-mod!-p(v,n);
% product of all the elements in the vector mod p;
  begin scalar w;
    w:=1;
    for i:=1:n do w:=times!-mod!-p(getv(v,i),w);
    return w
  end;
 
symbolic procedure make!-vec!-modular!-symmetric(v,n);
% fold each elt of V which is current a modular poly in the
% range 0->(p-1) onto the symmetric range (-p/2)->(p/2);
  for i:=1:n do putv(v,i,make!-modular!-symmetric getv(v,i));
 
% (6) Combinatorial fns used in finding values for the variables;
 
 
symbolic procedure make!-zerovarset vlist;
% vlist is a list of pairs (v . tag) where v is a variable name and
% tag is a boolean tag. The procedure splits the list into two
% according to the tags: Zerovarset is set to a list of variables
% whose tag is false and othervars contains the rest;
  for each w in vlist do
    if cdr w then othervars:= car w . othervars
    else zerovarset:= car w . zerovarset;
 
symbolic procedure make!-zeroset!-list n;
% Produces a list of lists each of length n with all combinations of
% ones and zeroes;
  begin scalar w;
    for k:=0:n do w:=append(w,kcombns(k,n));
    return w
  end;
 
symbolic procedure kcombns(k,m);
% produces a list of all combinations of ones and zeroes with k ones
% in each;
  if k=0 or k=m then begin scalar w;
    if k=m then k:=1;
    for i:=1:m do w:=k.w;
    return list w
    end
  else if k=1 or k=isub1 m then <<
    if k=isub1 m then k:=0;
    list!-with!-one!-a(k,1 #- k,m) >>
  else append(
    for each x in kcombns(isub1 k,isub1 m) collect (1 . x),
    for each x in kcombns(k,isub1 m) collect (0 . x) );
 
symbolic procedure list!-with!-one!-a(a,b,m);
% Creates list of all lists with one a and m-1 b's in;
  begin scalar w,x,r;
    for i:=1:isub1 m do w:=b . w;
    r:=list(a . w);
    for i:=1:isub1 m do <<
      x:=(car w) . x; w:=cdr w;
      r:=append(x,(a . w)) . r >>;
    return r
  end;

symbolic procedure make!-next!-zset l;
  begin scalar k,w;
    image!-set!-modulus:=iadd1 image!-set!-modulus;
    set!-modulus image!-set!-modulus;
    w:=for each ll in cdr l collect
      for each n in ll collect
        if n=0 then n
        else <<
          k:=modular!-number next!-random!-number();
          while (zerop k) or (onep k) do
            k:=modular!-number next!-random!-number();
          if k>modulus!/2 then k:=k-current!-modulus;
           k >>;
    save!-zset:=nil;
    return w
  end;
 
endmodule;


module facprim;   % Factorize a primitive multivariate polynomial.

% Author: P. M. A. Moore, 1979.

% Modifications by: Arthur C. Norman.

fluid '(!*force!-zero!-set
        !*overshoot
        !*overview
        !*timings
        !*trfac
        alphalist
        alphavec
        bad!-case
        base!-time
        best!-factor!-count
        best!-known!-factors
        best!-modulus
        best!-set!-pointer
        chosen!-prime
        current!-factor!-product
        current!-modulus
        degree!-bounds
        deltam
        f!-numvec
        factor!-level
        factor!-trace!-list
        factored!-lc
        factorvec
        facvec
        fhatvec
        forbidden!-primes
        forbidden!-sets
        full!-gcd
        hensel!-growth!-size
        image!-content
        image!-factors
        image!-lc
        image!-mod!-p
        image!-poly
        image!-set
        image!-set!-modulus
        input!-leading!-coefficient
        input!-polynomial
        inverted
        inverted!-sign
        irreducible
        known!-factors
        kord!*
        m!-image!-variable
        modfvec
        modular!-info
        multivariate!-factors
        multivariate!-input!-poly
        no!-of!-best!-sets
        no!-of!-primes!-to!-try
        no!-of!-random!-sets
        non!-monic
        null!-space!-basis
        number!-of!-factors
        one!-complete!-deg!-analysis!-done
        othervars
        poly!-mod!-p
        polynomial!-to!-factor
        predictions
        previous!-degree!-map
        prime!-base
        reconstructing!-gcd
        reduction!-count
        save!-zset
        sfp!-count
        split!-list
        target!-factor!-count
        true!-leading!-coeffts
        usable!-set!-found
        valid!-image!-sets
        vars!-to!-kill
        zero!-set!-tried
        zerovarset
        zset);

global '(largest!-small!-modulus);


%**********************************************************************;
%
%    multivariate polynomial factorization more or less as described
%    by paul wang in:  math. comp. vol.32 no.144 oct 1978 pp. 1215-1231
%       'an improved multivariate polynomial factoring algorithm'
%
%**********************************************************************;


%----------------------------------------------------------------------;
%   this code works by using a local database of fluid variables
%   whose meaning is (hopefully) obvious.
%   they are used as follows:
%
%   global name:            set in:               comments:
%
% m!-factored!-leading!    create!.images        only set if non-numeric
%  -coefft
% m!-factored!-images      factorize!.images     vector
% m!-input!-polynomial     factorize!-primitive!
%                           -polynomial
% m!-best!-image!-pointer  choose!.best!.image
% m!-image!-factors        choose!.best!.image   vector
% m!-true!-leading!        choose!.best!.image   vector
%  -coeffts
% m!-prime                 choose!.best!.image
% irreducible              factorize!.images     predicate
% inverted                 create!.images        predicate
% m!-inverted!-sign        create!-images        +1 or -1
% non!-monic               determine!-leading!   predicate
%                           -coeffts
%                          (also reconstruct!-over!
%                           -integers)
% m!-number!-of!-factors   choose!.best!.image
% m!-image!-variable       square!.free!.factorize
%                          or factorize!-form
% m!-image!-sets           create!.images        vector
% this last contains the images of m!-input!-polynomial and the
% numbers associated with the factors of lc m!-input!-polynomial (to be
% used later) the latter existing only when the lc m!-input!-polynomial
% is non-integral. ie.:
%    m!-image!-sets=< ... , (( d . u ), a, d) , ... >   ( a vector)
% where: a = an image set (=association list);
%        d = cont(m!-input!-polynomial image wrt a);
%        u = prim.part.(same) which is non-trivial square-free
%            by choice of image set.;
%        d = vector of numbers associated with factors in lc
%            m!-input!-polynomial (these depend on a as well);
% the number of entries in m!-image!-sets is defined by the fluid
% variable, no.of.random.sets;
%
%
%
%----------------------------------------------------------------------;




%**********************************************************************;
% multivariate factorization part 1. entry point for this code:
%  ** n.b.** the polynomial is assumed to be non-trivial and primitive;


symbolic procedure square!.free!.factorize u;
% u primitive (multivariate) poly but not yet square free.
% result is list of factors consed with their respective multiplicities:
%  ((f1 . m1),(f2 . m2),...) where mi may = mj when i not = j ;
% u is non-trivial - ie. at least linear in some variable;
%***** nb. this does not use best square free method *****;
  begin scalar v,w,x,i,newu,f!.list,sfp!-count;
    sfp!-count:=0;
    factor!-trace
      if not u=polynomial!-to!-factor then
       << prin2!* "Primitive polynomial to factor: ";
          printsf u >>;
    if null m!-image!-variable then
      errorf list("M-IMAGE-VARIABLE not set: ",u);
    v:=poly!-gcd(u,
          derivative!-wrt!-main!-variable(u,m!-image!-variable));
    if onep v then <<
      factor!-trace printstr "The polynomial is square-free.";
      return square!-free!-prim!-factor(u,1) >>
    else factor!-trace <<
      printstr
         "We now square-free decompose this to produce a series of ";
      printstr
         "(square-free primitive) factors which we treat in turn: ";
      terpri(); terpri() >>;
    w:=quotfail(u,v);
    x:=poly!-gcd(v,w);
    newu:=quotfail(w,x);
    if not onep newu then
    << f!.list:=append(f!.list,
        square!-free!-prim!-factor(newu,1))
    >>;
    i:=2;  % power of next factors;
            % from now on we can avoid an extra gcd and any diffn;
    while not domainp v do
    << v:=quotfail(v,x);
      w:=quotfail(w,newu);
      x:=poly!-gcd(v,w);
      newu:=quotfail(w,x);
      if not onep newu then
      << f!.list:=append(f!.list,
          square!-free!-prim!-factor(newu,i))
      >>;
      i:=iadd1 i
    >>;
    if not v=1 then f!.list:=(v . 1) . f!.list;
    return f!.list
  end;

symbolic procedure square!-free!-prim!-factor(u,i);
% factorize the square-free primitive factor u whose multiplicity
% in the original poly is i. return the factors consed with this
% multiplicity;
  begin scalar w;
    sfp!-count:=iadd1 sfp!-count;
    factor!-trace <<
      if not(u=polynomial!-to!-factor) then <<
        prin2!* "("; prin2!* sfp!-count;
        prin2!* ") Square-free primitive factor: "; printsf u;
        prin2!* "    with multiplicity "; prin2!* i;
        terpri!*(nil) >> >>;
    w:=distribute!.multiplicity(factorize!-primitive!-polynomial u,i);
    factor!-trace
      if not u=polynomial!-to!-factor then <<
        prin2!* "Factors of ("; prin2!* sfp!-count;
        printstr ") are: "; fac!-printfactors(1 . w);
        terpri(); terpri() >>;
    return w
  end;

symbolic procedure distribute!.multiplicity(factorlist,n);
% factorlist is a simple list of factors of a square free primitive
% multivariate poly and n is their multiplicity in a square free
% decomposition of another polynomial. result is a list of form:
%  ((f1 . n),(f2 . n),...) where fi are the factors.;
  for each w in factorlist collect (w . n);

symbolic procedure factorize!-primitive!-polynomial u;
% u is primitive square free and at least linear in
% m!-image!-variable. m!-image!-variable is the variable preserved in
% the univariate images. this function determines a random set of
% integers and a prime to create a univariate modular image of u,
% factorize it and determine the leading coeffts of the factors in the
% full factorization of u. finally the modular image factors are grown
% up to the full multivariates ones using the hensel construction;
% result is simple list of irreducible factors;
  if degree!-in!-variable(u,m!-image!-variable) = 1 then list u
  else if degree!-in!-variable(u,m!-image!-variable) = 2 then
    factorize!-quadratic u
  else if fac!-univariatep u then
     univariate!-factorize u
  else begin scalar
    valid!-image!-sets,factored!-lc,image!-factors,prime!-base,
    one!-complete!-deg!-analysis!-done,zset,zerovarset,othervars,
    multivariate!-input!-poly,best!-set!-pointer,reduction!-count,
    true!-leading!-coeffts,number!-of!-factors,
    inverted!-sign,irreducible,inverted,vars!-to!-kill,
    forbidden!-sets,zero!-set!-tried,non!-monic,
    no!-of!-best!-sets,no!-of!-random!-sets,bad!-case,
    target!-factor!-count,modular!-info,multivariate!-factors,
    hensel!-growth!-size,alphalist,base!-timer,w!-time,
    previous!-degree!-map,image!-set!-modulus,
    best!-known!-factors,reconstructing!-gcd,full!-gcd;
    base!-timer:=time();
    trace!-time display!-time(
      " Entered multivariate primitive polynomial code after ",
      base!-timer - base!-time);
    %note that this code works by using a local database of
    %fluid variables that are updated by the subroutines directly
    %called here. this allows for the relativly complicated
    %interaction between flow of data and control that occurs in
    %the factorization algorithm.
    factor!-trace <<
      printstr "From now on we shall refer to this polynomial as U.";
      printstr
         "We now create an image of U by picking suitable values ";
      printstr "for all but one of the variables in U.";
      prin2!* "The variable preserved in the image is ";
      prinvar m!-image!-variable; terpri!*(nil) >>;
    initialize!-fluids u;
            % set up the fluids to start things off;
    w!-time:=time();
tryagain:
    get!-some!-random!-sets();
    choose!-the!-best!-set();
      trace!-time <<
        display!-time("Modular factoring and best set chosen in ",
          time()-w!-time);
        w!-time:=time() >>;
      if irreducible then return list u
      else if bad!-case then <<
        if !*overshoot then printc "Bad image sets - loop";
        bad!-case:=nil; goto tryagain >>;
    reconstruct!-image!-factors!-over!-integers();
      trace!-time <<
        display!-time("Image factors reconstructed in ",time()-w!-time);
        w!-time:=time() >>;
      if irreducible then return list u
      else if bad!-case then <<
        if !*overshoot then printc "Bad image factors - loop";
        bad!-case:=nil; goto tryagain >>;
    determine!.leading!.coeffts();
      trace!-time <<
        display!-time("Leading coefficients distributed in ",
          time()-w!-time);
        w!-time:=time() >>;
      if irreducible then
        return list u
      else if bad!-case then <<
        if !*overshoot then printc "Bad split shown by LC distribution";
        bad!-case:=nil; goto tryagain >>;
    if determine!-more!-coeffts()='done then <<
      trace!-time <<
        display!-time("All the coefficients distributed in ",
          time()-w!-time);
        w!-time:=time() >>;
      return check!-inverted multivariate!-factors >>;
    trace!-time <<
      display!-time("More coefficients distributed in ",
        time()-w!-time);
      w!-time:=time() >>;
    reconstruct!-multivariate!-factors(nil);
      if bad!-case and not irreducible then <<
        if !*overshoot then printc "Multivariate overshoot - restart";
         bad!-case:=nil; goto tryagain >>;
      trace!-time
        display!-time("Multivariate factors reconstructed in ",
          time()-w!-time);
      if irreducible then return list u;
    return check!-inverted multivariate!-factors
   end;

symbolic procedure getcof(p, v, n);
% Get coeff of v^n in p;
% I bet this exists somewhere under a different name....
  if domainp p then if n=0 then p else nil
  else if mvar p = v then
    if ldeg p=n then lc p
    else getcof(red p, v, n)
  else addf(multf((lpow p .* 1) .+ nil, getcof(lc p, v, n)),
            getcof(red p, v, n));
 
symbolic procedure factorize!-quadratic u;
% U is a primitive square-free quadratic. It factors if and only if
% its discriminant is a perfect square;
  begin
    scalar a, b, c, discr, f1, f2, x;
% I am unreasonably cautious here - i THINK that the image variable
% should be the main var here, but in case things have goot themselves
% reordered & to make myself bomb proof against future changes I will
% not assume same
    a := getcof(u, m!-image!-variable, 2);
    b := getcof(u, m!-image!-variable, 1);
    c := getcof(u, m!-image!-variable, 0);
    discr := addf(multf(b, b), multf(a, multf(-4, c)));
    discr := sqrtf2 discr;
    if discr=-1 then return list u; % Irreducible;
    x := addf(multf(a, multf(2, !*k2f m!-image!-variable)), b);
    f1 := addf(x, discr);
    f2 := addf(x, negf discr);
    f1 := quotf(f1,
               cdr contents!-with!-respect!-to(f1, m!-image!-variable));
    f2 := quotf(f2,
               cdr contents!-with!-respect!-to(f2, m!-image!-variable));
    return list(f1, f2)
  end;
 
symbolic procedure sqrtd2 d;
% Square root of domain element or -1 if it does not have an exact one;
% Possibly needs upgrades to deal with non-integer domains, e.g. in
% modular arithmetic just half of all values have square roots (= are
% quadratic residues), but finding the roots is (I think) HARD.  In
% floating point it could be taken that all positive values have square
% roots.  Anyway somebody can adjust this as necessary and I think that
% SQRTF2 will then behave properly...
  if d=nil then nil
  else if not fixp d or d<0 then -1
  else begin
    scalar q, r, rold;
    q := pmam!-sqrt d;        % Works even if D is really huge;
    r := q*q-d;
    repeat <<
      rold := abs r;
      q := q - (r+q)/(2*q);   % / truncates, so this rounds to nearest
      r := q*q-d >> until abs r >= rold;
    if r=0 then return q
    else return -1
  end;
 
symbolic procedure sqrtf2 p;
% Return square root of the polynomial P if there is an exact one,
% else returns -1 to indicate failure;
  if domainp p then sqrtd2 p
  else begin
    scalar v, d, qlc, q, r, w;
    if not evenp (d := ldeg p) or
       (qlc := sqrtf2 lc p) = -1 then return -1;
    d := d/2;
    v := mvar p;
    q := (mksp(v, d) .* qlc) .+ nil;      % First approx to sqrt(P)
    r := multf(2, q);
    p := red p;                           % Residue
    while p neq nil and
          mvar p = v and
          ldeg p >= d and
          (w := quotf(lt p .+ nil, r)) neq nil do
        <<  p := addf(p, multf(negf w, addf(multf(2, q), w)));
            q := addf(q, w) >>;
    if p=nil then return q else return -1
  end;
 

symbolic procedure initialize!-fluids u;
% Set up the fluids to be used in factoring primitive poly;
  begin scalar w,w1,wtime;
    if !*force!-zero!-set then <<
      no!-of!-random!-sets:=1;
      no!-of!-best!-sets:=1 >>
    else <<
      no!-of!-random!-sets:=9;
      % we generate this many and calculate their factor counts.
      no!-of!-best!-sets:=5;
            % we find the modular factors of this many;
      >>;
    image!-set!-modulus:=5;
    vars!-to!-kill:=variables!-to!-kill lc u;
    multivariate!-input!-poly:=u;
    no!-of!-primes!-to!-try := 5;
    target!-factor!-count:=degree!-in!-variable(u,m!-image!-variable);
    if not domainp lc multivariate!-input!-poly then
      if domainp (w:=
        trailing!.coefft(multivariate!-input!-poly,
                         m!-image!-variable)) then
    << inverted:=t;
        % note that we are 'inverting' the poly m!-input!-polynomial;
      w1:=invert!.poly(multivariate!-input!-poly,m!-image!-variable);
      multivariate!-input!-poly:=cdr w1;
      inverted!-sign:=car w1;
            % to ease the lc problem, m!-input!-polynomial <- poly
            % produced by taking numerator of (m!-input!-polynomial
            % with 1/m!-image!-variable substituted for
            % m!-image!-variable);
            % m!-inverted!-sign is -1 if we have inverted the sign of
            % the resulting poly to keep it +ve, else +1;
      factor!-trace <<
        prin2!* "The trailing coefficient of U wrt ";
        prinvar m!-image!-variable; prin2!* "(="; prin2!* w;
        printstr ") is purely numeric so we 'invert' U to give: ";
        prin2!* "  U <- "; printsf multivariate!-input!-poly;
        printstr "This simplifies any problems with the leading ";
        printstr "coefficient of U." >>
    >>
    else <<
      trace!-time printc "Factoring the leading coefficient:";
      wtime:=time();
      factored!-lc:=
        factorize!-form!-recursion lc multivariate!-input!-poly;
      trace!-time display!-time("Leading coefficient factored in ",
        time()-wtime);
            % factorize the lc of m!-input!-polynomial completely;
      factor!-trace <<
        printstr
           "The leading coefficient of U is non-trivial so we must ";
        printstr "factor it before we can decide how it is distributed";
        printstr "over the leading coefficients of the factors of U.";
        printstr "So the factors of this leading coefficient are:";
        fac!-printfactors factored!-lc >>
    >>;
   make!-zerovarset vars!-to!-kill;
            % Sets ZEROVARSET and OTHERVARS;
   if null zerovarset then zero!-set!-tried:=t
   else <<
    zset:=make!-zeroset!-list length zerovarset;
    save!-zset:=zset >>
  end;



symbolic procedure variables!-to!-kill lc!-u;
% picks out all the variables in u except var. also checks to see if
% any of these divide lc u: if they do they are dotted with t otherwise
% dotted with nil. result is list of these dotted pairs;
  for each w in cdr kord!* collect
    if (domainp lc!-u) or didntgo quotf(lc!-u,!*k2f w) then
       (w . nil) else (w . t);


%**********************************************************************;
% multivariate factorization part 2. creating image sets and picking
%  the best one;


fluid '(usable!-set!-found);

symbolic procedure get!-some!-random!-sets();
% here we create a number of random sets to make the input
% poly univariate by killing all but 1 of the variables. at
% the same time we pick a random prime to reduce this image
% poly mod p;
  begin scalar image!-set,chosen!-prime,image!-lc,image!-mod!-p,wtime,
        image!-content,image!-poly,f!-numvec,forbidden!-primes,i,j,
        usable!-set!-found;
    valid!-image!-sets:=mkvect no!-of!-random!-sets;
    i:=0;
    while i < no!-of!-random!-sets do <<
      wtime:=time();
      generate!-an!-image!-set!-with!-prime(
        if i<idifference(no!-of!-random!-sets,3) then nil else t);
      trace!-time
        display!-time("  Image set generated in ",time()-wtime);
      i:=iadd1 i;
      putv(valid!-image!-sets,i,list(
        image!-set,chosen!-prime,image!-lc,image!-mod!-p,image!-content,
        image!-poly,f!-numvec));
      forbidden!-sets:=image!-set . forbidden!-sets;
      forbidden!-primes:=list chosen!-prime;
      j:=1;
      while (j<3) and (i<no!-of!-random!-sets) do <<
        wtime:=time();
        image!-mod!-p:=find!-a!-valid!-prime(image!-lc,image!-poly,
          not numberp image!-content);
        if not(image!-mod!-p='not!-square!-free) then <<
          trace!-time
            display!-time("  Prime and image mod p found in ",
              time()-wtime);
          i:=iadd1 i;
          putv(valid!-image!-sets,i,list(
            image!-set,chosen!-prime,image!-lc,image!-mod!-p,
            image!-content,image!-poly,f!-numvec));
          forbidden!-primes:=chosen!-prime . forbidden!-primes >>;
        j:=iadd1 j
        >>
      >>
  end;

symbolic procedure choose!-the!-best!-set();
% given several random sets we now choose the best by factoring
% each image mod its chosen prime and taking one with the
% lowest factor count as the best for hensel growth;
  begin scalar split!-list,poly!-mod!-p,null!-space!-basis,
               known!-factors,w,n,fnum,remaining!-split!-list,wtime;
    modular!-info:=mkvect no!-of!-random!-sets;
    wtime:=time();
    for i:=1:no!-of!-random!-sets do <<
      w:=getv(valid!-image!-sets,i);
      get!-factor!-count!-mod!-p(i,get!-image!-mod!-p w,
        get!-chosen!-prime w,not numberp get!-image!-content w) >>;
    split!-list:=sort(split!-list,function lessppair);
            % this now contains a list of pairs (m . n) where
            % m is the no: of factors in image no: n. the list
            % is sorted with best split (smallest m) first;
    trace!-time
      display!-time("  Factor counts found in ",time()-wtime);
    if caar split!-list = 1 then <<
      irreducible:=t; return nil >>;
    w:=nil;
    wtime:=time();
    for i:=1:no!-of!-best!-sets do <<
      n:=cdar split!-list;
      get!-factors!-mod!-p(n,
          get!-chosen!-prime getv(valid!-image!-sets,n));
      w:=(car split!-list) . w;
      split!-list:=cdr split!-list >>;
            % pick the best few of these and find out their
            % factors mod p;
    trace!-time
      display!-time("  Best factors mod p found in ",time()-wtime);
    remaining!-split!-list:=split!-list;
    split!-list:=reversewoc w;
            % keep only those images that are fully factored mod p;
    wtime:=time();
    check!-degree!-sets(no!-of!-best!-sets,t);
            % the best image is pointed at by best!-set!-pointer;
    trace!-time
      display!-time("  Degree sets analysed in ",time()-wtime);
            % now if these didn't help try the rest to see
            % if we can avoid finding new image sets altogether:    ;
    if bad!-case then <<
      bad!-case:=nil;
      wtime:=time();
      while remaining!-split!-list do <<
        n:=cdar remaining!-split!-list;
        get!-factors!-mod!-p(n,
            get!-chosen!-prime getv(valid!-image!-sets,n));
        w:=(car remaining!-split!-list) . w;
        remaining!-split!-list:=cdr remaining!-split!-list >>;
      trace!-time
        display!-time("  More sets factored mod p in ",time()-wtime);
      split!-list:=reversewoc w;
      wtime:=time();
      check!-degree!-sets(no!-of!-random!-sets - no!-of!-best!-sets,t);
            % best!-set!-pointer hopefully points at the best image ;
      trace!-time
        display!-time("  More degree sets analysed in ",time()-wtime)
    >>;
    one!-complete!-deg!-analysis!-done:=t;
    factor!-trace <<
      w:=getv(valid!-image!-sets,best!-set!-pointer);
      prin2!* "The chosen image set is:  ";
      for each x in get!-image!-set w do <<
        prinvar car x; prin2!* "="; prin2!* cdr x; prin2!* "; " >>;
      terpri!*(nil);
      prin2!* "and chosen prime is "; printstr get!-chosen!-prime w;
      printstr "Image polynomial (made primitive) = ";
      printsf get!-image!-poly w;
      if not(get!-image!-content w=1) then <<
        prin2!* " with (extracted) content of ";
        printsf get!-image!-content w >>;
      prin2!* "The image polynomial mod "; prin2!* get!-chosen!-prime w;
      printstr ", made monic, is:";
      printsf get!-image!-mod!-p w;
      printstr "and factors of the primitive image mod this prime are:";
      for each x in getv(modular!-info,best!-set!-pointer)
         do printsf x;
      if (fnum:=get!-f!-numvec w) and not !*overview then <<
        printstr "The numeric images of each (square-free) factor of";
        printstr "the leading coefficient of the polynomial are as";
        prin2!* "follows (in order):";
        prin2!* "  ";
        for i:=1:length cdr factored!-lc do <<
          prin2!* getv(fnum,i); prin2!* "; " >>;
        terpri!*(nil) >>
      >>
  end;



%**********************************************************************;
% multivariate factorization part 3. reconstruction of the
% chosen image over the integers;


symbolic procedure reconstruct!-image!-factors!-over!-integers();
% the hensel construction from modular case to univariate
% over the integers;
  begin scalar best!-modulus,best!-factor!-count,input!-polynomial,
    input!-leading!-coefficient,best!-known!-factors,s,w,i,
    x!-is!-factor,x!-factor;
    s:=getv(valid!-image!-sets,best!-set!-pointer);
    best!-known!-factors:=getv(modular!-info,best!-set!-pointer);
    best!-modulus:=get!-chosen!-prime s;
    best!-factor!-count:=length best!-known!-factors;
    input!-polynomial:=get!-image!-poly s;
    if ldeg input!-polynomial=1 then
      if not(x!-is!-factor:=not numberp get!-image!-content s) then
        errorf list("Trying to factor a linear image poly: ",
          input!-polynomial)
      else begin scalar brecip,ww,om,x!-mod!-p;
        number!-of!-factors:=2;
        prime!-base:=best!-modulus;
        x!-factor:=!*k2f m!-image!-variable;
        putv(valid!-image!-sets,best!-set!-pointer,
          put!-image!-poly!-and!-content(s,lc get!-image!-content s,
            multf(x!-factor,get!-image!-poly s)));
        om:=set!-modulus best!-modulus;
        brecip:=modular!-reciprocal
          red (ww:=reduce!-mod!-p input!-polynomial);
        x!-mod!-p:=!*f2mod x!-factor;
        alphalist:=list(
          (x!-mod!-p . brecip),
          (ww . modular!-minus modular!-times(brecip,lc ww)));
        do!-quadratic!-growth(list(x!-factor,input!-polynomial),
          list(x!-mod!-p,ww),best!-modulus);
        w:=list input!-polynomial; % All factors apart from X-FACTOR;
        set!-modulus om
      end
    else <<
      input!-leading!-coefficient:=lc input!-polynomial;
      factor!-trace <<
        printstr
           "Next we use the Hensel Construction to grow these modular";
      printstr "factors into factors over the integers." >>;
      w:=reconstruct!.over!.integers();
      if irreducible then return t;
      if (x!-is!-factor:=not numberp get!-image!-content s) then <<
        number!-of!-factors:=length w + 1;
        x!-factor:=!*k2f m!-image!-variable;
        putv(valid!-image!-sets,best!-set!-pointer,
          put!-image!-poly!-and!-content(s,lc get!-image!-content s,
            multf(x!-factor,get!-image!-poly s)));
        fix!-alphas() >>
      else number!-of!-factors:=length w;
      if number!-of!-factors=1 then return irreducible:=t >>;
    if number!-of!-factors>target!-factor!-count then
      return bad!-case:=list get!-image!-set s;
    image!-factors:=mkvect number!-of!-factors;
    i:=1;
    factor!-trace
      printstr "The full factors of the image polynomial are:";
    for each im!-factor in w do <<
      putv(image!-factors,i,im!-factor);
      factor!-trace printsf im!-factor;
      i:=iadd1 i >>;
   if x!-is!-factor then <<
     putv(image!-factors,i,x!-factor);
     factor!-trace <<
       printsf x!-factor;
       printsf get!-image!-content
         getv(valid!-image!-sets,best!-set!-pointer) >> >>
  end;

symbolic procedure do!-quadratic!-growth(flist,modflist,p);
  begin scalar fhatvec,alphavec,factorvec,modfvec,facvec,
    current!-factor!-product,i,deltam,m;
    fhatvec:=mkvect number!-of!-factors;
    alphavec:=mkvect number!-of!-factors;
    factorvec:=mkvect number!-of!-factors;
    modfvec:=mkvect number!-of!-factors;
    facvec:=mkvect number!-of!-factors;
    current!-factor!-product:=1;
    i:=0;
    for each ff in flist do <<
      putv(factorvec,i:=iadd1 i,ff);
      current!-factor!-product:=multf(ff,current!-factor!-product) >>;
    i:=0;
    for each modff in modflist do <<
      putv(modfvec,i:=iadd1 i,modff);
      putv(alphavec,i,cdr get!-alpha modff) >>;
    deltam:=p;
    m:=deltam*deltam;
    while m<largest!-small!-modulus do <<
      quadratic!-step(m,number!-of!-factors);
      m:=m*deltam >>;
    hensel!-growth!-size:=deltam;
    alphalist:=nil;
    for j:=1:number!-of!-factors do
      alphalist:=(reduce!-mod!-p getv(factorvec,j) . getv(alphavec,j))
        . alphalist
  end;

symbolic procedure fix!-alphas();
% we extracted a factor x (where x is the image variable)
% before any alphas were calculated, we now need to put
% back this factor and its coresponding alpha which incidently
% will change the other alphas;
  begin scalar om,f1,x!-factor,a,arecip,b;
    om:=set!-modulus hensel!-growth!-size;
    f1:=reduce!-mod!-p input!-polynomial;
    x!-factor:=!*f2mod !*k2f m!-image!-variable;
    arecip:=modular!-reciprocal
      (a:=evaluate!-mod!-p(f1,m!-image!-variable,0));
    b:=times!-mod!-p(modular!-minus arecip,
      quotfail!-mod!-p(difference!-mod!-p(f1,a),x!-factor));
    alphalist:=(x!-factor . arecip) .
      (for each aa in alphalist collect
        ((car aa) . remainder!-mod!-p(times!-mod!-p(b,cdr aa),car aa)));
    set!-modulus om
  end;




%**********************************************************************;
% multivariate factorization part 4. determining the leading
%  coefficients;


symbolic procedure determine!.leading!.coeffts();
% this function determines the leading coeffts to all but a constant
% factor which is spread over all of the factors before reconstruction;
  begin scalar delta,c,s;
    s:=getv(valid!-image!-sets,best!-set!-pointer);
    delta:=get!-image!-content s;
            % cont(the m!-input!-polynomial image);
    if not domainp lc multivariate!-input!-poly then
    << true!-leading!-coeffts:=
      distribute!.lc(number!-of!-factors,image!-factors,s,
        factored!-lc);
       if bad!-case then <<
         bad!-case:=list get!-image!-set s;
         target!-factor!-count:=number!-of!-factors - 1;
         if target!-factor!-count=1 then irreducible:=t;
         return bad!-case >>;
       delta:=car true!-leading!-coeffts;
       true!-leading!-coeffts:=cdr true!-leading!-coeffts;
            % if the lc problem exists then use wang's algorithm to
            % distribute it over the factors. ;
       if not !*overview then factor!-trace <<
         printstr "We now determine the leading coefficients of the ";
         printstr "factors of U by using the factors of the leading";
         printstr "coefficient of U and their (square-free) images";
         printstr "referred to earlier:";
         for i:=1:number!-of!-factors do <<
           prinsf getv(image!-factors,i);
           prin2!* " with l.c.: ";
           printsf getv(true!-leading!-coeffts,i)
         >> >>;
       if not onep delta then factor!-trace <<
         if !*overview then
        << printstr
              "In determining the leading coefficients of the factors";
           prin2!* "of U, " >>;
         prin2!* "We have an integer factor, ";
         prin2!* delta;
         printstr ", left over that we ";
         printstr "cannot yet distribute correctly." >>
      >>
    else <<
      true!-leading!-coeffts:=mkvect number!-of!-factors;
      for i:=1:number!-of!-factors do
        putv(true!-leading!-coeffts,i,lc getv(image!-factors,i));
      if not onep delta then
        factor!-trace <<
          prin2!* "U has a leading coefficient = ";
          prin2!* delta;
          printstr " which we cannot ";
          printstr "yet distribute correctly over the image factors." >>
      >>;
    if not onep delta then
    << for i:=1:number!-of!-factors do
       << putv(image!-factors,i,multf(delta,getv(image!-factors,i)));
          putv(true!-leading!-coeffts,i,
            multf(delta,getv(true!-leading!-coeffts,i)))
       >>;
       divide!-all!-alphas delta;
       c:=expt(delta,isub1 number!-of!-factors);
       multivariate!-input!-poly:=multf(c,multivariate!-input!-poly);
       non!-monic:=t;
       factor!-trace <<
         printstr "(a) We multiply each of the image factors by the ";
         printstr "absolute value of this constant and multiply";
         prin2!* "U by ";
         if not(number!-of!-factors=2) then
           << prin2!* delta; prin2!* "**";
             prin2!* isub1 number!-of!-factors >>
         else prin2!* delta;
         printstr " giving new image factors";
         printstr "as follows: ";
         for i:=1:number!-of!-factors do
           printsf getv(image!-factors,i)
       >>
    >>;
            % if necessary, fiddle the remaining integer part of the
            % lc of m!-input!-polynomial;
  end;


%**********************************************************************;
% multivariate factorization part 5. reconstruction;


symbolic procedure reconstruct!-multivariate!-factors vset!-mod!-p;
% Hensel construction for multivariate case
% Full univariate split has already been prepared (if factoring);
% but we only need the modular factors and the true leading coeffts;
  (lambda factor!-level; begin
    scalar s,om,u0,alphavec,wtime,predictions,
      best!-factors!-mod!-p,fhatvec,w1,fvec!-mod!-p,d,degree!-bounds,
      lc!-vec;
    alphavec:=mkvect number!-of!-factors;
    best!-factors!-mod!-p:=mkvect number!-of!-factors;
    lc!-vec := mkvect number!-of!-factors;
        % This will preserve the LCs of the factors while we are working
        % mod p since they may contain numbers that are bigger than the
        % modulus.;
    if not(
      (d:=max!-degree(multivariate!-input!-poly,0)) < prime!-base) then
      fvec!-mod!-p:=choose!-larger!-prime d;
    om:=set!-modulus hensel!-growth!-size;
    if null fvec!-mod!-p then <<
      fvec!-mod!-p:=mkvect number!-of!-factors;
      for i:=1:number!-of!-factors do
        putv(fvec!-mod!-p,i,reduce!-mod!-p getv(image!-factors,i)) >>;
    for i:=1:number!-of!-factors do <<
      putv(alphavec,i,cdr get!-alpha getv(fvec!-mod!-p,i));
      putv(best!-factors!-mod!-p,i,
        reduce!-mod!-p getv(best!-known!-factors,i));
      putv(lc!-vec,i,lc getv(best!-known!-factors,i)) >>;
         % Set up the Alphas, input factors mod p and remember to save
         % the LCs for use after finding the multivariate factors mod p;
    if not reconstructing!-gcd then <<
      s:=getv(valid!-image!-sets,best!-set!-pointer);
      vset!-mod!-p:=for each v in get!-image!-set s collect
        (car v . modular!-number cdr v) >>;
%    princ "kord* =";% print kord!*;
%    princ "order of variable substitution=";% print vset!-mod!-p;
    u0:=reduce!-mod!-p multivariate!-input!-poly;
    set!-degree!-bounds vset!-mod!-p;
    wtime:=time();
    factor!-trace <<
      printstr
         "We use the Hensel Construction to grow univariate modular";
      printstr
         "factors into multivariate modular factors, which will in";
      printstr "turn be used in the later Hensel construction.  The";
      printstr "starting modular factors are:";
      printvec(" f(",number!-of!-factors,")=",best!-factors!-mod!-p);
      prin2!* "The modulus is "; printstr current!-modulus >>;
    find!-multivariate!-factors!-mod!-p(u0,
      best!-factors!-mod!-p,
      vset!-mod!-p);
    if bad!-case then <<
      trace!-time <<
        display!-time(" Multivariate modular factors failed in ",
          time()-wtime);
        wtime:=time() >>;
      target!-factor!-count:=number!-of!-factors - 1;
      if target!-factor!-count=1 then irreducible:=t;
      set!-modulus om;
      return bad!-case >>;
    trace!-time <<
      display!-time(" Multivariate modular factors found in ",
        time()-wtime);
      wtime:=time() >>;
    fhatvec:=make!-multivariate!-hatvec!-mod!-p(best!-factors!-mod!-p,
      number!-of!-factors);
    for i:=1:number!-of!-factors do
      putv(fvec!-mod!-p,i,getv(best!-factors!-mod!-p,i));
    make!-vec!-modular!-symmetric(best!-factors!-mod!-p,
      number!-of!-factors);
    for i:=1:number!-of!-factors do <<
%      w1:=getv(coefft!-vectors,i);
%      putv(best!-known!-factors,i,
%        merge!-terms(getv(best!-factors!-mod!-p,i),w1));
      putv(best!-known!-factors,i,
        force!-lc(getv(best!-factors!-mod!-p,i),getv(lc!-vec,i)));
         % Now we put back the LCs before growing the multivariate
         % factors to be correct over the integers giving the final
         % result;
      >>;
    wtime:=time();
    w1:=hensel!-mod!-p(
      multivariate!-input!-poly,
      fvec!-mod!-p,
      best!-known!-factors,
      get!.coefft!.bound(multivariate!-input!-poly,
        total!-degree!-in!-powers(multivariate!-input!-poly,nil)),
      vset!-mod!-p,
      hensel!-growth!-size);
    if car w1='overshot then <<
      trace!-time <<
        display!-time(" Full factors failed in ",time()-wtime);
        wtime:=time() >>;
      target!-factor!-count:=number!-of!-factors - 1;
      if target!-factor!-count=1 then irreducible:=t;
      set!-modulus om;
      return bad!-case:=t >>;
    if not(car w1='ok) then errorf w1;
    trace!-time <<
      display!-time(" Full factors found in ",time()-wtime);
      wtime:=time() >>;
    if reconstructing!-gcd then <<
      full!-gcd:=if non!-monic then car primitive!.parts(
          list getv(cdr w1,1),m!-image!-variable,nil)
        else getv(cdr w1,1);
      set!-modulus om;
      return full!-gcd >>;
    for i:=1:getv(cdr w1,0) do
      multivariate!-factors:=getv(cdr w1,i) . multivariate!-factors;
    if non!-monic then multivariate!-factors:=
      primitive!.parts(multivariate!-factors,m!-image!-variable,nil);
    factor!-trace <<
      printstr "The full multivariate factors are:";
      for each x in multivariate!-factors do printsf x >>;
    set!-modulus om;
  end) (factor!-level*100);

symbolic procedure check!-inverted multi!-faclist;
  begin scalar inv!.sign,l;
    if inverted then <<
      inv!.sign:=1;
      multi!-faclist:=
        for each x in multi!-faclist collect <<
        l:=invert!.poly(x,m!-image!-variable);
        inv!.sign:=(car l) * inv!.sign;
        cdr l >>;
      if not(inv!.sign=inverted!-sign) then
        errorf list("INVERSION HAS LOST A SIGN",inv!.sign) >>;
      return multivariate!-factors:=multi!-faclist end;


endmodule;


module interfac;

% Authors: A. C. Norman and P. M. A. Moore, 1981.

% Modifications by: Anthony C. Hearn.

fluid '(m!-image!-variable
        poly!-vector
        polyzero
        unknowns!-list
        varlist);


%**********************************************************************;
%
% Routines that are specific to REDUCE.
%  These are either routines that are not needed in the HASH system
%  (which is the other algebra system that this factorizer
%  can be plugged into) or routines that are specifically
%  redefined in the HASH system. ;


%---------------------------------------------------------------------;
% The following would normally live in section:  ALPHAS
%---------------------------------------------------------------------;

symbolic procedure assoc!-alpha(poly,alist);  assoc(poly,alist);


%---------------------------------------------------------------------;
% The following would normally live in section:  COEFFTS
%---------------------------------------------------------------------;

symbolic procedure termvector2sf v;
  begin scalar r,w;
    for i:=car getv(v,0) step -1 until 1 do <<
      w:=getv(v,i);
            % degree . coefft;
      r:=if car w=0 then cdr w else
        (mksp(m!-image!-variable,car w) .* cdr w) .+ r
    >>;
    return r
  end;

symbolic procedure force!-lc(a,n);
% force polynomial a to have leading coefficient as specified;
    (lpow a .* n) .+ red a;

symbolic procedure merge!-terms(u,v);
  merge!-terms1(1,u,v,car getv(v,0));

symbolic procedure merge!-terms1(i,u,v,n);
  if i#>n then u
  else begin scalar a,b;
    a:=getv(v,i);
    if domainp u or not(mvar u=m!-image!-variable) then
      if not(car a=0) then errorf list("MERGING COEFFTS FAILED",u,a)
      else if cdr a then return cdr a
      else return u;
    b:=lt u;
    if tdeg b=car a then return
      (if cdr a then tpow b .* cdr a else b) .+
        merge!-terms1(i #+ 1,red u,v,n)
    else if tdeg b #> car a then return b .+ merge!-terms1(i,red u,v,n)
    else errorf list("MERGING COEFFTS FAILED ",u,a)
  end;

symbolic procedure list!-terms!-in!-factor u;
% ...;
  if domainp u then list (0 . nil)
  else (ldeg u . nil) . list!-terms!-in!-factor red u;

symbolic procedure try!-other!-coeffts(r,unknowns!-list,uv);
  begin scalar ldeg!-r,lc!-r,w;
    while not domainp r and (r:=red r) and not(w='complete) do <<
      if not depends!-on!-var(r,m!-image!-variable) then
        << ldeg!-r:=0; lc!-r:=r >>
      else << ldeg!-r:=ldeg r; lc!-r:=lc r >>;
      w:=solve!-next!-coefft(ldeg!-r,lc!-r,unknowns!-list,uv) >>
  end;


%---------------------------------------------------------------------;
% The following would normally live in section:  FACMISC
%---------------------------------------------------------------------;

symbolic procedure derivative!-wrt!-main!-variable(p,var);
% partial derivative of the polynomial p with respect to
% its main variable, var;
    if domainp p or (mvar p neq var) then nil
    else
     begin
      scalar degree;
      degree:=ldeg p;
      if degree=1 then return lc p; %degree one term is special;
      return (mksp(mvar p,degree-1) .* multf(degree,lc p)) .+
        derivative!-wrt!-main!-variable(red p,var)
     end;

symbolic procedure fac!-univariatep u;
% tests to see if u is univariate;
  domainp u or not multivariatep(u,mvar u);

symbolic procedure variables!.in!.form(a,sofar);
    if domainp a then sofar
    else <<
      if not memq(mvar a,sofar) then
        sofar:=mvar a . sofar;
      variables!.in!.form(red a,
        variables!.in!.form(lc a,sofar)) >>;


symbolic procedure degree!-in!-variable(p,v);
% returns the degree of the polynomial p in the
% variable v;
    if domainp p then 0
    else if lc p=0
     then errorf "Polynomial with a zero coefficient found"
    else if v=mvar p then ldeg p
    else max(degree!-in!-variable(lc p,v),
      degree!-in!-variable(red p,v));

symbolic procedure get!-height poly;
% find height (max coefft) of given poly;
  if null poly then 0
  else if numberp poly then abs poly
  else max(get!-height lc poly,get!-height red poly);


symbolic procedure poly!-minusp a;
    if a=nil then nil
    else if domainp a then minusp a
    else poly!-minusp lc a;

symbolic procedure poly!-abs a;
    if poly!-minusp a then negf a
    else a;

symbolic procedure fac!-printfactors l;
% procedure to print the result of factorize!-form;
% ie. l is of the form: (c . f)
%  where c is the numeric content (may be 1)
%  and f is of the form: ( (f1 . e1) (f2 . e2) ... (fn . en) )
%    where the fi's are s.f.s and ei's are numbers;
<< terpri();
  if not (car l = 1) then printsf car l;
  for each item in cdr l do
    printsf !*p2f mksp(prepf car item,cdr item) >>;


%---------------------------------------------------------------------;
% The following would normally live in section:  FACPRIM
%---------------------------------------------------------------------;

symbolic procedure invert!.poly(u,var);
% u is a non-trivial primitive square free multivariate polynomial.
% assuming var is the top-level variable in u, this effectively
% reverses the position of the coeffts: ie
%   a(n)*var**n + a(n-1)*var**(n-1) + ... + a(0)
% becomes:
%   a(0)*var**n + a(1)*var**(n-1) + ... + a(n) .               ;
  begin scalar w,invert!-sign;
    w:=invert!.poly1(red u,ldeg u,lc u,var);
    if poly!-minusp lc w then <<
      w:=negf w;
      invert!-sign:=-1 >>
    else invert!-sign:=1;
    return invert!-sign . w
  end;

symbolic procedure invert!.poly1(u,d,v,var);
% d is the degree of the poly we wish to invert.
% assume d > ldeg u always, and that v is never nil;
  if (domainp u) or not (mvar u=var) then
    (var to d) .* u .+ v
  else invert!.poly1(red u,d,(var to (d-ldeg u)) .* (lc u) .+ v,var);


symbolic procedure trailing!.coefft(u,var);
% u is multivariate poly with var as the top-level variable. we find
% the trailing coefft - ie the constant wrt var in u;
  if domainp u then u
  else if mvar u=var then trailing!.coefft(red u,var)
  else u;


%---------------------------------------------------------------------;
% The following would normally live in section:  IMAGESET
%---------------------------------------------------------------------;

symbolic procedure make!-image!-lc!-list(u,imset);
  reversewoc make!-image!-lc!-list1(u,imset,
    for each x in imset collect car x);

symbolic procedure make!-image!-lc!-list1(u,imset,varlist);
% If IMSET=((x1 . a1, x2 . a2, ... , xn . an)) (ordered) where xj is
% the variable and aj its value, then this fn creates n images of U wrt
% sets S(i) where S(i)= ((x1 . a1), ... , (xi . ai)). The result is an
% ordered list of pairs: (u(i) . X(i+1)) where u(i)= U wrt S(i) and
% X(i) = (xi, ... , xn) and X(n+1) = NIL.  VARLIST = X(1).
% (Note. the variables tagged to u(i) should be all those
% appearing in u(i) unless it is degenerate). The returned list is
% ordered with u(1) first and ending with the number u(n);
  if null imset then nil
  else if domainp u then list(!*d2n u . cdr varlist)
  else if mvar u=caar imset then
    begin scalar w;
      w:=horner!-rule!-for!-one!-var(
        u,caar imset,cdar imset,polyzero,ldeg u) . cdr varlist;
      return
        if polyzerop car w then list (0 . cdr w)
        else (w . make!-image!-lc!-list1(car w,cdr imset,cdr varlist))
    end
  else make!-image!-lc!-list1(u,cdr imset,cdr varlist);

symbolic procedure horner!-rule!-for!-one!-var(u,x,val,c,degg);
  if domainp u or not(mvar u=x)
    then if zerop val then u else addf(u,multf(c,!*num2f(val**degg)))
  else begin scalar newdeg;
    newdeg:=ldeg u;
    return horner!-rule!-for!-one!-var(red u,x,val,
       if zerop val then lc u
        else addf(lc u,
                  multf(c,!*num2f(val**(idifference(degg,newdeg))))),
                            newdeg)
  end;

symbolic procedure make!-image(u,imset);
% finds image of u wrt image set, imset, (=association list);
  if domainp u then u
  else if mvar u=m!-image!-variable then
    adjoin!-term(lpow u,!*num2f evaluate!-in!-order(lc u,imset),
                        make!-image(red u,imset))
  else !*num2f evaluate!-in!-order(u,imset);

symbolic procedure evaluate!-in!-order(u,imset);
% makes an image of u wrt imageset, imset, using horner's rule. result
% should be purely numeric;
  if domainp u then !*d2n u
  else if mvar u=caar imset then
    horner!-rule(evaluate!-in!-order(lc u,cdr imset),
      ldeg u,red u,imset)
  else evaluate!-in!-order(u,cdr imset);

symbolic procedure horner!-rule(c,degg,a,vset);
% c is running total and a is what is left;
  if domainp a
    then if zerop cdar vset then !*d2n a
          else (!*d2n a)+c*((cdar vset)**degg)
  else if not(mvar a=caar vset)
   then if zerop cdar vset then evaluate!-in!-order(a,cdr vset)
         else evaluate!-in!-order(a,cdr vset)+c*((cdar vset)**degg)
  else begin scalar newdeg;
    newdeg:=ldeg a;
    return horner!-rule(if zerop cdar vset
                          then evaluate!-in!-order(lc a,cdr vset)
                         else evaluate!-in!-order(lc a,cdr vset)
      +c*((cdar vset)**(idifference(degg,newdeg))),newdeg,red a,vset)
  end;


%---------------------------------------------------------------------;
% The following would normally live in section:  MHENSFNS
%---------------------------------------------------------------------;

symbolic procedure max!-degree(u,n);
% finds maximum degree of any single variable in U (n is max so far);
  if domainp u then n
  else if igreaterp(n,ldeg u) then
    max!-degree(red u,max!-degree(lc u,n))
  else max!-degree(red u,max!-degree(lc u,ldeg u));

symbolic procedure diff!-over!-k!-mod!-p(u,k,v);
% derivative of u wrt v divided by k (=number);
  if domainp u then nil
  else if mvar u = v then
    if ldeg u = 1 then quotient!-mod!-p(lc u,modular!-number k)
    else adjoin!-term(mksp(v,isub1 ldeg u),
      quotient!-mod!-p(
        times!-mod!-p(modular!-number ldeg u,lc u),
        modular!-number k),
      diff!-over!-k!-mod!-p(red u,k,v))
  else adjoin!-term(lpow u,
    diff!-over!-k!-mod!-p(lc u,k,v),
    diff!-over!-k!-mod!-p(red u,k,v));

symbolic procedure diff!-k!-times!-mod!-p(u,k,v);
% differentiates u k times wrt v and divides by (k!) ie. for each term
% a*v**n we get [n k]*a*v**(n-k) if n>=k and nil if n<k where
% [n k] is the binomial coefficient;
  if domainp u then nil
  else if mvar u = v then
    if ldeg u < k then nil
    else if ldeg u = k then lc u
    else adjoin!-term(mksp(v,ldeg u - k),
      times!-mod!-p(binomial!-coefft!-mod!-p(ldeg u,k),lc u),
      diff!-k!-times!-mod!-p(red u,k,v))
  else adjoin!-term(lpow u,
    diff!-k!-times!-mod!-p(lc u,k,v),
    diff!-k!-times!-mod!-p(red u,k,v));

symbolic procedure spreadvar(u,v,slist);
% find all the powers of V in U and merge their degrees into SLIST.
% We ignore the constant term wrt V;
  if domainp u then slist
  else <<
    if mvar u=v and not member(ldeg u,slist) then slist:=ldeg u . slist;
    spreadvar(red u,v,spreadvar(lc u,v,slist)) >>;


%---------------------------------------------------------------------;
% The following would normally live in section:  UNIHENS
%---------------------------------------------------------------------;

symbolic procedure root!-squares(u,sofar);
  if null u then pmam!-sqrt sofar
  else if domainp u then pmam!-sqrt(sofar+(u*u))
  else root!-squares(red u,sofar+(lc u * lc u));

%---------------------------------------------------------------------;
% The following would normally live in section:  VECPOLY
%---------------------------------------------------------------------;

symbolic procedure poly!-to!-vector p;
% spread the given univariate polynomial out into POLY-VECTOR;
    if isdomain p then putv(poly!-vector,0,!*d2n p)
    else <<
      putv(poly!-vector,ldeg p,lc p);
      poly!-to!-vector red p >>;

symbolic procedure vector!-to!-poly(p,d,v);
% Convert the vector P into a polynomial of degree D in variable V;
  begin
    scalar r;
    if d#<0 then return nil;
    r:=!*n2f getv(p,0);
    for i:=1:d do
      if getv(p,i) neq 0 then r:=((v to i) .* getv(p,i)) .+ r;
    return r
  end;



endmodule;


module linmodp;

% Authors: A. C. Norman and P. M. A. Moore, 1979;

fluid '(current!-modulus prime!-base);


%**********************************************************************;
%
%      This section solves linear equations mod p;








symbolic procedure lu!-factorize!-mod!-p(a,n);
% A is a matrix of size N*N. Overwrite it with its LU factorization;
  begin scalar w;
   for i:=1:n do begin
    scalar ii,pivot;
    ii:=i;
    while n>=ii and ((pivot:=getm2(a,ii,i))=0
       or iremainder(pivot,prime!-base)=0) do ii := ii+1;
    if ii>n then return 'singular;
    if not ii=i then begin
        scalar temp;
        temp:=getv(a,i);
        putv(a,i,getv(a,ii));
        putv(a,ii,temp) end;
    putm2(a,i,0,ii); % Remember pivoting information;
    pivot:=modular!-reciprocal pivot;
    putm2(a,i,i,pivot);
    for j:=i+1:n do
      putm2(a,i,j,modular!-times(pivot,getm2(a,i,j)));
    for ii:=i+1:n do begin
       scalar multiple;
       multiple:=getm2(a,ii,i);
       for j:=i+1:n do
          putm2(a,ii,j,modular!-difference(getm2(a,ii,j),
            modular!-times(multiple,getm2(a,i,j)))) end end;
    return w
  end;

symbolic procedure back!-substitute(a,v,n);
% A is an N*N matrix as produced by LU-FACTORIZE-MOD-P, and V is
% a vector of length N. Overwrite V with solution to linear equations;
  begin
    for i:=1:n do
        begin scalar ii;
           ii:=getm2(a,i,0); % Pivot control;
           if ii neq i
             then begin scalar temp;
                     temp:=getv(v,i);
                     putv(v,i,getv(v,ii));
                     putv(v,ii,temp)
                  end
        end;
    for i:=1:n do begin
        putv(v,i,times!-mod!-p(!*n2f getm2(a,i,i),getv(v,i)));
        for ii:=i+1:n do
           putv(v,ii,difference!-mod!-p(getv(v,ii),
              times!-mod!-p(getv(v,i),!*n2f getm2(a,ii,i)))) end;
            % Now do the actual back substitution;
    for i:=n-1 step -1 until 1 do
      for j:=i+1:n do
        putv(v,i,difference!-mod!-p(getv(v,i),
          times!-mod!-p(!*n2f getm2(a,i,j),getv(v,j))));
    return v
  end;


endmodule;


module mhensfns;

% Authors: A. C. Norman and P. M. A. Moore, 1979;

fluid '(!*trfac
        alphalist
        current!-modulus
        degree!-bounds
        delfvec
        factor!-level
        factor!-trace!-list
        forbidden!-primes
        hensel!-growth!-size
        image!-factors
        max!-unknowns
        multivariate!-input!-poly
        non!-monic
        number!-of!-factors
        number!-of!-unknowns
        polyzero
        prime!-base
        pt);


%**********************************************************************;
%    This section contains some of the functions used in
%    the multivariate hensel growth. (ie they are called from
%    section MULTIHEN or function RECONSTRUCT-MULTIVARIATE-FACTORS). ;



symbolic procedure set!-degree!-bounds v;
  degree!-bounds:=for each var in v collect
    (car var . degree!-in!-variable(multivariate!-input!-poly,car var));

symbolic procedure get!-degree!-bound v;
  begin scalar w;
    w:=atsoc(v,degree!-bounds);
    if null w then errorf(list("Degree bound not found for ",
        v," in ",degree!-bounds));
    return cdr w
  end;

symbolic procedure choose!-larger!-prime n;
% our prime base in the multivariate hensel must be greater than n so
% this sets a new prime to be that (previous one was found to be no
% good). We also set up various fluids e.g. the Alphas;
% the primes we can choose are < 2**24 so if n is bigger
% we collapse;
  if n > 2**24-1 then
    errorf list("CANNOT CHOOSE PRIME > GIVEN NUMBER:",n)
  else begin scalar p,flist!-mod!-p,k,fvec!-mod!-p,forbidden!-primes;
trynewprime:
    if p then forbidden!-primes:=p . forbidden!-primes;
    p:=random!-prime();
            % this chooses a word-size prime (currently 24 bits);
    set!-modulus p;
    if not(p>n) or member(p,forbidden!-primes) or
      polyzerop reduce!-mod!-p lc multivariate!-input!-poly then
       goto trynewprime;
    for i:=1:number!-of!-factors do
      flist!-mod!-p:=(reduce!-mod!-p getv(image!-factors,i) .
                       flist!-mod!-p);
    alphalist:=alphas(number!-of!-factors,flist!-mod!-p,1);
    if alphalist='factors! not! coprime then goto trynewprime;
    hensel!-growth!-size:=p;
    prime!-base:=p;
    factor!-trace <<
      prin2!* "New prime chosen: ";
      printstr hensel!-growth!-size >>;
    k:=number!-of!-factors;
    fvec!-mod!-p:=mkvect k;
    for each w in flist!-mod!-p do <<
      putv(fvec!-mod!-p,k,w); k:=isub1 k >>;
    return fvec!-mod!-p
  end;

symbolic procedure binomial!-coefft!-mod!-p(n,r);
  if n<r then nil
  else if n=r then 1
  else if r=1 then !*num2f modular!-number n
  else begin scalar n!-c!-r,b,j;
    n!-c!-r:=1;
    b:=min(r,n-r);
    n:=modular!-number n;
    r:=modular!-number r;
    for i:=1:b do <<
      j:=modular!-number i;
      n!-c!-r:=modular!-quotient(
        modular!-times(n!-c!-r,
          modular!-difference(n,modular!-difference(j,1))),
        j) >>;
    return !*num2f n!-c!-r
  end;

symbolic procedure make!-multivariate!-hatvec!-mod!-p(bvec,n);
% makes a vector whose ith elt is product over j [ BVEC(j) ] / BVEC(i);
% NB. we must NOT actually do the division here as we are likely
% to be working mod p**n (some n > 1) and the division can involve
% a division by p.;
  begin scalar bhatvec,r;
    bhatvec:=mkvect n;
    for i:=1:n do <<
      r:=1;
      for j:=1:n do if not(j=i) then r:=times!-mod!-p(r,getv(bvec,j));
      putv(bhatvec,i,r) >>;
    return bhatvec
  end;

symbolic procedure max!-degree!-in!-var(fvec,v);
  begin scalar r,d;
    r:=0;
    for i:=1:number!-of!-factors do
      if r<(d:=degree!-in!-variable(getv(fvec,i),v)) then r:=d;
    return r
  end;

symbolic procedure make!-growth!-factor pt;
% pt is of form (v . n) where v is a variable. we make the s.f. v-n;
  if cdr pt=0 then !*f2mod !*k2f car pt
  else plus!-mod!-p(!*f2mod !*k2f car pt,modular!-minus cdr pt);

symbolic procedure terms!-done!-mod!-p(fvec,delfvec,delfactor);
% calculate the terms introduced by the corrections in DELFVEC;
  begin scalar flist,delflist;
    for i:=1:number!-of!-factors do <<
      flist:=getv(fvec,i) . flist;
      delflist:=getv(delfvec,i) . delflist >>;
    return terms!-done1!-mod!-p(number!-of!-factors,flist,delflist,
      number!-of!-factors,delfactor)
  end;

symbolic procedure terms!-done1!-mod!-p(n,flist,delflist,r,m);
  if n=1 then (car flist) . (car delflist)
  else begin scalar k,i,f1,f2,delf1,delf2;
    k:=n/2; i:=1;
    for each f in flist do
    << if i>k then f2:=(f . f2)
       else f1:=(f . f1);
       i:=i+1 >>;
    i:=1;
    for each delf in delflist do
    << if i>k then delf2:=(delf . delf2)
       else delf1:=(delf . delf1);
       i:=i+1 >>;
    f1:=terms!-done1!-mod!-p(k,f1,delf1,r,m);
    delf1:=cdr f1; f1:=car f1;
    f2:=terms!-done1!-mod!-p(n-k,f2,delf2,r,m);
    delf2:=cdr f2; f2:=car f2;
    delf1:=
      plus!-mod!-p(plus!-mod!-p(
        times!-mod!-p(f1,delf2),
        times!-mod!-p(f2,delf1)),
        times!-mod!-p(times!-mod!-p(delf1,m),delf2));
    if n=r then return delf1;
    return (times!-mod!-p(f1,f2) . delf1)
  end;

symbolic procedure primitive!.parts(flist,var,univariate!-inputs);
% finds the prim.part of each factor in flist wrt variable var;
% Note that FLIST may contain univariate or multivariate S.F.s
% (according to UNIVARIATE!-INPUTS) - in the former case we correct the
% ALPHALIST if necessary;
  begin scalar c,primf;
    if null var then
      errorf "Must take primitive parts wrt some non-null variable";
    if non!-monic then
      factor!-trace <<
        printstr "Because we multiplied the original primitive";
        printstr "polynomial by a multiple of its leading coefficient";
        printstr "(see (a) above), the factors we have now are not";
        printstr "necessarily primitive. However the required factors";
        printstr "are merely their primitive parts." >>;
    return for each fw in flist collect
    << if not depends!-on!-var(fw,var) then
            errorf list("WRONG VARIABLE",var,fw);
       c:=comfac fw;
       if car c then errorf(list(
         "FACTOR DIVISIBLE BY MAIN VARIABLE:",fw,car c));
       primf:=quotfail(fw,cdr c);
       if not(cdr c=1) and univariate!-inputs then
         multiply!-alphas(cdr c,fw,primf);
       primf >>
  end;


symbolic procedure make!-predicted!-forms(pfs,v);
% PFS is a vector of S.F.s which represents the sparsity of
% the associated polynomials wrt V. Here PFS is adjusted to a
% suitable form for handling this sparsity. ie. we record the
% degrees of V in a vector for each poly in PFS. Each
% monomial (in V) represents an unknown (its coefft) in the predicted
% form of the associated poly. We count the maximum no of unknowns for
% each poly and return the maximum of these;
  begin scalar l,n,pvec,j,w;
    max!-unknowns:=0;
    for i:=1:number!-of!-factors do <<
      w:=getv(pfs,i);  % get the ith poly;
      l:=sort(spreadvar(w,v,nil),function lessp);
            % Pick out the monomials in V from this poly and order
            % them in increasing degree;
      n:=iadd1 length l; % no of unknowns in predicted poly - we add
                         % one for the constant term;
      number!-of!-unknowns:=(n . i) . number!-of!-unknowns;
      if max!-unknowns<n then max!-unknowns:=n;
      pvec:=mkvect isub1 n;
            % get space for the info on this poly;
      j:=0;
      putv(pvec,j,isub1 n);
            % put in the length of this vector which will vary
            % from poly to poly;
      for each m in l do putv(pvec,j:=iadd1 j,m);
            % put in the monomial info;
      putv(pfs,i,pvec);
            % overwrite the S.F. in PFS with the more compact vector;
      >>;
    number!-of!-unknowns:=sort(number!-of!-unknowns,function lesspcar);
    return max!-unknowns
  end;

symbolic procedure make!-correction!-vectors(bfs,n);
% set up space for the vector of vectors to hold the correction
% terms as we generate them by the function SOLVE-FOR-CORRECTIONS.
% Also put in the starting values;
  begin scalar cvs,cv;
    cvs:=mkvect number!-of!-factors;
    for i:=1:number!-of!-factors do <<
      cv:=mkvect n;
            % each CV will hold the corrections for the ith factor;
            % the no of corrections we put in here depends on the
            % maximum no of unknowns we have in the predicted
            % forms, giving a set of soluble linear systems (hopefully);
      putv(cv,1,getv(bfs,i));
            % put in the first 'corrections';
      putv(cvs,i,cv) >>;
    return cvs
  end;

symbolic procedure construct!-soln!-matrices(pfs,val);
% Here we construct the matrices - one for each linear system
% we will have to solve to see if our predicted forms of the
% answer are correct. Each matrix is a vector of row-vectors
% - the ijth elt is in jth slot of ith row-vector (ie zero slots
% are not used here);
  begin scalar soln!-matrix,resvec,n,pv;
    resvec:=mkvect number!-of!-factors;
    for i:=1:number!-of!-factors do <<
      pv:=getv(pfs,i);
      soln!-matrix:=mkvect(n:=iadd1 getv(pv,0));
      construct!-ith!-matrix(soln!-matrix,pv,n,val);
      putv(resvec,i,soln!-matrix) >>;
    return resvec
  end;

symbolic procedure construct!-ith!-matrix(sm,pv,n,val);
  begin scalar mv;
    mv:=mkvect n;  %  this will be the first row;
    putv(mv,1,1);  % the first column represents the constant term;
    for j:=2:n do putv(mv,j,modular!-expt(val,getv(pv,isub1 j)));
            % first row is straight substitution;
    putv(sm,1,mv);
            % now for the rest of the rows:   ;
    for j:=2:n do <<
      mv:=mkvect n;
      putv(mv,1,0);
      construct!-matrix!-row(mv,isub1 j,pv,n,val);
      putv(sm,j,mv) >>
  end;

symbolic procedure construct!-matrix!-row(mrow,j,pv,n,val);
  begin scalar d;
    for k:=2:n do <<
      d:=getv(pv,isub1 k);  % degree representing the monomial;
      if d<j then putv(mrow,k,0)
      else <<
        d:=modular!-times(!*d2n binomial!-coefft!-mod!-p(d,j),
             modular!-expt(val,idifference(d,j)));
            % differentiate and substitute all at once;
        putv(mrow,k,d) >> >>
  end;

symbolic procedure print!-linear!-systems(soln!-m,correction!-v,
                                              predicted!-f,v);
<<
  for i:=1:number!-of!-factors do
    print!-linear!-system(i,soln!-m,correction!-v,predicted!-f,v);
  terpri!*(nil) >>;

symbolic procedure print!-linear!-system(i,soln!-m,correction!-v,
                                              predicted!-f,v);
  begin scalar pv,sm,cv,mr,n,tt;
    terpri!*(t);
    prin2!* " i = "; printstr i;
    terpri!*(nil);
    sm:=getv(soln!-m,i);
    cv:=getv(correction!-v,i);
      pv:=getv(predicted!-f,i);
      n:=iadd1 getv(pv,0);
      for j:=1:n do << % for each row in matrix ... ;
        prin2!* "(  ";
        tt:=2;
        mr:=getv(sm,j);  % matrix row;
      for k:=1:n do << % for each elt in row ... ;
          prin2!* getv(mr,k);
          ttab!* (tt:=tt+10) >>;
        prin2!* ")  ( [";
        if j=1 then prin2!* 1
        else prinsf adjoin!-term(mksp(v,getv(pv,isub1 j)),1,polyzero);
      prin2!* "]";
      ttab!* (tt:=tt+10);
      prin2!* " )";
      if j=(n/2) then prin2!* "  =  (  " else prin2!* "     (  ";
      prinsf getv(cv,j);
      ttab!* (tt:=tt+30); printstr ")";
      if not(j=n) then <<
        tt:=2;
        prin2!* "(";
        ttab!* (tt:=tt+n*10);
        prin2!* ")  (";
        ttab!* (tt:=tt+10);
        prin2!* " )     (";
        ttab!* (tt:=tt+30);
        printstr ")" >> >>;
    terpri!*(t)
  end;

symbolic procedure try!-prediction(sm,cv,pv,n,i,poly,v,ff,ffhat);
  begin scalar w,ffi,fhati;
    sm:=getv(sm,i);
    cv:=getv(cv,i);
    pv:=getv(pv,i);
    if not(n=iadd1 getv(pv,0)) then
      errorf list("Predicted unknowns gone wrong? ",n,iadd1 getv(pv,0));
    if null getm2(sm,1,0) then <<
      w:=lu!-factorize!-mod!-p(sm,n);
      if w='singular then <<
        factor!-trace <<
          prin2!* "Prediction for ";
          prin2!* if null ff then 'f else 'a;
          prin2!* "("; prin2!* i;
          printstr ") failed due to singular matrix." >>;
        return (w . i) >> >>;
    back!-substitute(sm,cv,n);
    w:=
      if null ff then try!-factor(poly,cv,pv,n,v)
      else <<
        ffi := getv(ff,i);
        fhati := getv(ffhat,i); % The unfolding here is to get round
                                % a bug in the PSL compiler 12/9/82. It
                                % will be tidied back up as soon as
                                % possible;
        try!-alpha(poly,cv,pv,n,v,ffi,fhati) >>;
    if w='bad!-prediction then <<
      factor!-trace <<
        prin2!* "Prediction for ";
        prin2!* if null ff then 'f else 'a;
        prin2!* "("; prin2!* i;
        printstr ") was an inadequate guess." >>;
      return (w . i) >>;
    factor!-trace <<
      prin2!* "Prediction for ";
      prin2!* if null ff then 'f else 'a;
      prin2!* "("; prin2!* i; prin2!* ") worked: ";
      printsf car w >>;
    return (i . w)
  end;

symbolic procedure try!-factor(poly,testv,predictedf,n,v);
  begin scalar r,w;
    r:=getv(testv,1);
    for j:=2:n do <<
      w:=!*f2mod adjoin!-term(mksp(v,getv(predictedf,isub1 j)),1,
                              polyzero);
      r:=plus!-mod!-p(r,times!-mod!-p(w,getv(testv,j))) >>;
    w:=quotient!-mod!-p(poly,r);
    if didntgo w or
      not polyzerop difference!-mod!-p(poly,times!-mod!-p(w,r)) then
      return 'bad!-prediction
    else return list(r,w)
  end;

symbolic procedure try!-alpha(poly,testv,predictedf,n,v,fi,fhati);
  begin scalar r,w,wr;
    r:=getv(testv,1);
    for j:=2:n do <<
      w:=!*f2mod adjoin!-term(mksp(v,getv(predictedf,isub1 j)),1,
                              polyzero);
      r:=plus!-mod!-p(r,times!-mod!-p(w,getv(testv,j))) >>;
    if polyzerop
      (wr:=difference!-mod!-p(poly,times!-mod!-p(r,fhati))) then
      return list (r,wr);
    w:=quotient!-mod!-p(wr,fi);
    if didntgo w or
      not polyzerop difference!-mod!-p(wr,times!-mod!-p(w,fi)) then
      return 'bad!-prediction
    else return list(r,wr)
  end;



endmodule;


module modpoly;

% Authors: A. C. Norman and P. M. A. Moore, 1979;

fluid '(current!-modulus
        exact!-quotient!-flag
        m!-image!-variable
        modulus!/2
        reduction!-count);


%**********************************************************************;
% routines for performing arithmetic on multivariate
% polynomials with coefficients that are modular
% numbers as defined by modular!-plus etc;

% note that the datastructure used is the same as that used in
% REDUCE except that it is assumed that domain elements are atomic;



symbolic procedure plus!-mod!-p(a,b);
% form the sum of the two polynomials a and b
% working over the ground domain defined by the routines
% modular!-plus, modular!-times etc. the inputs to this
% routine are assumed to have coefficients already
% in the required domain;
   if null a then b
   else if null b then a
   else if isdomain a then
      if isdomain b then !*num2f modular!-plus(a,b)
      else (lt b) .+ plus!-mod!-p(a,red b)
   else if isdomain b then (lt a) .+ plus!-mod!-p(red a,b)
   else if lpow a = lpow b then
      adjoin!-term(lpow a,
         plus!-mod!-p(lc a,lc b),plus!-mod!-p(red a,red b))
   else if comes!-before(lpow a,lpow b) then
         (lt a) .+ plus!-mod!-p(red a,b)
   else (lt b) .+ plus!-mod!-p(a,red b);



symbolic procedure times!-mod!-p(a,b);
   if (null a) or (null b) then nil
   else if isdomain a then multiply!-by!-constant!-mod!-p(b,a)
   else if isdomain b then multiply!-by!-constant!-mod!-p(a,b)
   else if mvar a=mvar b then plus!-mod!-p(
     plus!-mod!-p(times!-term!-mod!-p(lt a,b),
                  times!-term!-mod!-p(lt b,red a)),
     times!-mod!-p(red a,red b))
   else if ordop(mvar a,mvar b) then
     adjoin!-term(lpow a,times!-mod!-p(lc a,b),times!-mod!-p(red a,b))
   else adjoin!-term(lpow b,
        times!-mod!-p(a,lc b),times!-mod!-p(a,red b));


symbolic procedure times!-term!-mod!-p(term,b);
%multiply the given polynomial by the given term;
    if null b then nil
    else if isdomain b then
        adjoin!-term(tpow term,
            multiply!-by!-constant!-mod!-p(tc term,b),nil)
    else if tvar term=mvar b then
         adjoin!-term(mksp(tvar term,iplus(tdeg term,ldeg b)),
                      times!-mod!-p(tc term,lc b),
                      times!-term!-mod!-p(term,red b))
    else if ordop(tvar term,mvar b) then
      adjoin!-term(tpow term,times!-mod!-p(tc term,b),nil)
    else adjoin!-term(lpow b,
      times!-term!-mod!-p(term,lc b),
      times!-term!-mod!-p(term,red b));

symbolic procedure difference!-mod!-p(a,b);
   plus!-mod!-p(a,minus!-mod!-p b);

symbolic procedure minus!-mod!-p a;
   if null a then nil
   else if isdomain a then modular!-minus a
   else (lpow a .* minus!-mod!-p lc a) .+ minus!-mod!-p red a;


symbolic procedure reduce!-mod!-p a;
%converts a multivariate poly from normal into modular polynomial;
    if null a then nil
    else if isdomain a then !*num2f modular!-number a
    else adjoin!-term(lpow a,reduce!-mod!-p lc a,reduce!-mod!-p red a);

symbolic procedure monic!-mod!-p a;
% This procedure can only cope with polys that have a numeric
% leading coeff;
   if a=nil then nil
   else if isdomain a then 1
   else if lc a = 1 then a
   else if not domainp lc a then
       errorf "LC NOT NUMERIC IN MONIC-MOD-P"
   else multiply!-by!-constant!-mod!-p(a,
     modular!-reciprocal lc a);


symbolic procedure quotfail!-mod!-p(a,b);
% Form quotient A/B, but complain if the division is
% not exact;
  begin
    scalar c;
    exact!-quotient!-flag:=t;
    c:=quotient!-mod!-p(a,b);
    if exact!-quotient!-flag then return c
    else errorf "QUOTIENT NOT EXACT (MOD P)"
  end;

symbolic procedure quotient!-mod!-p(a,b);
% truncated quotient of a by b;
    if null b then errorf "B=0 IN QUOTIENT-MOD-P"
    else if isdomain b then multiply!-by!-constant!-mod!-p(a,
                             modular!-reciprocal b)
    else if a=nil then nil
    else if isdomain a then exact!-quotient!-flag:=nil
    else if mvar a=mvar b then xquotient!-mod!-p(a,b,mvar b)
    else if ordop(mvar a,mvar b) then
       adjoin!-term(lpow a,
          quotient!-mod!-p(lc a,b),
          quotient!-mod!-p(red a,b))
    else exact!-quotient!-flag:=nil;


symbolic procedure xquotient!-mod!-p(a,b,v);
% truncated quotient a/b given that b is nontrivial;
    if a=nil then nil
    else if (isdomain a) or (not mvar a=v) or
      ilessp(ldeg a,ldeg b) then exact!-quotient!-flag:=nil
    else if ldeg a = ldeg b then begin scalar w;
      w:=quotient!-mod!-p(lc a,lc b);
      if difference!-mod!-p(a,times!-mod!-p(w,b)) then
        exact!-quotient!-flag:=nil;
      return w
      end
    else begin scalar term;
      term:=mksp(mvar a,idifference(ldeg a,ldeg b)) .*
        quotient!-mod!-p(lc a,lc b);
%that is the leading term of the quotient. now subtract
%term*b from a;
      a:=plus!-mod!-p(red a,
                      times!-term!-mod!-p(negate!-term term,red b));
% or a:=a-b*term given leading terms must cancel;
      return term .+ xquotient!-mod!-p(a,b,v)
    end;

symbolic procedure negate!-term term;
% negate a term;
    tpow term .* minus!-mod!-p tc term;


symbolic procedure remainder!-mod!-p(a,b);
% remainder when a is divided by b;
    if null b then errorf "B=0 IN REMAINDER-MOD-P"
    else if isdomain b then nil
    else if isdomain a then a
    else xremainder!-mod!-p(a,b,mvar b);


symbolic procedure xremainder!-mod!-p(a,b,v);
% remainder when the modular polynomial a is
% divided by b, given that b is non degenerate;
   if (isdomain a) or (not mvar a=v) or ilessp(ldeg a,ldeg b) then a
   else begin
    scalar q,w;
    q:=quotient!-mod!-p(minus!-mod!-p lc a,lc b);
% compute -lc of quotient;
    w:=idifference(ldeg a,ldeg b); %ldeg of quotient;
    if w=0 then a:=plus!-mod!-p(red a,
      multiply!-by!-constant!-mod!-p(red b,q))
    else
      a:=plus!-mod!-p(red a,times!-term!-mod!-p(
            mksp(mvar b,w) .* q,red b));
% the above lines of code use red a and red b because
% by construction the leading terms of the required
% answers will cancel out;
     return xremainder!-mod!-p(a,b,v)
   end;

symbolic procedure multiply!-by!-constant!-mod!-p(a,n);
% multiply the polynomial a by the constant n;
   if null a then nil
   else if n=1 then a
   else if isdomain a then !*num2f modular!-times(a,n)
   else adjoin!-term(lpow a,multiply!-by!-constant!-mod!-p(lc a,n),
     multiply!-by!-constant!-mod!-p(red a,n));



symbolic procedure gcd!-mod!-p(a,b);
% return the monic gcd of the two modular univariate
% polynomials a and b. Set REDUCTION-COUNT to the number
% of steps taken in the process;
 << reduction!-count := 0;
    if null a then monic!-mod!-p b
    else if null b then monic!-mod!-p a
    else if isdomain a then 1
    else if isdomain b then 1
    else if igreaterp(ldeg a,ldeg b) then
      ordered!-gcd!-mod!-p(a,b)
    else ordered!-gcd!-mod!-p(b,a) >>;


symbolic procedure ordered!-gcd!-mod!-p(a,b);
% as above, but deg a > deg b;
  begin
    scalar steps;
    steps := 0;
top:
    a := reduce!-degree!-mod!-p(a,b);
    if null a then return monic!-mod!-p b;
    steps := steps + 1;
    if domainp a then <<
        reduction!-count := reduction!-count+steps;
        return 1 >>
    else if ldeg a<ldeg b then begin
      scalar w;
      reduction!-count := reduction!-count + steps;
      steps := 0;
      w := a; a := b; b := w
      end;
    go to top
  end;


symbolic procedure reduce!-degree!-mod!-p(a,b);
% Compute A-Q*B where Q is a single term chosen so that the result
% has lower degree than A did;
  begin
    scalar q,w;
    q:=modular!-quotient(modular!-minus lc a,lc b);
% compute -lc of quotient;
    w:=idifference(ldeg a,ldeg b); %ldeg of quotient;
% the next lines of code use red a and red b because
% by construction the leading terms of the required
% answers will cancel out;
    if w=0 then return plus!-mod!-p(red a,
      multiply!-by!-constant!-mod!-p(red b,q))
    else
      return plus!-mod!-p(red a,times!-term!-mod!-p(
            mksp(mvar b,w) .* q,red b))
   end;

symbolic procedure derivative!-mod!-p a;
% derivative of a wrt its main variable;
   if isdomain a then nil
   else if ldeg a=1 then lc a
   else derivative!-mod!-p!-1(a,mvar a);

symbolic procedure derivative!-mod!-p!-1(a,v);
    if isdomain a then nil
    else if not mvar a=v then nil
    else if ldeg a=1 then lc a
   else adjoin!-term(mksp(v,isub1 ldeg a),
                 multiply!-by!-constant!-mod!-p(lc a,
                                                modular!-number ldeg a),
                 derivative!-mod!-p!-1(red a,v));

symbolic procedure square!-free!-mod!-p a;
% predicate that tests if a is square-free as a modular
% univariate polynomial;
    if isdomain a then t
    else isdomain gcd!-mod!-p(a,derivative!-mod!-p a);


symbolic procedure evaluate!-mod!-p(a,v,n);
% evaluate polynomial A at the point V=N;
    if isdomain a then a
    else if n=0 then evaluate!-mod!-p(a,v,nil)
    else if v=nil then errorf "Variable=NIL in EVALUATE-MOD-P"
    else if mvar a=v then horner!-rule!-mod!-p(lc a,ldeg a,red a,n,v)
    else adjoin!-term(lpow a,
      evaluate!-mod!-p(lc a,v,n),
      evaluate!-mod!-p(red a,v,n));
 
symbolic procedure horner!-rule!-mod!-p(v,degg,a,n,var);
% v is the running total, and it must be multiplied by
% n**deg and added to the value of a at n;
    if isdomain a or not mvar a=var
      then if null n or zerop n then a
            else <<v:=times!-mod!-p(v,expt!-mod!-p(n,degg));
                   plus!-mod!-p(a,v)>>
    else begin
      scalar newdeg;
      newdeg:=ldeg a;
      return horner!-rule!-mod!-p(if null n or zerop n then lc a
                                   else plus!-mod!-p(lc a,
         times!-mod!-p(v,expt!-mod!-p(n,idifference(degg,newdeg)))),
       newdeg,red a,n,var)
    end;




symbolic procedure expt!-mod!-p(a,n);
% a**n;
    if n=0 then 1
    else if n=1 then a
    else begin
     scalar w,x;
     w:=divide(n,2);
     x:=expt!-mod!-p(a,car w);
     x:=times!-mod!-p(x,x);
     if not (cdr w = 0) then x:=times!-mod!-p(x,a);
     return x
    end;

symbolic procedure make!-bivariate!-mod!-p(u,imset,v);
% Substitute into U for all variables in IMSET which should result in
% a bivariate poly. One variable is M-IMAGE-VARIABLE and V is the other
% U is modular multivariate with these two variables at top 2 levels
% - V at 2nd level;
  if domainp u then u
  else if mvar u = m!-image!-variable then
    adjoin!-term(lpow u,make!-univariate!-mod!-p(lc u,imset,v),
      make!-bivariate!-mod!-p(red u,imset,v))
  else make!-univariate!-mod!-p(u,imset,v);

symbolic procedure make!-univariate!-mod!-p(u,imset,v);
% Substitute into U for all variables in IMSET giving a univariate
% poly in V. U is modular multivariate with V at top level;
  if domainp u then u
  else if mvar u = v then
    adjoin!-term(lpow u,!*num2f evaluate!-in!-order!-mod!-p(lc u,imset),
      make!-univariate!-mod!-p(red u,imset,v))
  else !*num2f evaluate!-in!-order!-mod!-p(u,imset);

symbolic procedure evaluate!-in!-order!-mod!-p(u,imset);
% makes an image of u wrt imageset, imset, using horner's rule. result
% should be purely numeric (and modular);
  if domainp u then !*d2n u
  else if mvar u=caar imset then
    horner!-rule!-in!-order!-mod!-p(
      evaluate!-in!-order!-mod!-p(lc u,cdr imset),ldeg u,red u,imset)
  else evaluate!-in!-order!-mod!-p(u,cdr imset);

symbolic procedure horner!-rule!-in!-order!-mod!-p(c,degg,a,vset);
% c is running total and a is what is left;
  if domainp a then modular!-plus(!*d2n a,
    modular!-times(c,modular!-expt(cdar vset,degg)))
  else if not(mvar a=caar vset) then
    modular!-plus(
      evaluate!-in!-order!-mod!-p(a,cdr vset),
      modular!-times(c,modular!-expt(cdar vset,degg)))
  else begin scalar newdeg;
    newdeg:=ldeg a;
    return horner!-rule!-in!-order!-mod!-p(
      modular!-plus(
        evaluate!-in!-order!-mod!-p(lc a,cdr vset),
        modular!-times(c,
          modular!-expt(cdar vset,(idifference(degg,newdeg))))),
      newdeg,red a,vset)
  end;

symbolic procedure make!-modular!-symmetric a;
% input is a multivariate MODULAR poly A with nos in the range 0->(p-1).
% This folds it onto the symmetric range (-p/2)->(p/2);
    if null a then nil
    else if domainp a then
      if a>modulus!/2 then !*num2f(a - current!-modulus)
      else a
    else adjoin!-term(lpow a,make!-modular!-symmetric lc a,
      make!-modular!-symmetric red a);

endmodule;


module multihen;

% Authors: A. C. Norman and P. M. A. Moore, 1979.

fluid '(!*overshoot
        !*trfac
        alphavec
        bad!-case
        factor!-level
        factor!-trace!-list
        fhatvec
        hensel!-growth!-size
        max!-unknowns
        number!-of!-factors
        number!-of!-unknowns
        predictions
        residue);


%**********************************************************************;
%    hensel construction for the multivariate case
%     (this version is highly recursive);



symbolic procedure find!-multivariate!-factors!-mod!-p(poly,
    best!-factors,variable!-set);
% All arithmetic is done mod p, best-factors is overwritten;
    if null variable!-set then best!-factors
    else (lambda factor!-level; begin
    scalar growth!-factor,b0s,res,correction!-factor,v,
           bhat0s,w,degbd,first!-time,redpoly,
           predicted!-forms,number!-of!-unknowns,solve!-count,
           correction!-vectors,soln!-matrices,max!-unknowns,
           unknowns!-count!-list,test!-prediction,poly!-remaining,
           prediction!-results,one!-prediction!-failed;
    v:=car variable!-set;
    degbd:=get!-degree!-bound car v;
    first!-time:=t;
    growth!-factor:=make!-growth!-factor v;
    poly!-remaining:=poly;
    prediction!-results:=mkvect number!-of!-factors;
    find!-msg1(best!-factors,growth!-factor,poly);
    b0s:=reduce!-vec!-by!-one!-var!-mod!-p(best!-factors,
                    v,number!-of!-factors);
            % The above made a copy of the vector;
    for i:=1:number!-of!-factors do
      putv(best!-factors,i,
        difference!-mod!-p(getv(best!-factors,i),getv(b0s,i)));
    redpoly:=evaluate!-mod!-p(poly,car v,cdr v);
    find!-msg2(v,variable!-set);
    find!-multivariate!-factors!-mod!-p(redpoly,b0s,cdr variable!-set);
            % answers in b0s;
    if bad!-case then return;
    for i:=1:number!-of!-factors do
      putv(best!-factors,i,
        plus!-mod!-p(getv(b0s,i),getv(best!-factors,i)));
    find!-msg3(best!-factors,v);
    res:=diff!-over!-k!-mod!-p(
        difference!-mod!-p(poly,
          times!-vector!-mod!-p(best!-factors,number!-of!-factors)),
        1,car v);
            % RES is the residue and must eventually be reduced to zero;
    factor!-trace << printsf res; terpri!*(nil) >>;
    if not polyzerop res and
      cdr variable!-set and not zerop cdr v then <<
      predicted!-forms:=make!-bivariate!-vec!-mod!-p(best!-factors,
        cdr variable!-set,car v,number!-of!-factors);
      find!-multivariate!-factors!-mod!-p(
        make!-bivariate!-mod!-p(poly,cdr variable!-set,car v),
        predicted!-forms,list v);
            % Answers in PREDICTED!-FORMS.
      find!-msg4(predicted!-forms,v);
      make!-predicted!-forms(predicted!-forms,car v);
            % Sets max!-unknowns and number!-of!-unknowns.
      find!-msg5();
      unknowns!-count!-list:=number!-of!-unknowns;
      while unknowns!-count!-list and
         (car (w:=car unknowns!-count!-list))=1 do
        begin scalar i,r;
          unknowns!-count!-list:=cdr unknowns!-count!-list;
          i:=cdr w;
          w:=quotient!-mod!-p(poly!-remaining,r:=getv(best!-factors,i));
          if didntgo w or
            not polyzerop difference!-mod!-p(poly!-remaining,
            times!-mod!-p(w,r)) then
            if one!-prediction!-failed then <<
              factor!-trace printstr "Predictions are no good";
              max!-unknowns:=nil >>
            else <<
              factor!-trace <<
                prin2!* "Guess for f(";
                prin2!* i;
                printstr ") was bad." >>;
              one!-prediction!-failed:=i >>
          else <<
            putv(prediction!-results,i,r);
            factor!-trace <<
              prin2!* "Prediction for f("; prin2!* i;
              prin2!* ") worked: ";
              printsf r >>;
            poly!-remaining:=w >>
        end;
      w:=length unknowns!-count!-list;
      if w=1 and not one!-prediction!-failed then <<
        putv(best!-factors,cdar unknowns!-count!-list,poly!-remaining);
        go to exit >>
      else if w=0 and one!-prediction!-failed then <<
        putv(best!-factors,one!-prediction!-failed,poly!-remaining);
        go to exit >>;
      solve!-count:=1;
      if max!-unknowns then
        correction!-vectors:=
           make!-correction!-vectors(best!-factors,max!-unknowns) >>;
    bhat0s:=make!-multivariate!-hatvec!-mod!-p(b0s,number!-of!-factors);
    correction!-factor:=growth!-factor;
            % next power of growth-factor we are
            % adding to the factors;
    % Now branch to another function to make this one not so huge.
    return find!-multi1(list(res,
                             test!-prediction,
                             growth!-factor,
                             first!-time,
                             bhat0s,
                             b0s,
                             variable!-set,
                             solve!-count,
                             correction!-vectors,
                             unknowns!-count!-list,
                             correction!-factor,
                             best!-factors,
                             v,
                             degbd,
                             soln!-matrices,
                             predicted!-forms,
                             poly!-remaining,
                             prediction!-results,
                             one!-prediction!-failed));
exit:
      find!-exit(best!-factors,first!-time);
  end) (factor!-level+1);

symbolic procedure find!-multi1(u);
   begin scalar res,test!-prediction,growth!-factor,first!-time,bhat0s,
              b0s,variable!-set,solve!-count,correction!-vectors,
              unknowns!-count!-list,correction!-factor,best!-factors,v,
              degbd,soln!-matrices,predicted!-forms,poly!-remaining,
              prediction!-results,one!-prediction!-failed,
              b1,bool,d,k,kk,substres,w;
      res := car u; u := cdr u;
      test!-prediction := car u; u := cdr u;
      growth!-factor := car u; u := cdr u;
      first!-time := car u; u := cdr u;
      bhat0s := car u; u := cdr u;
      b0s := car u; u := cdr u;
      variable!-set := car u; u := cdr u;
      solve!-count := car u; u := cdr u;
      correction!-vectors := car u; u := cdr u;
      unknowns!-count!-list := car u; u := cdr u;
      correction!-factor := car u; u := cdr u;
      best!-factors := car u; u := cdr u;
      v := car u; u := cdr u;
      degbd := car u; u := cdr u;
      soln!-matrices := car u; u := cdr u;
      predicted!-forms := car u; u := cdr u;
      poly!-remaining := car u; u := cdr u;
      prediction!-results := car u; u := cdr u;
      one!-prediction!-failed := car u;
      b1:=mkvect number!-of!-factors;
      k:=1;
      kk:=0;
temploop:
    bool := nil;
    while not bool and not polyzerop res and (null max!-unknowns
                  or null test!-prediction) do
      if k>degbd then <<
        factor!-trace <<
          prin2!* "We have overshot the degree bound for ";
          printvar car v >>;
        if !*overshoot then
          printc "Multivariate degree bound overshoot -> restart";
        bad!-case:= bool := t >>
      else
        if polyzerop(substres:=evaluate!-mod!-p(res,car v,cdr v))
        then <<
        k:=iadd1 k;
        res:=diff!-over!-k!-mod!-p(res,k,car v);
        correction!-factor:=
          times!-mod!-p(correction!-factor,growth!-factor) >>
      else begin
        find!-msg6(growth!-factor,first!-time,k,kk,substres);
        kk := kk#+1;
        if first!-time then first!-time := nil;
        solve!-for!-corrections(substres,bhat0s,b0s,b1,
                                cdr variable!-set);
            % Answers left in B1;
        if bad!-case then return (bool := t);
        if max!-unknowns then <<
          solve!-count:=iadd1 solve!-count;
          for i:=1:number!-of!-factors do
            putv(getv(correction!-vectors,i),solve!-count,getv(b1,i));
          if solve!-count=caar unknowns!-count!-list then
            test!-prediction:=t >>;
        factor!-trace <<
          printstr "   Giving:";
          printvec("     f(",number!-of!-factors,",1) = ",b1) >>;
        d:=times!-mod!-p(correction!-factor,
            terms!-done!-mod!-p(best!-factors,b1,correction!-factor));
        if degree!-in!-variable(d,car v)>degbd then <<
          factor!-trace <<
            prin2!* "We have overshot the degree bound for ";
            printvar car v >>;
          if !*overshoot then
            printc "Multivariate degree bound overshoot -> restart";
          bad!-case:=t;
          return (bool := t)>>;
        d:=diff!-k!-times!-mod!-p(d,k,car v);
        for i:=1:number!-of!-factors do
          putv(best!-factors,i,
            plus!-mod!-p(getv(best!-factors,i),
              times!-mod!-p(getv(b1,i),correction!-factor)));
        k:=iadd1 k;
        res:=diff!-over!-k!-mod!-p(difference!-mod!-p(res,d),k,car v);
        factor!-trace <<
        printstr "   New factors are now:";
        printvec("     f(",number!-of!-factors,") = ",best!-factors);
        prin2!* "   and residue = ";
        printsf res;
        printstr "-------------"
        >>;
        correction!-factor:=
          times!-mod!-p(correction!-factor,growth!-factor) end;
    if not polyzerop res and not bad!-case then <<
      soln!-matrices:=construct!-soln!-matrices(predicted!-forms,cdr v);
      factor!-trace <<
        printstr "We use the results from the Hensel growth to";
        printstr "produce a set of linear equations to solve";
        printstr "for coefficients in the relevent factors:" >>;
      bool := nil;
      while not bool and unknowns!-count!-list and
        (car (w:=car unknowns!-count!-list))=solve!-count do <<
        unknowns!-count!-list:=cdr unknowns!-count!-list;
        factor!-trace
          print!-linear!-system(cdr w,soln!-matrices,
            correction!-vectors,predicted!-forms,car v);
        w:=try!-prediction(soln!-matrices,correction!-vectors,
             predicted!-forms,car w,cdr w,poly!-remaining,car v,
             nil,nil);
        if car w='singular or car w='bad!-prediction then
          if one!-prediction!-failed then <<
            factor!-trace printstr "Predictions were no help.";
            max!-unknowns:=nil;
            bool := t>>
          else one!-prediction!-failed:=cdr w
        else <<
          putv(prediction!-results,car w,cadr w);
          poly!-remaining:=caddr w >> >>;
      if null max!-unknowns then goto temploop;
      w:=length unknowns!-count!-list;
      if w>1 or (w=1 and one!-prediction!-failed) then <<
        test!-prediction:=nil;
        goto temploop >>;
      if w=1 or one!-prediction!-failed then <<
        w:=if one!-prediction!-failed then one!-prediction!-failed
           else cdar unknowns!-count!-list;
        putv(prediction!-results,w,poly!-remaining) >>;
      for i:=1:number!-of!-factors do
        putv(best!-factors,i,getv(prediction!-results,i));
      if not one!-prediction!-failed then
        predictions:=
        (car v .
          list(soln!-matrices,predicted!-forms,max!-unknowns,
            number!-of!-unknowns))
        . predictions >>;
      find!-exit(best!-factors,first!-time);
   end;

symbolic procedure find!-msg1(best!-factors,growth!-factor,poly);
    factor!-trace <<
      printstr "Want f(i) s.t.";
      prin2!* "  product over i [ f(i) ] = ";
      prinsf poly;
      prin2!* " mod ";
      printstr hensel!-growth!-size;
      terpri!*(nil);
      printstr "We know f(i) as follows:";
      printvec("  f(",number!-of!-factors,") = ",best!-factors);
      prin2!* " and we shall put in powers of ";
      prinsf growth!-factor;
      printstr " to find them fully."
    >>;

symbolic procedure find!-msg2(v,variable!-set);
    factor!-trace <<
      prin2!*
         "First solve the problem in one less variable by putting ";
      prinvar car v; prin2!* "="; printstr cdr v;
      if cdr variable!-set then <<
        prin2!* "and growing wrt ";
        printvar caadr variable!-set
        >>;
      terpri!*(nil)
    >>;

symbolic procedure find!-msg3(best!-factors,v);
    factor!-trace <<
      prin2!* "After putting back any knowledge of ";
      prinvar car v;
      printstr ", we have the";
      printstr "factors so far as:";
      printvec("  f(",number!-of!-factors,") = ",best!-factors);
      printstr "Subtracting the product of these from the polynomial";
      prin2!* "and differentiating wrt "; prinvar car v;
      printstr " gives a residue:"
    >>;

symbolic procedure find!-msg4(predicted!-forms,v);
      factor!-trace <<
        printstr "To help reduce the number of Hensel steps we try";
        prin2!* "predicting how many terms each factor will have wrt ";
        prinvar car v; printstr ".";
        printstr
          "Predictions are based on the bivariate factors :";
        printvec("     f(",number!-of!-factors,") = ",predicted!-forms)
        >>;

symbolic procedure find!-msg5;
      factor!-trace <<
        terpri!*(nil);
        printstr "We predict :";
        for each w in number!-of!-unknowns do <<
          prin2!* car w;
          prin2!* " terms in f("; prin2!* cdr w; printstr '!) >>;
        if (caar number!-of!-unknowns)=1 then <<
          prin2!* "Since we predict only one term for f(";
          prin2!* cdar number!-of!-unknowns;
          printstr "), we can try";
          printstr "dividing it out now:" >>
        else <<
          prin2!* "So we shall do at least ";
          prin2!* isub1 caar number!-of!-unknowns;
          prin2!* " Hensel step";
          if (caar number!-of!-unknowns)=2 then printstr "."
          else printstr "s." >>;
        terpri!*(nil) >>;

symbolic procedure find!-msg6(growth!-factor,first!-time,k,kk,substres);
        factor!-trace <<
          prin2!* "Hensel Step "; printstr (kk:=kk #+ 1);
          prin2!* "-------------";
          if kk>10 then printstr "-" else terpri!*(t);
          prin2!* "Next corrections are for (";
          prinsf growth!-factor;
          if not (k=1) then <<
            prin2!* ") ** ";
            prin2!* k >> else prin2!* '!);
          printstr ". To find these we solve:";
          prin2!* "     sum over i [ f(i,1)*fhat(i,0) ] = ";
          prinsf substres;
          prin2!* " mod ";
          prin2!* hensel!-growth!-size;
          printstr " for f(i,1), ";
          if first!-time then <<
            prin2!*
               "       where fhat(i,0) = product over j [ f(j,0) ]";
            prin2!* " / f(i,0) mod ";
            printstr hensel!-growth!-size >>;
          terpri!*(nil)
        >>;

symbolic procedure find!-exit(best!-factors,first!-time);
    factor!-trace <<
      if not bad!-case then
        if first!-time then
          printstr "Therefore these factors are already correct."
        else <<
          printstr "Correct factors are:";
          printvec("  f(",number!-of!-factors,") = ",best!-factors)
        >>;
      terpri!*(nil);
      printstr "******************************************************";
      terpri!*(nil) >>;

symbolic procedure solve!-for!-corrections(c,fhatvec,fvec,resvec,vset);
% ....;
  if null vset then
    for i:=1:number!-of!-factors do
      putv(resvec,i,
        remainder!-mod!-p(
          times!-mod!-p(c,getv(alphavec,i)),
          getv(fvec,i)))
  else (lambda factor!-level; begin
    scalar residue,growth!-factor,f0s,fhat0s,v,
      correction!-factor,degbd,first!-time,redc,
      predicted!-forms,max!-unknowns,solve!-count,number!-of!-unknowns,
      correction!-vectors,soln!-matrices,w,previous!-prediction!-holds,
      unknowns!-count!-list,test!-prediction,poly!-remaining,
      prediction!-results,one!-prediction!-failed;
    v:=car vset;
    degbd:=get!-degree!-bound car v;
    first!-time:=t;
    growth!-factor:=make!-growth!-factor v;
    poly!-remaining:=c;
    prediction!-results:=mkvect number!-of!-factors;
    redc:=evaluate!-mod!-p(c,car v,cdr v);
    solve!-msg1(c,fvec,v);
    solve!-for!-corrections(redc,
      fhat0s:=reduce!-vec!-by!-one!-var!-mod!-p(
        fhatvec,v,number!-of!-factors),
      f0s:=reduce!-vec!-by!-one!-var!-mod!-p(
        fvec,v,number!-of!-factors),
      resvec,
      cdr vset); % Results left in RESVEC;
    if bad!-case then return;
    solve!-msg2(resvec,v);
    residue:=diff!-over!-k!-mod!-p(difference!-mod!-p(c,
          form!-sum!-and!-product!-mod!-p(resvec,fhatvec,
            number!-of!-factors)),1,car v);
    factor!-trace <<
      printsf residue;
      prin2!* " Now we shall put in the powers of ";
      prinsf growth!-factor;
      printstr " to find the a's fully."
    >>;
    if not polyzerop residue and not zerop cdr v then <<
      w:=atsoc(car v,predictions);
      if w then <<
        previous!-prediction!-holds:=t;
        factor!-trace <<
          printstr
             "We shall use the previous prediction for the form of";
          prin2!* "polynomials wrt "; printvar car v >>;
        w:=cdr w;
        soln!-matrices:=car w;
        predicted!-forms:=cadr w;
        max!-unknowns:=caddr w;
        number!-of!-unknowns:=cadr cddr w >>
      else <<
        factor!-trace <<
     printstr
        "We shall use a new prediction for the form of polynomials ";
        prin2!* "wrt "; printvar car v >>;
        predicted!-forms:=mkvect number!-of!-factors;
        for i:=1:number!-of!-factors do
          putv(predicted!-forms,i,getv(fvec,i));
            % make a copy of the factors in a vector that we shall
            % overwrite;
        make!-predicted!-forms(predicted!-forms,car v);
            % sets max!-unknowns and number!-of!-unknowns;
        >>;
      solve!-msg3();
      unknowns!-count!-list:=number!-of!-unknowns;
      while unknowns!-count!-list and
         (car (w:=car unknowns!-count!-list))=1 do
        begin scalar i,r,wr,fi;
          unknowns!-count!-list:=cdr unknowns!-count!-list;
          i:=cdr w;
          w:=quotient!-mod!-p(
            wr:=difference!-mod!-p(poly!-remaining,
              times!-mod!-p(r:=getv(resvec,i),getv(fhatvec,i))),
            fi:=getv(fvec,i));
          if didntgo w or not polyzerop
            difference!-mod!-p(wr,times!-mod!-p(w,fi)) then
            if one!-prediction!-failed then <<
              factor!-trace printstr "Predictions are no good.";
              max!-unknowns:=nil >>
            else <<
              factor!-trace <<
                prin2!* "Guess for a(";
                prin2!* i;
                printstr ") was bad." >>;
              one!-prediction!-failed:=i >>
          else <<
            putv(prediction!-results,i,r);
            factor!-trace <<
              prin2!* "Prediction for a("; prin2!* i;
              prin2!* ") worked: ";
              printsf r >>;
            poly!-remaining:=wr >>
        end;
      w:=length unknowns!-count!-list;
      if w=1 and not one!-prediction!-failed then <<
        putv(resvec,cdar unknowns!-count!-list,
          quotfail!-mod!-p(poly!-remaining,getv(fhatvec,
            cdar unknowns!-count!-list)));
        go to exit >>
      else if w=0 and one!-prediction!-failed then <<
        putv(resvec,one!-prediction!-failed,
          quotfail!-mod!-p(poly!-remaining,getv(fhatvec,
            one!-prediction!-failed)));
        go to exit >>;
      solve!-count:=1;
      if max!-unknowns then
        correction!-vectors:=
           make!-correction!-vectors(resvec,max!-unknowns) >>;
    correction!-factor:=growth!-factor;
    if not polyzerop residue then first!-time:=nil;
    % Now branch to another function to make this one not so huge.
    return solve!-for1(list(test!-prediction,
                            growth!-factor,
                            first!-time,
                            fhat0s,
                            f0s,
                            vset,
                            solve!-count,
                            correction!-vectors,
                            unknowns!-count!-list,
                            resvec,
                            correction!-factor,
                            v,
                            degbd,
                            soln!-matrices,
                            predicted!-forms,
                            poly!-remaining,
                            fvec,
                            prediction!-results,
                            previous!-prediction!-holds,
                            one!-prediction!-failed));
exit:
      solve!-exit(bad!-case,first!-time,resvec); 
  end) (factor!-level+1);

symbolic procedure solve!-for1 u;
   begin scalar test!-prediction,growth!-factor,first!-time,fhat0s,f0s,
            vset,solve!-count,correction!-vectors,unknowns!-count!-list,
            resvec,correction!-factor,v,degbd,soln!-matrices,
            predicted!-forms,poly!-remaining,fvec,prediction!-results,
            previous!-prediction!-holds,one!-prediction!-failed,
            bool,d,f1,k,kk,substres,w;
      test!-prediction := car u; u := cdr u;
      growth!-factor := car u; u := cdr u;
      first!-time := car u; u := cdr u;
      fhat0s := car u; u := cdr u;
      f0s := car u; u := cdr u;
      vset := car u; u := cdr u;
      solve!-count := car u; u := cdr u;
      correction!-vectors := car u; u := cdr u;
      unknowns!-count!-list := car u; u := cdr u;
      resvec := car u; u := cdr u;
      correction!-factor := car u; u := cdr u;
      v := car u; u := cdr u;
      degbd := car u; u := cdr u;
      soln!-matrices := car u; u := cdr u;
      predicted!-forms := car u; u := cdr u;
      poly!-remaining := car u; u := cdr u;
      fvec := car u; u := cdr u;
      prediction!-results := car u; u := cdr u;
      previous!-prediction!-holds := car u; u := cdr u;
      one!-prediction!-failed := car u;
      f1:=mkvect number!-of!-factors;
      k:=1;
      kk:=0;
temploop:
    bool := nil;
    while not bool and not polyzerop residue and (null max!-unknowns
                      or null test!-prediction) do
      if k>degbd then <<
        factor!-trace <<
          prin2!* "We have overshot the degree bound for ";
          printvar car v >>;
        if !*overshoot then
          printc "Multivariate degree bound overshoot -> restart";
        bad!-case:= bool := t >>
      else
        if polyzerop(substres:=evaluate!-mod!-p(residue,car v,cdr v))
         then <<
          k:=iadd1 k;
          residue:=diff!-over!-k!-mod!-p(residue,k,car v);
          correction!-factor:=
            times!-mod!-p(correction!-factor,growth!-factor) >>
      else begin
        solve!-msg4(growth!-factor,k,kk,substres);
        solve!-for!-corrections(substres,fhat0s,f0s,f1,cdr vset);
            % answers in f1;
        if bad!-case then return (bool := t);
        if max!-unknowns then <<
          solve!-count:=iadd1 solve!-count;
          for i:=1:number!-of!-factors do
            putv(getv(correction!-vectors,i),solve!-count,getv(f1,i));
          if solve!-count=caar unknowns!-count!-list then
            test!-prediction:=t >>;
        for i:=1:number!-of!-factors do
          putv(resvec,i,plus!-mod!-p(getv(resvec,i),times!-mod!-p(
            getv(f1,i),correction!-factor)));
        factor!-trace <<
          printstr "   Giving:";
          printvec("     a(",number!-of!-factors,",1) = ",f1);
          printstr "   New a's are now:";
          printvec("     a(",number!-of!-factors,") = ",resvec)
        >>;
         d:=times!-mod!-p(correction!-factor,
              form!-sum!-and!-product!-mod!-p(f1,fhatvec,
                number!-of!-factors));
        if degree!-in!-variable(d,car v)>degbd then <<
          factor!-trace <<
            prin2!* "We have overshot the degree bound for ";
            printvar car v >>;
          if !*overshoot then
            printc "Multivariate degree bound overshoot -> restart";
          bad!-case:=t;
          return (bool := t)>>;
        d:=diff!-k!-times!-mod!-p(d,k,car v);
        k:=iadd1 k;
        residue:=diff!-over!-k!-mod!-p(
             difference!-mod!-p(residue,d),k,car v);
        factor!-trace <<
          prin2!* "   and residue = ";
          printsf residue;
          printstr "-------------"
        >>;
        correction!-factor:=
          times!-mod!-p(correction!-factor,growth!-factor) end;
    if not polyzerop residue and not bad!-case then <<
      if null soln!-matrices then
        soln!-matrices:=
           construct!-soln!-matrices(predicted!-forms,cdr v);
      factor!-trace <<
        printstr "The Hensel growth so far allows us to test some of";
        printstr "our predictions:" >>;
      bool := nil;
      while not bool and unknowns!-count!-list and
        (car (w:=car unknowns!-count!-list))=solve!-count do <<
        unknowns!-count!-list:=cdr unknowns!-count!-list;
        factor!-trace
          print!-linear!-system(cdr w,soln!-matrices,
            correction!-vectors,predicted!-forms,car v);
        w:=try!-prediction(soln!-matrices,correction!-vectors,
          predicted!-forms,car w,cdr w,poly!-remaining,car v,fvec,
          fhatvec);
        if car w='singular or car w='bad!-prediction then
          if one!-prediction!-failed then <<
            factor!-trace printstr "Predictions were no help.";
            max!-unknowns:=nil;
            bool := t>>
          else <<
            if previous!-prediction!-holds then <<
              predictions:=delasc(car v,predictions);
              previous!-prediction!-holds:=nil >>;
            one!-prediction!-failed:=cdr w >>
        else <<
          putv(prediction!-results,car w,cadr w);
          poly!-remaining:=caddr w >> >>;
      if null max!-unknowns then <<
        if previous!-prediction!-holds then
          predictions:=delasc(car v,predictions);
        goto temploop >>;
      w:=length unknowns!-count!-list;
      if w>1 or (w=1 and one!-prediction!-failed) then <<
        test!-prediction:=nil;
        goto temploop >>;
      if w=1 or one!-prediction!-failed then <<
        w:=if one!-prediction!-failed then one!-prediction!-failed
           else cdar unknowns!-count!-list;
        putv(prediction!-results,w,quotfail!-mod!-p(
          poly!-remaining,getv(fhatvec,w))) >>;
      for i:=1:number!-of!-factors do
          putv(resvec,i,getv(prediction!-results,i));
      if not previous!-prediction!-holds
         and not one!-prediction!-failed then
        predictions:=
          (car v .
            list(soln!-matrices,predicted!-forms,max!-unknowns,
              number!-of!-unknowns))
          . predictions >>;
      solve!-exit(bad!-case,first!-time,resvec)
   end;

symbolic procedure solve!-msg1(c,fvec,v);
    factor!-trace <<
      printstr "Want a(i) s.t.";
      prin2!* "(*)  sum over i [ a(i)*fhat(i) ] = ";
      prinsf c;
      prin2!* " mod ";
      printstr hensel!-growth!-size;
      prin2!* "    where fhat(i) = product over j [ f(j) ]";
      prin2!* " / f(i) mod ";
      printstr hensel!-growth!-size;
      printstr "    and";
      printvec("      f(",number!-of!-factors,") = ",fvec);
      terpri!*(nil);
      prin2!*
         "First solve the problem in one less variable by putting ";
      prinvar car v; prin2!* '!=; printstr cdr v;
      terpri!*(nil)
    >>;

symbolic procedure solve!-msg2(resvec,v);
    factor!-trace <<
      printstr "Giving:";
      printvec("  a(",number!-of!-factors,",0) = ",resvec);
      printstr "Subtracting the contributions these give in (*) from";
      prin2!* "the R.H.S. of (*) ";
      prin2!* "and differentiating wrt "; prinvar car v;
      printstr " gives a residue:"
    >>;

symbolic procedure solve!-msg3;
      factor!-trace <<
        terpri!*(nil);
        printstr "We predict :";
        for each w in number!-of!-unknowns do <<
          prin2!* car w;
          prin2!* " terms in a("; prin2!* cdr w; printstr '!) >>;
        if (caar number!-of!-unknowns)=1 then <<
          prin2!* "Since we predict only one term for a(";
          prin2!* cdar number!-of!-unknowns;
          printstr "), we can test it right away:" >>
        else <<
          prin2!* "So we shall do at least ";
          prin2!* isub1 caar number!-of!-unknowns;
          prin2!* " Hensel step";
          if (caar number!-of!-unknowns)=2 then printstr "."
          else printstr "s." >>;
        terpri!*(nil) >>;

symbolic procedure solve!-msg4(growth!-factor,k,kk,substres);
        factor!-trace <<
          prin2!* "Hensel Step "; printstr (kk:=kk #+ 1);
          prin2!* "-------------";
          if kk>10 then printstr "-" else terpri!*(t);
          prin2!* "Next corrections are for (";
          prinsf growth!-factor;
          if not (k=1) then <<
            prin2!* ") ** ";
            prin2!* k >> else prin2!* '!);
          printstr ". To find these we solve:";
          prin2!* "     sum over i [ a(i,1)*fhat(i,0) ] = ";
          prinsf substres;
          prin2!* " mod ";
          prin2!* hensel!-growth!-size;
          printstr " for a(i,1). ";
          terpri!*(nil)
        >>;

symbolic procedure solve!-exit(bad!-case,first!-time,resvec); 
    factor!-trace <<
      if not bad!-case then
        if first!-time then
          printstr "But these a's are already correct."
        else <<
          printstr "Correct a's are:";
          printvec("  a(",number!-of!-factors,") = ",resvec)
        >>;
      terpri!*(nil);
      printstr "**************************************************";
      terpri!*(nil) >>;

endmodule;


module unihens;  % Univariate case of Hensel code with quadratic growth.

% Author: P. M. A. Moore, 1979.

fluid '(!*linear
        !*overshoot
        !*overview
        !*trfac
        alphalist
        alphavec
        coefftbd
        current!-factor!-product
        current!-modulus
        delfvec
        deltam
        factor!-level
        factor!-trace!-list
        factors!-done
        factorvec
        facvec
        fhatvec
        hensel!-growth!-size
        hensel!-poly
        irreducible
        m!-image!-variable
        modfvec
        multivariate!-input!-poly
        non!-monic
        number!-of!-factors
        polyzero
        prime!-base
        reconstructing!-gcd);

global '(largest!-small!-modulus);


symbolic procedure uhensel!.extend(poly,best!-flist,lclist,p);
% Extend poly=product(factors in best!-flist) mod p even if poly is
% non-monic.  Return a list (ok. list of factors) if factors can be
% extended to be correct over the integers, otherwise return a list
% (failed <reason> <reason>).
  begin scalar w,k,old!-modulus,alphavec,modular!-flist,factorvec,
        modfvec,coefftbd,fcount,fhatvec,deltam,mod!-symm!-flist,
        current!-factor!-product,facvec,factors!-done,hensel!-poly;
    prime!-base:=p;
    old!-modulus:=set!-modulus p;
%   timer:=readtime();
    number!-of!-factors:=length best!-flist;
    w:=expt(lc poly,number!-of!-factors -1);
    if lc poly < 0 then errorf list("LC SHOULD NOT BE -VE",poly);
    coefftbd:=max(110,p+1,lc poly*get!-coefft!-bound(poly,ldeg poly));
    poly:=multf(poly,w);
    modular!-flist:=for each ff in best!-flist collect
      reduce!-mod!-p ff;
            % Modular factors have been multiplied by a constant to
            % fix the l.c.'s, so they may be out of range - this
            % fixes that.
      if not(w=1) then factor!-trace <<
        prin2!* "Altered univariate polynomial: "; printsf poly >>;
          % Make sure the leading coefft will not cause trouble
          % in the hensel construction.
    mod!-symm!-flist:=for each ff in modular!-flist collect
      make!-modular!-symmetric ff;
    if not !*overview then factor!-trace <<
      prin2!* "The factors mod "; prin2!* p;
      printstr " to start from are:";
      fcount:=1;
      for each ff in mod!-symm!-flist do <<
        prin2!* "   f("; prin2!* fcount; prin2!* ")=";
        printsf ff; fcount:=iadd1 fcount >>;
      terpri!*(nil) >>;
    alphalist:=alphas(number!-of!-factors,modular!-flist,1);
            % 'magic' polynomials associated with the image factors.
    if not !*overview then factor!-trace <<
      printstr
         "The following modular polynomials are chosen such that:";
      terpri();
      prin2!* "   a(1)*h(1) + ... + a(";
      prin2!* number!-of!-factors;
      prin2!* ")*h("; prin2!* number!-of!-factors;
      prin2!* ") = 1 mod "; printstr p;
      terpri();
      printstr "  where h(i)=(product of all f(j) [see below])/f(i)";
      printstr "    and degree of a(i) < degree of f(i).";
      fcount:=1;
      for each a in modular!-flist do <<
        prin2!* "   a("; prin2!* fcount; prin2!* ")=";
        printsf cdr get!-alpha a;
        prin2!* "   f("; prin2!* fcount; prin2!* ")=";
        printsf a;
        fcount:=iadd1 fcount >>
    >>;
    k:=0;
    factorvec:=mkvect number!-of!-factors;
    modfvec:=mkvect number!-of!-factors;
    alphavec:=mkvect number!-of!-factors;
    for each modsymmf in mod!-symm!-flist do
      << putv(factorvec,k:=k+1,force!-lc(modsymmf,car lclist));
         lclist:=cdr lclist
      >>;
    k:=0;
    for each modfactor in modular!-flist do
         << putv(modfvec,k:=k+1,modfactor);
         putv(alphavec,k,cdr get!-alpha modfactor);
         >>;
            % best!-fvec is now a vector of factors of poly correct
            % mod p with true l.c.s forced in.
    fhatvec:=mkvect number!-of!-factors;
    w:=hensel!-mod!-p(poly,modfvec,factorvec,coefftbd,nil,p);
    if car w='overshot then w := uhensel!.extend1(poly,w)
     else w := uhensel!.extend2 w;
   set!-modulus old!-modulus;
    if irreducible then <<
      factor!-trace
         printstr "Two factors and overshooting means irreducible";
      return t >>;
    factor!-trace begin scalar k;
      k:=0;
      printstr "Univariate factors, possibly with adjusted leading";
      printstr "coefficients, are:";
      for each ww in cdr w do <<
        prin2!* " f("; prin2!* (k:=k #+ 1);
        prin2!* ")="; printsf ww >>
    end;
    return if non!-monic then
        (car w . primitive!.parts(cdr w,m!-image!-variable,t))
      else w
  end;
 
symbolic procedure uhensel!.extend1(poly,w);
      begin scalar oklist,badlist,m,r,ff,om,pol;
        m:=cadr w; % the modulus.
        r:=getv(factorvec,0); % the number of factors.
        if r=2 then return (irreducible:=t);
        if factors!-done then <<
          poly:=hensel!-poly;
          for each ww in factors!-done do
            poly:=multf(poly,ww) >>;
        pol:=poly;
        om:=set!-modulus hensel!-growth!-size;
        alphalist:=nil;
        for i:=r step -1 until 1 do
          alphalist:=
             (reduce!-mod!-p getv(factorvec,i) . getv(alphavec,i))
                      . alphalist;
        set!-modulus om;
            % bring alphalist up to date.
        for i:=1:r do <<
          ff:=getv(factorvec,i);
          if not didntgo(w:=quotf(pol,ff)) then
          << oklist:=ff . oklist; pol:=w>>
          else badlist:=(i . ff) . badlist >>;
        if null badlist then w:='ok . oklist
        else <<
          if not !*overview then factor!-trace <<
            printstr "Overshot factors are:";
            for each f in badlist do <<
              prin2!* " f("; prin2!* car f; prin2!* ")=";
              printsf cdr f >>
          >>;
          w:=try!.combining(badlist,pol,m,nil);
          if car w='one! bad! factor then begin scalar x;
            w:=append(oklist,cdr w);
            x:=1;
            for each v in w do x:=multf(x,v);
            w:='ok . (quotfail(pol,x) . w)
          end
          else w:='ok . append(oklist,w) >>;
        if (not !*linear) and multivariate!-input!-poly then <<
          poly:=1;
          number!-of!-factors:=0;
          for each facc in cdr w do <<
            poly:=multf(poly,facc);
            number!-of!-factors:=1 #+ number!-of!-factors >>;
            % make sure poly is the product of the factors we have,
            % we recalculate it this way because we may have the wrong
            % lc in old value of poly.
          reset!-quadratic!-step!-fluids(poly,cdr w,
                                         number!-of!-factors);
          if m=deltam then errorf list("Coefft bound < prime ?",
              coefftbd,m);
          m:=deltam*deltam;
          while m<largest!-small!-modulus do <<
            quadratic!-step(m,number!-of!-factors);
            m:=m*deltam >>;
          hensel!-growth!-size:=deltam;
          om:=set!-modulus hensel!-growth!-size;
          alphalist:=nil;
          for i:=number!-of!-factors step -1 until 1 do
            alphalist:=
              (reduce!-mod!-p getv(factorvec,i) . getv(alphavec,i))
                      . alphalist;
          set!-modulus om >>;
         return w
      end;

symbolic procedure uhensel!.extend2 w;
   begin scalar r,faclist,om;
      r:=getv(factorvec,0); % no of factors.
      om:=set!-modulus hensel!-growth!-size;
      alphalist:=nil;
      for i:=r step -1 until 1 do
        alphalist:=(reduce!-mod!-p getv(factorvec,i) . getv(alphavec,i))
                    . alphalist;
      set!-modulus om;
            % bring alphalist up to date.
      for i:=r step -1 until 1 do
        faclist:=getv(factorvec,i) . faclist;
      return (car w . faclist)
    end;
 
symbolic procedure get!-coefft!-bound(poly,ddeg);
% This uses Mignotte's bound which is minimal I believe.
% NB. poly had better be univariate as bound only valid for this.
  binomial!-coefft(ddeg/2,ddeg/4) * root!-squares(poly,0);

symbolic procedure binomial!-coefft(n,r);
  if n<r then nil
  else if n=r then 1
  else if r=1 then n
  else begin scalar n!-c!-r,b;
    n!-c!-r:=1;
    b:=min(r,n-r);
    for i:=1:b do
      n!-c!-r:=(n!-c!-r * (n - i + 1)) / i;
    return n!-c!-r
  end;

symbolic procedure pmam!-sqrt n;
% Find the square root of n and return integer part + 1.  N is fixed pt
% on input as it may be very large, i.e. > largest allowed floating pt
% number so I scale it appropriately.
  begin scalar s,ten!*!*6,ten!*!*12,ten!*!*14;
    s:=0;
    ten!*!*6:=10**6;
    ten!*!*12:=ten!*!*6**2;
    ten!*!*14:=100*ten!*!*12;
    while n>ten!*!*14 do << s:=iadd1 s; n:=1+n/ten!*!*12 >>;
    return ((fix sqrt!-float float n) + 1) * 10**(6*s)
  end;

symbolic procedure find!-alphas!-in!-a!-ring(n,mflist,fhatlist,gamma);
% Find the alphas (as below) given that the modulus may not be prime
% but is a prime power.
  begin scalar gg,m,ppow,i,gg!-mod!-p,modflist,wvec,alpha,alphazeros,w;
    if null prime!-base then errorf
      list("Prime base not set for finding alphas",
        current!-modulus,n,mflist);
    m:=set!-modulus prime!-base;
    modflist:= if m=prime!-base then mflist
      else for each fthing in mflist collect
        reduce!-mod!-p !*mod2f fthing;
    alphalist:=alphas(n,modflist,gamma);
    if m=prime!-base then <<
      set!-modulus m;
      return alphalist >>;
    i:=0;
    alphazeros:=mkvect n;
    wvec:=mkvect n;
    for each modfthing in modflist do <<
      putv(modfvec,i:=iadd1 i,modfthing);
      putv(alphavec,i,!*f2mod(alpha:=cdr get!-alpha modfthing));
      putv(alphazeros,i,alpha);
      putv(wvec,i,alpha);
      putv(fhatvec,i,car fhatlist);
      fhatlist:=cdr fhatlist >>;
    gg:=gamma;
    ppow:=prime!-base;
    while ppow<m do <<
      set!-modulus m;
      gg:=!*f2mod quotfail(!*mod2f difference!-mod!-p(gg,
          form!-sum!-and!-product!-mod!-m(wvec,fhatvec,n)),prime!-base);
      set!-modulus prime!-base;
      gg!-mod!-p:=reduce!-mod!-p !*mod2f gg;
      for k:=1:n do <<
        putv(wvec,k,w:=remainder!-mod!-p(
          times!-mod!-p(getv(alphazeros,k),gg!-mod!-p),
          getv(modfvec,k)));
        putv(alphavec,k,addf(getv(alphavec,k),multf(!*mod2f w,ppow)))>>;
      ppow:=ppow*prime!-base >>;
    set!-modulus m;
    i:=0;
    return (for each fthing in mflist collect
      (fthing . !*f2mod getv(alphavec,i:=iadd1 i)))
  end;

symbolic procedure alphas(n,flist,gamma);
% Finds alpha,beta,delta,... wrt factors f(i) in flist s.t.
%  alpha*g(1) + beta*g(2) + delta*g(3) + ... = gamma mod p,
% where g(i)=product(all the f(j) except f(i) itself).
% (cf. xgcd!-mod!-p below). n is number of factors in flist.
  if n=1 then list(car flist . gamma)
  else begin scalar k,w,f1,f2,i,gamma1,gamma2;
    k:=n/2;
    f1:=1; f2:=1;
    i:=1;
    for each f in flist do
    << if i>k then f2:=times!-mod!-p(f,f2)
       else f1:=times!-mod!-p(f,f1);
       i:=i+1 >>;
    w:=xgcd!-mod!-p(f1,f2,1,polyzero,polyzero,1);
    if atom w then
      return 'factors! not! coprime;
    gamma1:=remainder!-mod!-p(times!-mod!-p(cdr w,gamma),f1);
    gamma2:=remainder!-mod!-p(times!-mod!-p(car w,gamma),f2);
    i:=1; f1:=nil; f2:=nil;
    for each f in flist do
    << if i>k then f2:=f . f2
       else f1:=f . f1;
       i:=i+1 >>;
    return append(
      alphas(k,f1,gamma1),
      alphas(n-k,f2,gamma2))
  end;

symbolic procedure xgcd!-mod!-p(a,b,x1,y1,x2,y2);
% Finds alpha and beta s.t. alpha*a+beta*b=1.
% Returns alpha . beta or nil if a and b are not coprime.
    if null b then nil
    else if isdomain b then begin
        b:=modular!-reciprocal b;
        x2:=multiply!-by!-constant!-mod!-p(x2,b);
        y2:=multiply!-by!-constant!-mod!-p(y2,b);
        return x2 . y2 end
    else begin scalar q;
        q:=quotient!-mod!-p(a,b); % Truncated quotient here.
        return xgcd!-mod!-p(b,difference!-mod!-p(a,times!-mod!-p(b,q)),
            x2,y2,
            difference!-mod!-p(x1,times!-mod!-p(x2,q)),
            difference!-mod!-p(y1,times!-mod!-p(y2,q)))
        end;

symbolic procedure hensel!-mod!-p(poly,mvec,fvec,cbd,vset,p);
% Hensel construction building up in powers of p.
% Given that poly=product(factors in factorvec) mod p, find the full
% factors over the integers.  Mvec contains the univariate factors mod p
% while fvec contains our best knowledge of the factors to date.
% Fvec includes leading coeffts (and in multivariate case possibly other
% coeffts) of the factors. return a list whose first element is a flag
% with one of the following values:
%  ok        construction worked, the cdr of the result is a list of
%            the correct factors.
%  failed    inputs must have been incorrect
%  overshot  factors are correct mod some power of p (say p**m),
%            but are not correct over the integers.
%            result is (overshot,p**m,list of factors so far).
  begin scalar w,u0,delfvec,old!.mod,res,m;
    u0:=initialize!-hensel(number!-of!-factors,p,poly,mvec,fvec,cbd);
            % u0 contains the product (over integers) of factors mod p.
    m := p;
    old!.mod := set!-modulus nil;
    if number!-of!-factors=1 
      then <<putv(fvec,1,current!-factor!-product:=poly);
             % Added JHD 28.9.87
             return hensel!-exit(m,old!.mod,p,vset,w)>>;
            % only one factor to grow! but need to go this deep to
            % construct the alphas and set things up for the
            % multivariate growth which may follow.
    hensel!-msg1(p,u0);
    old!.mod:=set!-modulus p;
    res:=addf(hensel!-poly,negf u0);
            % calculate the residue. from now on this is always
            % kept in res.
    m:=p;
            % measure of how far we have built up factors - at this
            % stage we know the constant terms mod p in the factors.
   a: if polyzerop res then return hensel!-exit(m,old!.mod,p,vset,w);
      if (m/2)>coefftbd then
        <<
            % we started with a false split of the image so some
            % of the factors we have built up must amalgamate in
            % the complete factorization.
          if !*overshoot then <<
            prin2 if null vset then "Univariate " else "Multivariate ";
            printc "coefft bound overshoot" >>;
          if not !*overview then
        factor!-trace printstr "We have overshot the coefficient bound";
          return hensel!-exit(m,old!.mod,p,vset,'overshot)>>;
      res:=quotfail(res,deltam);
            % next term in residue.
      if not !*overview then factor!-trace <<
        prin2!* "Residue divided by "; prin2!* m; prin2!* " is ";
        printsf res >>;
      if (not !*linear) and null vset
        and m<=largest!-small!-modulus and m>p then
        quadratic!-step(m,number!-of!-factors);
      w:=reduce!-mod!-p res;
      if not !*overview then factor!-trace <<
          prin2!* "Next term in residue to kill is:";
          prinsf w; prin2!* " which is of size ";
          printsf (deltam*m);
          >>;
      solve!-for!-corrections(w,fhatvec,modfvec,delfvec,vset);
            % delfvec is vector of next correction terms to factors.
      make!-vec!-modular!-symmetric(delfvec,number!-of!-factors);
      if not !*overview then factor!-trace <<
        printstr "Correction terms are:";
        w:=1;
        for i:=1:number!-of!-factors do <<
          prin2!* "  To f("; prin2!* w; prin2!* "): ";
          printsf multf(m,getv(delfvec,i));
          w:=iadd1 w >>;
      >>;
      w:=terms!-done(factorvec,delfvec,m);
      res:=addf(res,negf w);
            % subtract out the terms generated by these corrections
            % from the residue.
      current!-factor!-product:=
         addf(current!-factor!-product,multf(m,w));
            % add in the correction terms to give new factor product.
      for i:=1:number!-of!-factors do
        putv(factorvec,i,
          addf(getv(factorvec,i),multf(getv(delfvec,i),m)));
            % add the corrections into the factors.
      if not !*overview then factor!-trace <<
        printstr "   giving new factors as:";
        w:=1;
        for i:=1:number!-of!-factors do <<
          prin2!* " f("; prin2!* w; prin2!* ")=";
          printsf getv(factorvec,i); w:=iadd1 w >>
        >>;
      m:=m*deltam;
      if not polyzerop res and null vset and
        not reconstructing!-gcd then
        begin scalar j,u,fac;
          j:=0;
          while (j:=j #+ 1)<=number!-of!-factors do
%            IF NULL GETV(DELFVEC,J) AND
            % - Try dividing out every time for now.
            if not didntgo
              (u:=quotf(hensel!-poly,fac:=getv(factorvec,j))) then <<
              hensel!-poly:=u;
              res:=adjust!-growth(fac,j,m);
              j:=number!-of!-factors >>
        end;
      go to a
  end;

symbolic procedure hensel!-exit(m,old!.mod,p,vset,w);
   begin
    if factors!-done then <<
      if not(w='overshot) then m:=p*p;
      set!-hensel!-fluids!-back p >>;
    if (not (w='overshot)) and null vset
      and (not !*linear) and multivariate!-input!-poly then
      while m<largest!-small!-modulus do <<
        if not(m=deltam) then quadratic!-step(m,number!-of!-factors);
        m:=m*deltam >>;
            % set up the alphas etc so that multivariate growth can
            % use a Hensel growth size of about word size.
    set!-modulus old!.mod;
            % reset the old modulus.
    hensel!-growth!-size:=deltam;
    putv(factorvec,0,number!-of!-factors);
    return
      if w='overshot then list('overshot,m,factorvec)
      else 'ok . factorvec
  end;

symbolic procedure hensel!-msg1(p,u0);
   begin scalar w;
    factor!-trace <<
      printstr
         "We are now ready to use the Hensel construction to grow";
      prin2!* "in powers of "; printstr current!-modulus;
      if not !*overview then <<prin2!* "Polynomial to factor (=U): ";
        printsf hensel!-poly>>;
      prin2!* "Initial factors mod "; prin2!* p;
      printstr " with some correct coefficients:";
      w:=1;
      for i:=1:number!-of!-factors do <<
        prin2!* " f("; prin2!* w; prin2!* ")=";
        printsf getv(factorvec,i); w:=iadd1 w >>;
      if not !*overview then << prin2!* "Coefficient bound = ";
        prin2!* coefftbd;
      terpri!*(nil);
      prin2!* "The product of factors over the integers is ";
      printsf u0;
      printstr "In each step below, the residue is U - (product of the";
      printstr
         "factors as far as we know them). The correction to each";
      printstr "factor, f(i), is (a(i)*v) mod f0(i) where f0(i) is";
      prin2!* "f(i) mod "; prin2!* p;
      printstr "(ie. the f(i) used in calculating the a(i))"
      >>>>
   end;

symbolic procedure initialize!-hensel(r,p,poly,mvec,fvec,cbd);
% Set up the vectors and initialize the fluids.
  begin scalar u0;
    delfvec:=mkvect r;
    facvec:=mkvect r;
    hensel!-poly:=poly;
    modfvec:=mvec;
    factorvec:=fvec;
    coefftbd:=cbd;
    factors!-done:=nil;
    deltam:=p;
    u0:=1;
    for i:=1:r do u0:=multf(getv(factorvec,i),u0);
    current!-factor!-product:=u0;
    return u0
  end;

% symbolic procedure reset!-quadratic!-step!-fluids(poly,faclist,n);
%   begin scalar i,om,modf;
%     current!-factor!-product:=poly;
%     om:=set!-modulus hensel!-growth!-size;
%     i:=0;
%     for each fac in faclist do <<
%       putv(factorvec,i:=iadd1 i,fac);
%       putv(modfvec,i,modf:=reduce!-mod!-p fac);
%       putv(alphavec,i,cdr get!-alpha modf) >>;
%      for i:=1:n do <<
%        prin2 "F("; % prin2 i; % prin2 ") = ";
%        printsf getv(factorvec,i);
%        prin2 "F("; % prin2 i; % prin2 ") MOD P = ";
%        printsf getv(modfvec,i);
%        prin2 "A("; % prin2 i; % prin2 ") = ";
%        printsf getv(alphavec,i) >>;
%     set!-modulus om
%   end;

symbolic procedure reset!-quadratic!-step!-fluids(poly,faclist,n);
  begin scalar i,om,facpairlist,cfp!-mod!-p,fhatlist;
    current!-factor!-product:=poly;
    om:=set!-modulus hensel!-growth!-size;
    cfp!-mod!-p:=reduce!-mod!-p current!-factor!-product;
    i:=0;
    facpairlist:=for each fac in faclist collect <<
      i:= i #+ 1;
      (fac . reduce!-mod!-p fac) >>;
    fhatlist:=for each facc in facpairlist collect
      quotfail!-mod!-p(cfp!-mod!-p,cdr facc);
    if factors!-done then alphalist:=
      find!-alphas!-in!-a!-ring(i,
        for each facpr in facpairlist collect cdr facpr,
        fhatlist,1);
          % a bug has surfaced such that the alphas get out of step.
          % In this case so recalculate them to stop the error for now.
    i:=0;
    for each facpair in facpairlist do <<
      putv(factorvec,i:=iadd1 i,car facpair);
      putv(modfvec,i,cdr facpair);
      putv(alphavec,i,cdr get!-alpha cdr facpair) >>;
%      for i:=1:n do <<
%        prin2 "f("; % prin2 i; % prin2 ") = ";
%        printsf getv(factorvec,i);
%        prin2 "f("; % prin2 i; % prin2 ") mod p = ";
%        printsf getv(modfvec,i);
%        prin2 "a("; % prin2 i; % prin2 ") = ";
%        printsf getv(alphavec,i) >>;
    set!-modulus om
  end;

symbolic procedure quadratic!-step(m,r);
% Code for adjusting the hensel variables to take quadratic steps in
% the growing process.
  begin scalar w,s,cfp!-mod!-p;
    set!-modulus m;
    cfp!-mod!-p:=reduce!-mod!-p current!-factor!-product;
    for i:=1:r do putv(facvec,i,reduce!-mod!-p getv(factorvec,i));
    for i:=1:r do putv(fhatvec,i,
      quotfail!-mod!-p(cfp!-mod!-p,getv(facvec,i)));
    w:=form!-sum!-and!-product!-mod!-m(alphavec,fhatvec,r);
    w:=!*mod2f plus!-mod!-p(1,minus!-mod!-p w);
    s:=quotfail(w,deltam);
    set!-modulus deltam;
    s:=!*f2mod s;
            % Boxes S up to look like a poly mod deltam.
    for i:=1:r do <<
      w:=remainder!-mod!-p(times!-mod!-p(s,getv(alphavec,i)),
        getv(modfvec,i));
      putv(alphavec,i,
        addf(!*mod2f getv(alphavec,i),multf(!*mod2f w,deltam))) >>;
    s:=modfvec;
    modfvec:=facvec;
    facvec:=s;
    deltam:=m;
            % this is our new growth rate.
    set!-modulus deltam;
    for i:=1:r do <<
      putv(facvec,i,"RUBBISH");
            % we will want to overwrite facvec next time so we
            % had better point it to the old (no longer needed)
            % modvec. Also mark it as containing rubbish for safety.
      putv(alphavec,i,!*f2mod getv(alphavec,i)) >>;
            % Make sure the alphas are boxed up as being mod new deltam.
    if not !*overview then factor!-trace <<
      printstr "The new modular polynomials are chosen such that:";
      terpri();
      prin2!* "   a(1)*h(1) + ... + a(";
      prin2!* r;
      prin2!* ")*h("; prin2!* r;
      prin2!* ") = 1 mod "; printstr m;
      terpri();
      printstr "  where h(i)=(product of all f(j) [see below])/f(i)";
      printstr "    and degree of a(i) < degree of f(i).";
      for i:=1:r do <<
        prin2!* "  a("; prin2!* i; prin2!* ")=";
        printsf getv(alphavec,i);
        prin2!* "   f("; prin2!* i; prin2!* ")=";
        printsf getv(modfvec,i) >>
    >>
  end;

symbolic procedure terms!-done(fvec,delfvec,m);
  begin scalar flist,delflist;
    for i:=1:number!-of!-factors do <<
      flist:=getv(fvec,i) . flist;
      delflist:=getv(delfvec,i) . delflist >>;
    return terms!.done(number!-of!-factors,flist,delflist,
                                 number!-of!-factors,m)
  end;

symbolic procedure terms!.done(n,flist,delflist,r,m);
  if n=1 then (car flist) . (car delflist)
  else begin scalar k,i,f1,f2,delf1,delf2;
    k:=n/2; i:=1;
    for each f in flist do
    << if i>k then f2:=(f . f2)
       else f1:=(f . f1);
       i:=i+1 >>;
    i:=1;
    for each delf in delflist do
    << if i>k then delf2:=(delf . delf2)
       else delf1:=(delf . delf1);
       i:=i+1 >>;
    f1:=terms!.done(k,f1,delf1,r,m);
    delf1:=cdr f1; f1:=car f1;
    f2:=terms!.done(n-k,f2,delf2,r,m);
    delf2:=cdr f2; f2:=car f2;
    delf1:=
      addf(addf(
        multf(f1,delf2),
        multf(f2,delf1)),
        multf(multf(delf1,m),delf2));
    if n=r then return delf1;
    return (multf(f1,f2) . delf1)
  end;

symbolic procedure try!.combining(l,poly,m,sofar);
% l is a list of factors, f(i), s.t. (product of the f(i) mod m) = poly
% but no f(i) divides poly over the integers.  We find the combinations
% of the f(i) that yield the true factors of poly over the integers.
% Sofar is a list of these factors found so far.
  if poly=1 then
    if null l then sofar
    else errorf(list("TOO MANY BAD FACTORS:",l))
  else begin scalar k,n,res,ff,v,w,w1,combined!.factors,ll;
    n:=length l;
    if n=1 then
      if ldeg car l > (ldeg poly)/2 then
        return ('one! bad! factor . sofar)
      else errorf(list("ONE BAD FACTOR DOES NOT FIT:",l));
    if n=2 or n=3 then <<
      w:=lc cdar l; % The LC of all the factors is the same.
      while not (w=lc poly) do poly:=quotfail(poly,w);
            % poly's LC may be a higher power of w than we want
            % and we must return a result with the same
            % LC as each of the combined factors.
      if not !*overview then factor!-trace <<
        printstr "We combine:";
         for each lf in l do printsf cdr lf;
         prin2!* " mod "; prin2!* m;
         printstr " to give correct factor:";
         printsf poly >>;
       combine!.alphas(l,t);
       return (poly . sofar) >>;
    ll:=for each ff in l collect (cdr ff . car ff);
    k := 2;
  loop1:
      if k > n/2 then go to exit;
      w:=koutof(k,if 2*k=n then cdr l else l,nil);
      while w and (v:=factor!-trialdiv(poly,car w,m,ll))='didntgo do
      << w:=cdr w;
        while w and
            ((car w = '!*lazyadjoin) or (car w = '!*lazykoutof)) do
          if car w= '!*lazyadjoin then
            w:=lazy!-adjoin(cadr w,caddr w,cadr cddr w)
          else w:=koutof(cadr w,caddr w,cadr cddr w)
        >>;
      if not(v='didntgo) then <<
        ff:=car v; v:=cdr v;
        if not !*overview then factor!-trace <<
          printstr "We combine:";
           for each a in car w do printsf a;
         prin2!* " mod "; prin2!* m;
         printstr " to give correct factor:";
         printsf ff >>;
       for each a in car w do <<
         w1:=l;
         while not (a = cdar w1) do w1:=cdr w1;
         combined!.factors:=car w1 . combined!.factors;
         l:=delete(car w1,l) >>;
       combine!.alphas(combined!.factors,t);
       res:=try!.combining(l,v,m,ff . sofar);
       go to exit>>;
    k := k + 1;
    go to loop1;
  exit:
    if res then return res
    else <<
      w:=lc cdar l; % The LC of all the factors is the same.
      while not (w=lc poly) do poly:=quotfail(poly,w);
            % poly's LC may be a higher power of w than we want
            % and we must return a result with the same
            % LC as each of the combined factors.
      if not !*overview then factor!-trace <<
        printstr "We combine:";
          for each ff in l do printsf cdr ff;
          prin2!* " mod "; prin2!* m;
          printstr " to give correct factor:";
          printsf poly >>;
      combine!.alphas(l,t);
      return (poly . sofar) >>
  end;

symbolic procedure koutof(k,l,sofar);
% Produces all permutations of length k from list l accumulating them
% in sofar as we go.  We use lazy evaluation in that this results in
% a permutation dotted with:
%   ( '!*lazy . (argument for eval) )
%  except when k=1 when the permutations are explicitly given.
  if k=1 then append(
    for each f in l collect list cdr f,sofar)
  else if k>length l then sofar
  else <<
    while eqcar(l,'!*lazyadjoin) or eqcar(l,'!*lazykoutof) do
      if car l='!*lazyadjoin then
        l := lazy!-adjoin(cadr l,caddr l,cadr cddr l)
      else l := koutof(cadr l,caddr l,cadr cddr l);
    if k=length l then
      (for each ll in l collect cdr ll ) . sofar
    else koutof(k,cdr l,
      list('!*lazyadjoin,cdar l,
        list('!*lazykoutof,(k-1),cdr l,nil),
         sofar)) >>;

symbolic procedure lazy!-adjoin(item,l,tail);
% Dots item with each element in l using lazy evaluation on l.
% If l is null tail results.
 << while eqcar(l,'!*lazyadjoin) or eqcar(l,'!*lazykoutof) do
      if car l ='!*lazyadjoin then
        l:=lazy!-adjoin(cadr l,caddr l,cadr cddr l)
      else l:=koutof(cadr l,caddr l,cadr cddr l);
    if null l then tail
    else (item . car l) .
     if null cdr l then tail
     else list('!*lazyadjoin,item,cdr l,tail) >>;

symbolic procedure factor!-trialdiv(poly,flist,m,llist);
% Combines the factors in FLIST mod M and test divides the result
% into POLY (over integers) to see if it goes. If it doesn't
% then DIDNTGO is returned, else the pair (D . Q) is
% returned where Q is the quotient obtained and D is the product
% of the factors mod M.
  if polyzerop poly then errorf "Test dividing into zero?"
  else begin scalar d,q;
    d:=combine(flist,m,llist);
    if didntgo(q:=quotf(poly,car d)) then <<
      factor!-trace printstr " it didn't go (division fail)";
      return 'didntgo >>
    else <<
      factor!-trace printstr " it worked !";
      return (car d . quotf(q,cdr d)) >>
  end;

symbolic procedure combine(flist,m,l);
% Multiply factors in flist mod m.
% L is a list of the factors for use in FACTOR!-TRACE.
  begin scalar om,res,w,lcf,lcfinv,lcfprod;
    factor!-trace <<
      prin2!* "We combine factors ";
      for each ff in flist do <<
        w:=assoc(ff,l);
        prin2!* "f(";
        prin2!* cdr w;
        prin2!* "), " >> ;
      prin2!* "and try dividing : " >>;
    lcf := lc car flist; % all leading coeffts should be the same.
    lcfprod := 1;
% This is one of only two places in the entire factorizer where
% it is ever necessary to use a modulus larger than word-size.
    if m>largest!-small!-modulus then <<
      om:=set!-general!-modulus m;
      lcfinv := general!-modular!-reciprocal lcf;
      res:=general!-reduce!-mod!-p car flist;
      for each ff in cdr flist do <<
        if not lcf=lc ff then errorf "BAD LC IN FLIST";
        res:=general!-times!-mod!-p(
            general!-times!-mod!-p(lcfinv,
                general!-reduce!-mod!-p ff),res);
        lcfprod := lcfprod*lcf >>;
      res:=general!-make!-modular!-symmetric res;
      set!-modulus om;
      return (res . lcfprod) >>
    else <<
      om:=set!-modulus m;
      lcfinv := modular!-reciprocal lcf;
      res:=reduce!-mod!-p car flist;
      for each ff in cdr flist do <<
        if not lcf=lc ff then errorf "BAD LC IN FLIST";
        res:=times!-mod!-p(times!-mod!-p(lcfinv,reduce!-mod!-p ff),res);
        lcfprod := lcfprod*lcf >>;
      res:=make!-modular!-symmetric res;
      set!-modulus om;
      return (res . lcfprod) >>
  end;

symbolic procedure combine!.alphas(flist,fixlcs);
% Combine the alphas associated with each of these factors to
% give the one alpha for their combination.
  begin scalar f1,a1,ff,aa,oldm,lcfac,lcfinv,saveflist;
    oldm:=set!-modulus hensel!-growth!-size;
    flist:=for each fac in flist collect <<
      saveflist:= (reduce!-mod!-p cdr fac) . saveflist;
      (car fac) . car saveflist >>;
    if fixlcs then <<
        lcfinv:=modular!-reciprocal lc cdar flist;
        lcfac:=modular!-expt(lc cdar flist,sub1 length flist)
      >>
      else << lcfinv:=1; lcfac:=1 >>;
            % If FIXLCS is set then we have combined n factors
            % (each with the same l.c.) to give one and we only need one
            % l.c. in the result, we have divided the combination by
            % lc**(n-1) and we must be sure to do the same for the
            % alphas.
    ff:=cdar flist;
    aa:=cdr get!-alpha ff;
    flist:=cdr flist;
    while flist do <<
      f1:=cdar flist;
      a1:=cdr get!-alpha f1;
      flist:=cdr flist;
      aa:=plus!-mod!-p(times!-mod!-p(aa,f1),times!-mod!-p(a1,ff));
      ff:=times!-mod!-p(ff,f1)
    >>;
    for each a in alphalist do
      if not member(car a,saveflist) then
        flist:=(car a . times!-mod!-p(cdr a,lcfac)) . flist;
    alphalist:=(quotient!-mod!-p(ff, lcfac) . aa) . flist;
    set!-modulus oldm
  end;

% The following code is for dividing out factors in the middle
% of the Hensel construction and adjusting all the associated
% variables that go with it.


symbolic procedure adjust!-growth(facdone,k,m);
% One factor (at least) divides out so we can reconfigure the
% problem for Hensel constrn giving a smaller growth and hopefully
% reducing the coefficient bound considerably.
  begin scalar w,u,bound!-scale,modflist,factorlist,fhatlist,
        modfdone,b;
    factorlist:=vec2list!-without!-k(factorvec,k);
    modflist:=vec2list!-without!-k(modfvec,k);
    fhatlist:=vec2list!-without!-k(fhatvec,k);
    w:=number!-of!-factors;
    modfdone:=getv(modfvec,k);
top:
    factors!-done:=facdone . factors!-done;
    if (number!-of!-factors:=number!-of!-factors #- 1)=1 then <<
      factors!-done:=hensel!-poly . factors!-done;
      number!-of!-factors:=0;
      hensel!-poly:=1;
      if not !*overview then factor!-trace <<
        printstr "    All factors found:";
        for each fd in factors!-done do printsf fd >>;
      return polyzero >>;
    fhatlist:=for each fhat in fhatlist collect
      quotfail!-mod!-p(if null fhat then polyzero else fhat,modfdone);
    u:=comfac facdone;  % Take contents and prim. parts.
    if car u then
      errorf(list("Factor divisible by main variable: ",facdone,car u));
    facdone:=quotfail(facdone,cdr u);
    bound!-scale:=cdr u;
    if not((b:=lc facdone)=1) then begin scalar b!-inv,old!-m;
      hensel!-poly:=quotfail(hensel!-poly,b**number!-of!-factors);
      b!-inv:=modular!-reciprocal modular!-number b;
      modflist:=for each modf in modflist collect
        times!-mod!-p(b!-inv,modf);
% This is one of only two places in the entire factorizer where
% it is ever necessary to use a modulus larger than word-size.
      if m>largest!-small!-modulus then <<
        old!-m:=set!-general!-modulus m;
        factorlist:=for each facc in factorlist collect
          adjoin!-term(lpow facc,quotfail(lc facc,b),
            general!-make!-modular!-symmetric(
              general!-times!-mod!-p(
            general!-modular!-reciprocal general!-modular!-number b,
                            general!-reduce!-mod!-p red facc))) >>
      else <<
        old!-m:=set!-modulus m;
        factorlist:=for each facc in factorlist collect
          adjoin!-term(lpow facc,quotfail(lc facc,b),
            make!-modular!-symmetric(
              times!-mod!-p(modular!-reciprocal modular!-number b,
                            reduce!-mod!-p red facc))) >>;
            % We must be careful not to destroy the information
            % that we have about the leading coefft.
      set!-modulus old!-m;
      fhatlist:=for each fhat in fhatlist collect
        times!-mod!-p(
          modular!-expt(b!-inv,number!-of!-factors #- 1),fhat)
    end;
try!-another!-factor:
    if (w:=w #- 1)>0 then
      if not didntgo
        (u:=quotf(hensel!-poly,facdone:=car factorlist)) then <<
        hensel!-poly:=u;
        factorlist:=cdr factorlist;
        modfdone:=car modflist;
        modflist:=cdr modflist;
        fhatlist:=cdr fhatlist;
        goto top >>
      else <<
        factorlist:=append(cdr factorlist,list car factorlist);
        modflist:=append(cdr modflist,list car modflist);
        fhatlist:=append(cdr fhatlist,list car fhatlist);
        goto try!-another!-factor >>;
    set!-fluids!-for!-newhensel(factorlist,fhatlist,modflist);
    bound!-scale:=
      bound!-scale * get!-coefft!-bound(
        quotfail(hensel!-poly,bound!-scale**(number!-of!-factors #- 1)),
        ldeg hensel!-poly);
    % We expect the new coefficient bound to be smaller, but on
    % dividing out a factor our polynomial's height may have grown
    % more than enough to compensate in the bound formula for
    % the drop in degree. Anyway, the bound we computed last time
    % will still be valid, so let's stick with the smaller.
    if bound!-scale < coefftbd then coefftbd := bound!-scale;
    w:=quotfail(addf(hensel!-poly,negf current!-factor!-product),
          m/deltam);
    if not !*overview then factor!-trace <<
      printstr "    Factors found to be correct:";
      for each fd in factors!-done do
        printsf fd;
      printstr "Remaining factors are:";
      printvec("    f(",number!-of!-factors,") = ",factorvec);
      prin2!* "New coefficient bound is "; printstr coefftbd;
      prin2!* " and the residue is now "; printsf w >>;
    return w
  end;

symbolic procedure vec2list!-without!-k(v,k);
% Turn a vector into a list leaving out Kth element.
  begin scalar w;
    for i:=1:number!-of!-factors do
      if not(i=k) then w:=getv(v,i) . w;
    return w
  end;

symbolic procedure set!-fluids!-for!-newhensel(flist,fhatlist,modflist);
<< current!-factor!-product:=1;
  alphalist:=
    find!-alphas!-in!-a!-ring(number!-of!-factors,modflist,fhatlist,1);
  for i:=number!-of!-factors step -1 until 1 do <<
    putv(factorvec,i,car flist);
    putv(modfvec,i,car modflist);
    putv(fhatvec,i,car fhatlist);
    putv(alphavec,i,cdr get!-alpha car modflist);
    current!-factor!-product:=multf(car flist,current!-factor!-product);
    flist:=cdr flist;
    modflist:=cdr modflist;
    fhatlist:=cdr fhatlist >>
>>;

symbolic procedure set!-hensel!-fluids!-back p;
% After the Hensel growth we must be careful to set back any fluids
% that have been changed when we divided out a factor in the middle
% of growing.  Since calculating the alphas involves modular division
% we cannot do it mod DELTAM which is generally a non-trivial power of
% P (prime). So we calculate them mod P and if necessary we can do a
% few quadratic growth steps later.
  begin scalar n,fd,modflist,fullf,modf;
    set!-modulus p;
    deltam:=p;
    n:=number!-of!-factors #+ length (fd:=factors!-done);
    current!-factor!-product:=hensel!-poly;
    for i:=(number!-of!-factors #+ 1):n do <<
      putv(factorvec,i,fullf:=car fd);
      putv(modfvec,i,modf:=reduce!-mod!-p fullf);
      current!-factor!-product:=multf(fullf,current!-factor!-product);
      modflist:=modf . modflist;
      fd:=cdr fd >>;
    for i:=1:number!-of!-factors do <<
      modf:=reduce!-mod!-p !*mod2f getv(modfvec,i);
            % need to 'unbox' a modpoly before reducing it mod p as we
            % know that the input modpoly is wrt a larger modulus
            % (otherwise this would be a stupid thing to do anyway!)
            % and so we are just pretending it is a full poly.
      modflist:=modf . modflist;
      putv(modfvec,i,modf) >>;
    alphalist:=alphas(n,modflist,1);
    for i:=1:n do putv(alphavec,i,cdr get!-alpha getv(modfvec,i));
    number!-of!-factors:=n
  end;

endmodule;


end;

Added r33/factor.red version [99af573d08].



























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
module bigmodp; % Modular polynomial arithmetic where the modulus may
                % be a bignum.

% Authors: A. C. Norman and P. M. A. Moore, 1981;

fluid '(current!-modulus modulus!/2);

symbolic procedure general!-plus!-mod!-p(a,b);
% form the sum of the two polynomials a and b
% working over the ground domain defined by the routines
% general!-modular!-plus, general!-modular!-times etc. the inputs to
% this routine are assumed to have coefficients already
% in the required domain;
   if null a then b
   else if null b then a
   else if isdomain a then
      if isdomain b then !*num2f general!-modular!-plus(a,b)
      else (lt b) .+ general!-plus!-mod!-p(a,red b)
   else if isdomain b then (lt a) .+ general!-plus!-mod!-p(red a,b)
   else if lpow a = lpow b then
      adjoin!-term(lpow a,
         general!-plus!-mod!-p(lc a,lc b),
         general!-plus!-mod!-p(red a,red b))
   else if comes!-before(lpow a,lpow b) then
         (lt a) .+ general!-plus!-mod!-p(red a,b)
   else (lt b) .+ general!-plus!-mod!-p(a,red b);

symbolic procedure general!-times!-mod!-p(a,b);
   if (null a) or (null b) then nil
   else if isdomain a then gen!-mult!-by!-const!-mod!-p(b,a)
   else if isdomain b then gen!-mult!-by!-const!-mod!-p(a,b)
   else if mvar a=mvar b then general!-plus!-mod!-p(
     general!-plus!-mod!-p(general!-times!-term!-mod!-p(lt a,b),
                  general!-times!-term!-mod!-p(lt b,red a)),
     general!-times!-mod!-p(red a,red b))
   else if ordop(mvar a,mvar b) then
     adjoin!-term(lpow a,general!-times!-mod!-p(lc a,b),
       general!-times!-mod!-p(red a,b))
   else adjoin!-term(lpow b,
        general!-times!-mod!-p(a,lc b),general!-times!-mod!-p(a,red b));

symbolic procedure general!-times!-term!-mod!-p(term,b);
%multiply the given polynomial by the given term;
    if null b then nil
    else if isdomain b then
        adjoin!-term(tpow term,
            gen!-mult!-by!-const!-mod!-p(tc term,b),nil)
    else if tvar term=mvar b then
         adjoin!-term(mksp(tvar term,iplus(tdeg term,ldeg b)),
                      general!-times!-mod!-p(tc term,lc b),
                      general!-times!-term!-mod!-p(term,red b))
    else if ordop(tvar term,mvar b) then
      adjoin!-term(tpow term,general!-times!-mod!-p(tc term,b),nil)
    else adjoin!-term(lpow b,
      general!-times!-term!-mod!-p(term,lc b),
      general!-times!-term!-mod!-p(term,red b));

symbolic procedure gen!-mult!-by!-const!-mod!-p(a,n);
% multiply the polynomial a by the constant n;
   if null a then nil
   else if n=1 then a
   else if isdomain a then !*num2f general!-modular!-times(a,n)
   else adjoin!-term(lpow a,gen!-mult!-by!-const!-mod!-p(lc a,n),
     gen!-mult!-by!-const!-mod!-p(red a,n));

symbolic procedure general!-difference!-mod!-p(a,b);
   general!-plus!-mod!-p(a,general!-minus!-mod!-p b);

symbolic procedure general!-minus!-mod!-p a;
   if null a then nil
   else if isdomain a then general!-modular!-minus a
   else (lpow a .* general!-minus!-mod!-p lc a) .+
        general!-minus!-mod!-p red a;

symbolic procedure general!-reduce!-mod!-p a;
%converts a multivariate poly from normal into modular polynomial;
    if null a then nil
    else if isdomain a then !*num2f general!-modular!-number a
    else adjoin!-term(lpow a,
                      general!-reduce!-mod!-p lc a,
                      general!-reduce!-mod!-p red a);

symbolic procedure general!-make!-modular!-symmetric a;
% input is a multivariate MODULAR poly A with nos in the range 0->(p-1).
% This folds it onto the symmetric range (-p/2)->(p/2);
    if null a then nil
    else if domainp a then
      if a>modulus!/2 then !*num2f(a - current!-modulus)
      else a
    else adjoin!-term(lpow a,
                      general!-make!-modular!-symmetric lc a,
                      general!-make!-modular!-symmetric red a);

endmodule;


module degsets;   % degree set processing.

% Authors: A. C. Norman and P. M. A. Moore, 1981.

fluid '(!*trallfac
        !*trfac
        bad!-case
        best!-set!-pointer
        dpoly
        factor!-level
        factor!-trace!-list
        factored!-lc
        irreducible
        modular!-info
        one!-complete!-deg!-analysis!-done
        previous!-degree!-map
        split!-list
        valid!-image!-sets);

symbolic procedure check!-degree!-sets(n,multivariate!-case);
% MODULAR!-INFO (vector of size N) contains the modular factors now.
  begin scalar degree!-sets,w,x!-is!-factor,degs;
    w:=split!-list;
    for i:=1:n do <<
      if multivariate!-case then
        x!-is!-factor:=not numberp get!-image!-content
          getv(valid!-image!-sets,cdar w);
      degs:=for each v in getv(modular!-info,cdar w) collect ldeg v;
      degree!-sets:=
        (if x!-is!-factor then 1 . degs else degs)
              . degree!-sets;
      w:=cdr w >>;
    check!-degree!-sets!-1 degree!-sets;
    best!-set!-pointer:=cdar split!-list;
    if multivariate!-case and factored!-lc then <<
      while null(w:=get!-f!-numvec
           getv(valid!-image!-sets,best!-set!-pointer))
       and (split!-list:=cdr split!-list) do
        best!-set!-pointer:=cdar split!-list;
      if null w then bad!-case:=t >>;
            % make sure the set is ok for distributing the
            % leading coefft where necessary;
  end;

symbolic procedure check!-degree!-sets!-1 l;
% L is a list of degree sets. Try to discover if the entries
% in it are consistent, or if they imply that some of the
% modular splittings were 'false';
  begin
    scalar i,degree!-map,degree!-map1,dpoly,
        plausible!-split!-found,target!-count;
    factor!-trace <<
       printc "Degree sets are:";
       for each s in l do <<
          prin2 "     ";
          for each n in s do <<
             prin2 " "; prin2 n >>;
          terpri() >> >>;
    dpoly:=sum!-list car l;
    target!-count:=length car l;
    for each s in cdr l do
        target!-count:=min(target!-count,length s);
    % This used to be IMIN, but since it was the only use, it was
    % eliminated.
    if null previous!-degree!-map then <<
      degree!-map:=mkvect dpoly;
% To begin with all degrees of factors may be possible;
      for i:=0:dpoly do putv(degree!-map,i,t) >>
    else <<
      factor!-trace "Refine an existing degree map";
      degree!-map:=previous!-degree!-map >>;
    degree!-map1:=mkvect dpoly;
    for each s in l do <<
% For each degree set S I will collect in DEGREE-MAP1 a
% bitmap showing what degree factors would be consistent
% with that set. By ANDing together all these maps
% (into DEGREE-MAP) I find what degrees for factors are
% consistent with the whole of the information I have;
      for i:=0:dpoly do putv(degree!-map1,i,nil);
      putv(degree!-map1,0,t);
      putv(degree!-map1,dpoly,t);
      for each d in s do for i:=dpoly#-d#-1 step -1 until 0 do
        if getv(degree!-map1,i) then
           putv(degree!-map1,i#+d,t);
      for i:=0:dpoly do
        putv(degree!-map,i,getv(degree!-map,i) and
             getv(degree!-map1,i)) >>;
    factor!-trace <<
        printc "Possible degrees for factors are: ";
        for i:=1:dpoly#-1 do
          if getv(degree!-map,i) then << prin2 i; prin2 " " >>;
        terpri() >>;
    i:=dpoly#-1;
    while i#>0 do if getv(degree!-map,i) then i:=-1
                 else i:=i#-1;
    if i=0 then <<
       factor!-trace
          printc "Degree analysis proves polynomial irreducible";
       return irreducible:=t >>;
    for each s in l do if length s=target!-count then begin
      % Sets with too many factors are not plausible anyway;
      i:=s;
      while i and getv(degree!-map,car i) do i:=cdr i;
      % If I drop through with I null it was because the set was
      % consistent, otherwise it represented a false split;
      if null i then plausible!-split!-found:=t end;
    previous!-degree!-map:=degree!-map;
    if plausible!-split!-found or one!-complete!-deg!-analysis!-done
      then return nil;
%    PRINTC "Going to try getting some more images";
    return bad!-case:=t
  end;

symbolic procedure sum!-list l;
   if null cdr l then car l
   else car l #+ sum!-list cdr l;




endmodule;


module facmod; % Modular factorization: discover the factor count mod p.

% Authors: A. C. Norman and P. M. A. Moore, 1979.

fluid '(!*timings
        current!-modulus
        dpoly
        dwork1
        dwork2
        known!-factors
        linear!-factors
        m!-image!-variable
        modular!-info
        null!-space!-basis
        number!-needed
        poly!-mod!-p
        poly!-vector
        safe!-flag
        split!-list
        work!-vector1
        work!-vector2);


safe!-flag:=carcheck 0; % For speed of array access - important here;


symbolic procedure get!-factor!-count!-mod!-p
                              (n,poly!-mod!-p,p,x!-is!-factor);
% gets the factor count mod p from the nth image using the
% first half of Berlekamp's method;
  begin scalar old!-m,f!-count,wtime;
    old!-m:=set!-modulus p;
%    PRIN2 "prime = ";% printc current!-modulus;
%    PRIN2 "degree = ";% printc ldeg poly!-mod!-p;
    trace!-time display!-time("Entered GET-FACTOR-COUNT after ",time());
    wtime:=time();
    f!-count:=modular!-factor!-count();
    trace!-time display!-time("Factor count obtained in ",time()-wtime);
    split!-list:=
      ((if x!-is!-factor then car f!-count#+1 else car f!-count) . n)
        . split!-list;
    putv(modular!-info,n,cdr f!-count);
    set!-modulus old!-m
  end;

symbolic procedure modular!-factor!-count();
  begin
    scalar poly!-vector,wvec1,wvec2,x!-to!-p,
      n,wtime,w,lin!-f!-count,null!-space!-basis;
    known!-factors:=nil;
    dpoly:=ldeg poly!-mod!-p;
    wvec1:=mkvect (2#*dpoly);
    wvec2:=mkvect (2#*dpoly);
    x!-to!-p:=mkvect dpoly;
    poly!-vector:=mkvect dpoly;
    for i:=0:dpoly do putv(poly!-vector,i,0);
    poly!-to!-vector poly!-mod!-p;
    w:=count!-linear!-factors!-mod!-p(wvec1,wvec2,x!-to!-p);
    lin!-f!-count:=car w;
    if dpoly#<4 then return
       (if dpoly=0 then lin!-f!-count
        else lin!-f!-count#+1) .
        list(lin!-f!-count . cadr w,
             dpoly . poly!-vector,
             nil);
% When I use Berlekamp I certainly know that the polynomial
% involved has no linear factors;
    wtime:=time();
    null!-space!-basis:=use!-berlekamp(x!-to!-p,caddr w,wvec1);
    trace!-time display!-time("Berlekamp done in ",time()-wtime);
    n:=lin!-f!-count #+ length null!-space!-basis #+ 1;
            % there is always 1 more factor than the number of
            % null vectors we have picked up;
    return n . list(
     lin!-f!-count . cadr w,
     dpoly . poly!-vector,
     null!-space!-basis)
  end;

%**********************************************************************;
% Extraction of linear factors is done specially;

symbolic procedure count!-linear!-factors!-mod!-p(wvec1,wvec2,x!-to!-p);
% Compute gcd(x**p-x,u). It will be the product of all the
% linear factors of u mod p;
  begin scalar dx!-to!-p,lin!-f!-count,linear!-factors;
    for i:=0:dpoly do putv(wvec2,i,getv(poly!-vector,i));
    dx!-to!-p:=make!-x!-to!-p(current!-modulus,wvec1,x!-to!-p);
    for i:=0:dx!-to!-p do putv(wvec1,i,getv(x!-to!-p,i));
    if dx!-to!-p#<1 then <<
        if dx!-to!-p#<0 then putv(wvec1,0,0);
        putv(wvec1,1,modular!-minus 1);
        dx!-to!-p:=1 >>
    else <<
      putv(wvec1,1,modular!-difference(getv(wvec1,1),1));
      if dx!-to!-p=1 and getv(wvec1,1)=0 then
         if getv(wvec1,0)=0 then dx!-to!-p:=-1
         else dx!-to!-p:=0 >>;
    if dx!-to!-p#<0 then
      lin!-f!-count:=copy!-vector(wvec2,dpoly,wvec1)
    else lin!-f!-count:=gcd!-in!-vector(wvec1,dx!-to!-p,
      wvec2,dpoly);
    linear!-factors:=mkvect lin!-f!-count;
    for i:=0:lin!-f!-count do
      putv(linear!-factors,i,getv(wvec1,i));
    dpoly:=quotfail!-in!-vector(poly!-vector,dpoly,
        linear!-factors,lin!-f!-count);
    return list(lin!-f!-count,linear!-factors,dx!-to!-p)
  end;

symbolic procedure make!-x!-to!-p(p,wvec1,x!-to!-p);
  begin scalar dx!-to!-p,dw1;
    if p#<dpoly then <<
       for i:=0:p#-1 do putv(x!-to!-p,i,0);
       putv(x!-to!-p,p,1);
       return p >>;
    dx!-to!-p:=make!-x!-to!-p(p/2,wvec1,x!-to!-p);
    dw1:=times!-in!-vector(x!-to!-p,dx!-to!-p,x!-to!-p,dx!-to!-p,wvec1);
    dw1:=remainder!-in!-vector(wvec1,dw1,
        poly!-vector,dpoly);
    if not(iremainder(p,2)=0) then <<
       for i:=dw1 step -1 until 0 do
          putv(wvec1,i#+1,getv(wvec1,i));
       putv(wvec1,0,0);
       dw1:=remainder!-in!-vector(wvec1,dw1#+1,
         poly!-vector,dpoly) >>;
    for i:=0:dw1 do putv(x!-to!-p,i,getv(wvec1,i));
    return dw1
  end;

symbolic procedure find!-linear!-factors!-mod!-p(p,n);
% P is a vector representing a polynomial of degree N which has
% only linear factors. Find all the factors and return a list of
% them;
  begin
    scalar root,var,w,vec1;
    if n#<1 then return nil;
    vec1:=mkvect 1;
    putv(vec1,1,1);
    root:=0;
    while (n#>1) and not (root #> current!-modulus) do <<
        w:=evaluate!-in!-vector(p,n,root);
        if w=0 then << %a factor has been found!!;
          if var=nil then
             var:=mksp(m!-image!-variable,1) . 1;
          w:=!*f2mod
            adjoin!-term(car var,cdr var,!*n2f modular!-minus root);
          known!-factors:=w . known!-factors;
          putv(vec1,0,modular!-minus root);
          n:=quotfail!-in!-vector(p,n,vec1,1) >>;
        root:=root#+1 >>;
    known!-factors:=
        vector!-to!-poly(p,n,m!-image!-variable) . known!-factors
  end;


%**********************************************************************;
% Berlekamp's algorithm part 1: find null space basis giving factor
% count;


symbolic procedure use!-berlekamp(x!-to!-p,dx!-to!-p,wvec1);
% Set up a basis for the set of remaining (nonlinear) factors
% using Berlekamp's algorithm;
  begin
    scalar berl!-m,berl!-m!-size,w,
           dcurrent,current!-power,wtime;
    berl!-m!-size:=dpoly#-1;
    berl!-m:=mkvect berl!-m!-size;
    for i:=0:berl!-m!-size do <<
      w:=mkvect berl!-m!-size;
      for j:=0:berl!-m!-size do putv(w,j,0); %initialize to zero;
      putv(berl!-m,i,w) >>;
% Note that column zero of the matrix (as used in the
% standard version of Berlekamp's algorithm) is not in fact
% needed and is not used here;
% I want to set up a matrix that has entries
%  x**p, x**(2*p), ... , x**((n-1)*p)
% as its columns,
% where n is the degree of poly-mod-p
% and all the entries are reduced mod poly-mod-p;
% Since I computed x**p I have taken out some linear factors,
% so reduce it further;
    dx!-to!-p:=remainder!-in!-vector(x!-to!-p,dx!-to!-p,
      poly!-vector,dpoly);
    dcurrent:=0;
    current!-power:=mkvect berl!-m!-size;
    putv(current!-power,0,1);
    for i:=1:berl!-m!-size do <<
       if current!-modulus#>dpoly then
         dcurrent:=times!-in!-vector(
            current!-power,dcurrent,
            x!-to!-p,dx!-to!-p,
            wvec1)
       else << % Multiply by shifting;
         for i:=0:current!-modulus#-1 do
           putv(wvec1,i,0);
         for i:=0:dcurrent do
           putv(wvec1,current!-modulus#+i,
             getv(current!-power,i));
         dcurrent:=dcurrent#+current!-modulus >>;
       dcurrent:=remainder!-in!-vector(
         wvec1,dcurrent,
         poly!-vector,dpoly);
       for j:=0:dcurrent do
          putv(getv(berl!-m,j),i,putv(current!-power,j,
            getv(wvec1,j)));
% also I need to subtract 1 from the diagonal of the matrix;
       putv(getv(berl!-m,i),i,
         modular!-difference(getv(getv(berl!-m,i),i),1)) >>;
    wtime:=time();
%   print!-m("Q matrix",berl!-m,berl!-m!-size);
    w := find!-null!-space(berl!-m,berl!-m!-size);
    trace!-time display!-time("Null space found in ",time()-wtime);
    return w
  end;


symbolic procedure find!-null!-space(berl!-m,berl!-m!-size);
% Diagonalize the matrix to find its rank and hence the number of
% factors the input polynomial had;
  begin scalar null!-space!-basis;
% find a basis for the null-space of the matrix;
    for i:=1:berl!-m!-size do
      null!-space!-basis:=
        clear!-column(i,null!-space!-basis,berl!-m,berl!-m!-size);
%    print!-m("Null vectored",berl!-m,berl!-m!-size);
    return
      tidy!-up!-null!-vectors(null!-space!-basis,berl!-m,berl!-m!-size)
  end;

symbolic procedure print!-m(m,berl!-m,berl!-m!-size);
 << printc m;
    for i:=0:berl!-m!-size do <<
      for j:=0:berl!-m!-size do <<
        prin2 getv(getv(berl!-m,i),j);
        ttab((4#*j)#+4) >>;
      terpri() >> >>;



symbolic procedure clear!-column(i,
                    null!-space!-basis,berl!-m,berl!-m!-size);
% Process column I of the matrix so that (if possible) it
% just has a '1' in row I and zeros elsewhere;
  begin
    scalar ii,w;
% I want to bring a non-zero pivot to the position (i,i)
% and then add multiples of row i to all other rows to make
% all but the i'th element of column i zero. First look for
% a suitable pivot;
    ii:=0;
search!-for!-pivot:
    if getv(getv(berl!-m,ii),i)=0 or
       ((ii#<i) and not(getv(getv(berl!-m,ii),ii)=0)) then
          if (ii:=ii#+1)#>berl!-m!-size then
              return (i . null!-space!-basis)
          else go to search!-for!-pivot;
% Here ii references a row containing a suitable pivot element for
% column i. Permute rows in the matrix so as to bring the pivot onto
% the diagonal;
    w:=getv(berl!-m,ii);
    putv(berl!-m,ii,getv(berl!-m,i));
    putv(berl!-m,i,w);
            % swop rows ii and i ;
    w:=modular!-minus modular!-reciprocal getv(getv(berl!-m,i),i);
% w = -1/pivot, and is used in zeroing out the rest of column i;
    for row:=0:berl!-m!-size do
      if row neq i then begin
         scalar r; %process one row;
         r:=getv(getv(berl!-m,row),i);
         if not(r=0) then <<
           r:=modular!-times(r,w);
   %that is now the multiple of row i that must be added to row ii;
           for col:=i:berl!-m!-size do
             putv(getv(berl!-m,row),col,
               modular!-plus(getv(getv(berl!-m,row),col),
               modular!-times(r,getv(getv(berl!-m,i),col)))) >>
         end;
    for col:=i:berl!-m!-size do
        putv(getv(berl!-m,i),col,
           modular!-times(getv(getv(berl!-m,i),col),w));
    return null!-space!-basis
  end;


symbolic procedure tidy!-up!-null!-vectors(null!-space!-basis,
                    berl!-m,berl!-m!-size);
  begin
    scalar row!-to!-use;
    row!-to!-use:=berl!-m!-size#+1;
    null!-space!-basis:=
      for each null!-vector in null!-space!-basis collect
        build!-null!-vector(null!-vector,
            getv(berl!-m,row!-to!-use:=row!-to!-use#-1),berl!-m);
    berl!-m:=nil; % Release the store for full matrix;
%    prin2 "Null vectors: ";
%    print null!-space!-basis;
    return null!-space!-basis
  end;

symbolic procedure build!-null!-vector(n,vec,berl!-m);
% At the end of the elimination process (the CLEAR-COLUMN loop)
% certain columns, indicated by the entries in NULL-SPACE-BASIS
% will be null vectors, save for the fact that they need a '1'
% inserted on the diagonal of the matrix. This procedure copies
% these null-vectors into some of the vectors that represented
% rows of the Berlekamp matrix;
  begin
%   putv(vec,0,0); % Not used later!!;
    for i:=1:n#-1 do
      putv(vec,i,getv(getv(berl!-m,i),n));
    putv(vec,n,1);
%   for i:=n#+1:berl!-m!-size do
%     putv(vec,i,0);
    return vec . n
  end;



%**********************************************************************;
% Berlekamp's algorithm part 2: retrieving the factors mod p;


symbolic procedure get!-factors!-mod!-p(n,p);
% given the modular info (for the nth image) generated by the
% previous half of Berlekamp's method we can reconstruct the
% actual factors mod p;
  begin scalar nth!-modular!-info,old!-m,wtime;
    nth!-modular!-info:=getv(modular!-info,n);
    old!-m:=set!-modulus p;
    wtime:=time();
    putv(modular!-info,n,
      convert!-null!-vectors!-to!-factors nth!-modular!-info);
    trace!-time display!-time("Factors constructed in ",time()-wtime);
    set!-modulus old!-m
  end;

symbolic procedure convert!-null!-vectors!-to!-factors m!-info;
% Using the null space found, complete the job
% of finding modular factors by taking gcd's of the
% modular input polynomial and variants on the
% null space generators;
  begin
    scalar number!-needed,factors,
      work!-vector1,dwork1,work!-vector2,dwork2,wtime;
    known!-factors:=nil;
    wtime:=time();
    find!-linear!-factors!-mod!-p(cdar m!-info,caar m!-info);
    trace!-time display!-time("Linear factors found in ",time()-wtime);
    dpoly:=caadr m!-info;
    poly!-vector:=cdadr m!-info;
    null!-space!-basis:=caddr m!-info;
    if dpoly=0 then return known!-factors; % All factors were linear;
    if null null!-space!-basis then
      return known!-factors:=
          vector!-to!-poly(poly!-vector,dpoly,m!-image!-variable) .
            known!-factors;
    number!-needed:=length null!-space!-basis;
% count showing how many more factors I need to find;
    work!-vector1:=mkvect dpoly;
    work!-vector2:=mkvect dpoly;
    factors:=list (poly!-vector . dpoly);
try!-next!-null:
    if null!-space!-basis=nil then
      errorf "RAN OUT OF NULL VECTORS TOO EARLY";
    wtime:=time();
    factors:=try!-all!-constants(factors,
        caar null!-space!-basis,cdar null!-space!-basis);
    trace!-time display!-time("All constants tried in ",time()-wtime);
    if number!-needed=0 then
       return known!-factors:=append!-new!-factors(factors,
            known!-factors);
    null!-space!-basis:=cdr null!-space!-basis;
    go to try!-next!-null
  end;


symbolic procedure try!-all!-constants(list!-of!-polys,v,dv);
% use gcd's of v, v+1, v+2, ... to try to split up the
% polynomials in the given list;
  begin
    scalar a,b,aa,s;
% aa is a list of factors that can not be improved using this v,
% b is a list that might be;
    aa:=nil; b:=list!-of!-polys;
    s:=0;
try!-next!-constant:
    putv(v,0,s); % Fix constant term of V to be S;
%    wtime:=time();
    a:=split!-further(b,v,dv);
%    trace!-time display!-time("Polys split further in ",time()-wtime);
    b:=cdr a; a:=car a;
    aa:=nconc(a,aa);
% Keep aa up to date as a list of polynomials that this poly
% v can not help further with;
    if b=nil then return aa; % no more progress possible here;
    if number!-needed=0 then return nconc(b,aa);
      % no more progress needed;
    s:=s#+1;
    if s#<current!-modulus then go to try!-next!-constant;
% Here I have run out of choices for the constant
% coefficient in v without splitting everything;
    return nconc(b,aa)
  end;

symbolic procedure split!-further(list!-of!-polys,v,dv);
% list-of-polys is a list of polynomials. try to split
% its members further by taking gcd's with the polynomial
% v. return (a . b) where the polys in a can not possibly
% be split using v+constant, but the polys in b might
% be;
    if null list!-of!-polys then nil . nil
    else begin
      scalar a,b,gg,q;
      a:=split!-further(cdr list!-of!-polys,v,dv);
      b:=cdr a; a:=car a;
      if number!-needed=0 then go to no!-split;
      % if all required factors have been found there is no need to
      % search further;
      dwork1:=copy!-vector(v,dv,work!-vector1);
      dwork2:=copy!-vector(caar list!-of!-polys,cdar list!-of!-polys,
        work!-vector2);
      dwork1:=gcd!-in!-vector(work!-vector1,dwork1,
         work!-vector2,dwork2);
      if dwork1=0 or dwork1=cdar list!-of!-polys then go to no!-split;
      dwork2:=copy!-vector(caar list!-of!-polys,cdar list!-of!-polys,
        work!-vector2);
      dwork2:=quotfail!-in!-vector(work!-vector2,dwork2,
        work!-vector1,dwork1);
% Here I have a splitting;
      gg:=mkvect dwork1;
      copy!-vector(work!-vector1,dwork1,gg);
      a:=((gg . dwork1) . a);
      copy!-vector(work!-vector2,dwork2,q:=mkvect dwork2);
      b:=((q . dwork2) . b);
      number!-needed:=number!-needed#-1;
      return (a . b);
   no!-split:
      return (a . ((car list!-of!-polys) . b))
    end;

symbolic procedure append!-new!-factors(a,b);
% Convert to REDUCE (rather than vector) form;
    if null a then b
    else
      vector!-to!-poly(caar a,cdar a,m!-image!-variable) .
        append!-new!-factors(cdr a,b);



carcheck safe!-flag; % Restore status quo;

endmodule;


module factrr;   % Full factorization of polynomials.

% Author: P. M. A. Moore, 1979.

fluid '(!*all!-contents
        !*exp
        !*ezgcd
        !*force!-prime
        !*gcd
        !*kernreverse
        !*mcd
        !*timings
        !*trfac
        base!-time
        current!-modulus
        dmode!*
        factor!-count
        factor!-level
        factor!-trace!-list
        gc!-base!-time
        last!-displayed!-gc!-time
        last!-displayed!-time
        m!-image!-variable
        modulus!/2
        polynomial!-to!-factor
        polyzero);

global '(!*ifactor);

symbolic procedure factoreval u;
% Factorize the polynomial in the car of u, returning the factors found.
% If cadr u exists then if it is a number, use it as a force prime.
% Otherwise, use cadr u as a fill object, and check to see if caddr u
% is now a force prime.
   begin scalar p,w,!*force!-prime,x,z,factor!-count;
      p := length u;
      if p<1 or p>3
        then rederr "FACTORIZE called with wrong number of arguments";
      p := !*q2f simp!* car u;
      if cdr u then
        <<w := cadr u;
          if fixp w then <<!*force!-prime := w; w := nil>>
           else if cddr u and fixp caddr u
            then !*force!-prime := caddr u;
          if !*force!-prime and not primep !*force!-prime
            then typerr(!*force!-prime,"prime")>>;
      x := if dmode!*
             then if z := get(dmode!*,'factorfn) then apply1(z,p)
                   else rederr
                         list("Factorization not supported over domain",
                                get(dmode!*,'dname))
           else factorf1(p,!*force!-prime);
      % Note that car x is expected to be a number.
      z:= (0 . car x) . nil;
      x := reversip!* cdr x;  % This puts factors in better order.
      factor!-count:=0;
      for each fff in x do
          for i:=1:cdr fff do
              z:=((factor!-count:=factor!-count+1) .
                  mk!*sq(car fff ./ 1)) . z;
      z := multiple!-result(z,w);
      if numberp z then return z     % old style input
       else if numberp cadr z and cadr z<0 and cddr z
        then z := car z . 
                      (- cadr z) . mk!*sq negsq simp caddr z . cdddr z;
      % make numerical coefficient positive.
      return if cadr z = 1 then car z . cddr z
              else if !*ifactor and numberp cadr z and fixp cadr z
               then car z .
                     append(pairlist2list reversip zfactor cadr z,
                            cddr z)
              else z
  end;

put('factorize,'psopfn,'factoreval);

symbolic procedure pairlist2list u;
   for each x in u conc nlist(car x,cdr x);


symbolic procedure factorf u;
% This is the entry to the factorizer that is to be used by programmers
% working at the symbolic level.  U is to be a standard form.  FACTORF
% hands back a list giving the factors of U.  The format of said list is
% described below in the comments with FACTORIZE!-FORM.  Entry to the
% factorizer at any level other than this is at the programmers own
% risk!! ;
   factorf1(u,nil);

symbolic procedure factorf1(u,!*force!-prime);
% This entry to the factorizer allows one to force
% the code to use some particular prime for its
% modular factorization. It is not for casual
% use;
  begin
    scalar factor!-level,base!-time,last!-displayed!-time,
      gc!-base!-time,last!-displayed!-gc!-time,current!-modulus,
      modulus!/2,expsave,!*ezgcd,!*gcd;
    if null !*mcd then rederr "Factorization invalid with MCD off";
    expsave := !*exp;
    !*exp := !*gcd := t; % This code will not work otherwise;
    !*ezgcd := t;
    if null expsave then u := !*q2f resimp !*f2q u;
    set!-time();
    factor!-level := 0;
    u := factorize!-form u;
    !*exp := expsave;
    return u
  end;
 
symbolic procedure factorize!-form p;
% input:
% p is a reduce standard form that is to be factorized
% over the integers
% result:      (nc . l)
%  where nc is numeric (may be just 1)
%  and l is list of the form:
%    ((p1 . x1) (p2 . x2) .. (pn . xn))
% where p<i> are standard forms and x<i> are integers,
% and p= product<i> p<i>**x<i>;
%
% method:
% (a) reorder polynomial to make the variable of lowest maximum
% degree the main one and the rest ordered similarly;
% (b) use contents and primitive parts to split p up as far as possible
% (c) use square-free decomposition to continue the process
% (c.1) detect & perform special processing on cyclotomic polynomials
% (d) use modular-based method to find factors over integers;
  begin scalar new!-korder,old!-korder;
    new!-korder:=kernord(p,polyzero);
    if !*kernreverse then new!-korder:=reverse new!-korder;
    old!-korder:=setkorder new!-korder;
    p:=reorder p; % Make var of lowest degree the main one;
    p:=factorize!-form1(p,new!-korder);
    setkorder old!-korder;
    p := (car p . for each w in cdr p collect
           (reorder car w . cdr w));
    return p
  end;

symbolic procedure factorize!-form1(p,given!-korder);
% input:
% p is a reduce standard form that is to be factorized
% over the integers
% given-korder is a list of kernels in the order of importance
% (ie when finding leading terms etc. we use this list)
% See FACTORIZE-FORM above;
  if domainp p then (p . nil)
  else begin scalar m!-image!-variable,var!-list,
                    polynomial!-to!-factor,n;
    if !*all!-contents then var!-list:=given!-korder
    else <<
      m!-image!-variable:=car given!-korder;
      var!-list:=list m!-image!-variable >>;
    return (lambda factor!-level;
     << factor!-trace <<
          prin2!* "FACTOR : "; printsf p;
          prin2!* "Chosen main variable is ";
          printvar m!-image!-variable >>;
        polynomial!-to!-factor:=p;
        n:=numeric!-content p;
        p:=quotf(p,n);
        if poly!-minusp p then <<
          p:=negf p;
          n:=-n >>;
        factor!-trace <<
          prin2!* "Numeric content = ";
          printsf n >>;
        p:=factorize!-by!-contents(p,var!-list);
        p:=n . sort!-factors p;
        factor!-trace <<
          terpri(); terpri();
          printstr "Final result is:";  fac!-printfactors p >>;
        p >>)
        (factor!-level+1)
  end;

symbolic procedure factorize!-form!-recursion p;
% this is essentially the same as FACTORIZE!-FORM except that
% we must be careful of stray minus signs due to a possible
% reordering in the recursive factoring;
  begin scalar s,n,x,res,new!-korder,old!-korder;
    new!-korder:=kernord(p,polyzero);
    if !*kernreverse then new!-korder:=reverse new!-korder;
    old!-korder:=setkorder new!-korder;
    p:=reorder p; % Make var of lowest degree the main one;
    x:=factorize!-form1(p,new!-korder);
    setkorder old!-korder;
    n := car x;
    x := for each p in cdr x collect (reorder car p . cdr p);
    if minusp n then << s:=-1; n:=-n >> else s:=1;
    res:=for each ff in x collect
      if poly!-minusp car ff then <<
        s:=s*((-1)**cdr ff);
        (negf car ff . cdr ff) >>
      else ff;
    if minusp s then errorf list(
      "Stray minus sign in recursive factorisation:",x);
    return (n . res)
  end;

symbolic procedure sort!-factors l;
%sort factors as found into some sort of standard order. The order
%used here is more or less random, but will be self-consistent;
    sort(l,function orderfactors);


% ***** Contents and primitive parts as applied to factorization *****

symbolic procedure factorize!-by!-contents(p,v);
%use contents wrt variables in list v to split the
%polynomial p. return a list of factors;
% specification is that on entry p *must* be positive;
    if domainp p then
      errorf list("FACTORIZE-BY-CONTENTS HANDED DOMAIN ELT:",p)
    else if null v then square!.free!.factorize p
    else begin scalar c,w,l,wtime;
        w:=contents!-with!-respect!-to(p,car v);
% contents!-with!-respect!-to returns a pair (g . c) where
% if g=nil the content is just c, otherwise g is a power
% [ x ** n ] and g*c is the content;
        if not null car w then <<
% here a power of v divides p;
            l:=(!*k2f caar w . cdar w) . nil;
            p:=quotfail(p,!*p2f car w);
            if p=1 then return l
            else if domainp p then
                errorf "P SHOULD NOT BE CONSTANT HERE" >>;
        c:=cdr w;
        if c=1 then << %no progress here;
          if null l then
            factor!-trace << prin2!* "Polynomial is primitive wrt ";
              prinvar car v; terpri!*(nil) >>
          else factor!-trace << printstr "Content is: ";
              fac!-printfactors(1 . l) >>;
          return if !*all!-contents then
            append(factorize!-by!-contents(p,cdr v),l)
          else append(square!.free!.factorize p,l) >>;
        p:=quotfail(p,c); %primitive part;
% p is now primitive, so if it is not a real polynomial it
% must be a unit. since input was +ve it had better be +1 !! ;
        if p=-1 then
          errorf "NEGATIVE PRIMITIVE PART IN FACTORIZE-BY-CONTENTS";
        trace!-time printc "Factoring the content:";
        wtime:=time();
        l:=append(cdr1 factorize!-form!-recursion c,l);
        trace!-time display!-time("Content factored in ",
          time()-wtime);
        factor!-trace <<
          prin2!* "Content wrt "; prinvar car v; prin2!* " is: ";
          printsf comfac!-to!-poly w;
          printstr "Factors of content are: ";
          fac!-printfactors(1 . l) >>;
        if p=1 then return l
        else if !*all!-contents then
            return append(factorize!-by!-contents(p,cdr v),l)
        else return append(square!.free!.factorize p,l)
    end;

symbolic procedure cdr1 a;
  if car a=1 then cdr a
  else errorf list("NUMERIC CONTENT NOT EXTRACTED:",car a);

endmodule;


module facuni;

% Authors: A. C. Norman and P. M. A. Moore, 1979;

fluid '(!*force!-prime
        !*trfac
        alphalist
        bad!-case
        best!-factor!-count
        best!-known!-factors
        best!-modulus
        best!-set!-pointer
        chosen!-prime
        factor!-level
        factor!-trace!-list
        forbidden!-primes
        hensel!-growth!-size
        input!-leading!-coefficient
        input!-polynomial
        irreducible
        known!-factors
        m!-image!-variable
        modular!-info
        no!-of!-best!-primes
        no!-of!-random!-primes
        non!-monic
        null!-space!-basis
        number!-of!-factors
        one!-complete!-deg!-analysis!-done
        poly!-mod!-p
        previous!-degree!-map
        reduction!-count
        split!-list
        target!-factor!-count
        univariate!-factors
        univariate!-input!-poly
        valid!-primes);


symbolic procedure univariate!-factorize poly;
% input poly a primitive square-free univariate polynomial at least
% quadratic and with +ve lc.  output is a list of the factors of poly
% over the integers ;
  if testx!*!*n!+1 poly then
    factorizex!*!*n!+1(m!-image!-variable,ldeg poly,1)
  else if testx!*!*n!-1 poly then
    factorizex!*!*n!-1(m!-image!-variable,ldeg poly,1)
  else univariate!-factorize1 poly;

symbolic procedure univariate!-factorize1 poly;
  begin scalar
    valid!-primes,univariate!-input!-poly,best!-set!-pointer,
    number!-of!-factors,irreducible,forbidden!-primes,
    no!-of!-best!-primes,no!-of!-random!-primes,bad!-case,
    target!-factor!-count,modular!-info,univariate!-factors,
    hensel!-growth!-size,alphalist,previous!-degree!-map,
    one!-complete!-deg!-analysis!-done,reduction!-count,
    multivariate!-input!-poly;
%note that this code works by using a local database of
%fluid variables that are updated by the subroutines directly
%called here. this allows for the relativly complicated
%interaction between flow of data and control that occurs in
%the factorization algorithm;
    factor!-trace <<
      prin2!* "Univariate polynomial="; printsf poly;
      printstr
         "The polynomial is univariate, primitive and square-free";
      printstr "so we can treat it slightly more specifically. We";
      printstr "factorise mod several primes,then pick the best one";
      printstr "to use in the Hensel construction." >>;
    initialize!-univariate!-fluids poly;
            % set up the fluids to start things off;
tryagain:
    get!-some!-random!-primes();
    choose!-the!-best!-prime();
      if irreducible then <<
        univariate!-factors:=list univariate!-input!-poly;
        goto exit >>
      else if bad!-case then <<
        bad!-case:=nil; goto tryagain >>;
    reconstruct!-factors!-over!-integers();
      if irreducible then <<
        univariate!-factors:=list univariate!-input!-poly;
        goto exit >>;
exit:
    factor!-trace <<
      printstr "The univariate factors are:";
      for each ff in univariate!-factors do printsf ff >>;
    return univariate!-factors
   end;


%**********************************************************************
% univariate factorization part 1. initialization and setting fluids;


symbolic procedure initialize!-univariate!-fluids u;
% Set up the fluids to be used in factoring primitive poly;
  begin
    if !*force!-prime then <<
      no!-of!-random!-primes:=1;
      no!-of!-best!-primes:=1 >>
    else <<
      no!-of!-random!-primes:=5;
            % we generate this many modular images and calculate
            % their factor counts;
      no!-of!-best!-primes:=3;
            % we find the modular factors of this many;
      >>;
    univariate!-input!-poly:=u;
    target!-factor!-count:=ldeg u
  end;


%**********************************************************************;
% univariate factorization part 2. creating modular images and picking
%  the best one;


symbolic procedure get!-some!-random!-primes();
% here we create a number of random primes to reduce the input mod p;
  begin scalar chosen!-prime,poly!-mod!-p,i;
    valid!-primes:=mkvect no!-of!-random!-primes;
    i:=0;
    while i < no!-of!-random!-primes do <<
      poly!-mod!-p:=
        find!-a!-valid!-prime(lc univariate!-input!-poly,
                    univariate!-input!-poly,nil);
      if not(poly!-mod!-p='not!-square!-free) then <<
        i:=iadd1 i;
        putv(valid!-primes,i,chosen!-prime . poly!-mod!-p);
        forbidden!-primes:=chosen!-prime . forbidden!-primes
        >>
      >>
  end;

symbolic procedure choose!-the!-best!-prime();
% given several random primes we now choose the best by factoring
% the poly mod its chosen prime and taking one with the
% lowest factor count as the best for hensel growth;
  begin scalar split!-list,poly!-mod!-p,null!-space!-basis,
               known!-factors,w,n;
    modular!-info:=mkvect no!-of!-random!-primes;
    for i:=1:no!-of!-random!-primes do <<
      w:=getv(valid!-primes,i);
      get!-factor!-count!-mod!-p(i,cdr w,car w,nil) >>;
    split!-list:=sort(split!-list,function lessppair);
            % this now contains a list of pairs (m . n) where
            % m is the no: of factors in set no: n. the list
            % is sorted with best split (smallest m) first;
    if caar split!-list = 1 then <<
      irreducible:=t; return nil >>;
    w:=split!-list;
    for i:=1:no!-of!-best!-primes do <<
      n:=cdar w;
      get!-factors!-mod!-p(n,car getv(valid!-primes,n));
      w:=cdr w >>;
            % pick the best few of these and find out their
            % factors mod p;
    split!-list:=delete(w,split!-list);
            % throw away the other sets;
    check!-degree!-sets(no!-of!-best!-primes,nil);
            % the best set is pointed at by best!-set!-pointer;
    one!-complete!-deg!-analysis!-done:=t;
    factor!-trace <<
      w:=getv(valid!-primes,best!-set!-pointer);
      prin2!* "The chosen prime is "; printstr car w;
      prin2!* "The polynomial mod "; prin2!* car w;
      printstr ", made monic, is:";
      printsf cdr w;
      printstr "and the factors of this modular polynomial are:";
      for each x in getv(modular!-info,best!-set!-pointer)
         do printsf x;
      >>
  end;



%**********************************************************************;
% univariate factorization part 3. reconstruction of the
% chosen image over the integers;


symbolic procedure reconstruct!-factors!-over!-integers();
% the hensel construction from modular case to univariate
% over the integers;
  begin scalar best!-modulus,best!-factor!-count,input!-polynomial,
    input!-leading!-coefficient,best!-known!-factors,s;
    s:=getv(valid!-primes,best!-set!-pointer);
    best!-known!-factors:=getv(modular!-info,best!-set!-pointer);
    input!-leading!-coefficient:=lc univariate!-input!-poly;
    best!-modulus:=car s;
    best!-factor!-count:=length best!-known!-factors;
    input!-polynomial:=univariate!-input!-poly;
    univariate!-factors:=reconstruct!.over!.integers();
    if irreducible then return t;
    number!-of!-factors:=length univariate!-factors;
    if number!-of!-factors=1 then return irreducible:=t
  end;


symbolic procedure reconstruct!.over!.integers();
  begin scalar w,lclist,non!-monic;
    set!-modulus best!-modulus;
    for i:=1:best!-factor!-count do
      lclist:=input!-leading!-coefficient . lclist;
    if not (input!-leading!-coefficient=1) then <<
      best!-known!-factors:=
        for each ff in best!-known!-factors collect
          multf(input!-leading!-coefficient,!*mod2f ff);
      non!-monic:=t;
      factor!-trace <<
        printstr
           "(a) Now the polynomial is not monic so we multiply each";
        printstr
           "of the modular factors, f(i), by the absolute value of";
        prin2!* "the leading coefficient: ";
        prin2!* input!-leading!-coefficient; printstr '!.;
        printstr "To bring the polynomial into agreement with this, we";
        prin2!* "multiply it by ";
        if best!-factor!-count > 2 then
          << prin2!* input!-leading!-coefficient; prin2!* "**";
            printstr isub1 best!-factor!-count >>
        else printstr input!-leading!-coefficient >> >>;
    w:=uhensel!.extend(input!-polynomial,
      best!-known!-factors,lclist,best!-modulus);
    if irreducible then return t;
    if car w ='ok then return cdr w
    else errorf w
  end;


% Now some special treatment for cyclotomic polynomials;

symbolic procedure testx!*!*n!+1 u;
  not domainp u and (
    lc u=1 and
    red u = 1);


symbolic procedure testx!*!*n!-1 u;
  not domainp u and (
    lc u=1 and
    red u = -1);


symbolic procedure factorizex!*!*n!+1(var,degree,vorder);
% Deliver factors of (VAR**VORDER)**DEGREE+1 given that it is
% appropriate to treat VAR**VORDER as a kernel;
  if evenp degree then factorizex!*!*n!+1(var,degree/2,2*vorder)
  else begin
    scalar w;
    w := factorizex!*!*n!-1(var,degree,vorder);
    w := negf car w . cdr w;
    return for each p in w collect negate!-variable(var,2*vorder,p)
  end;

symbolic procedure negate!-variable(var,vorder,p);
% VAR**(VORDER/2) -> -VAR**(VORDER/2) in the polynomial P;
  if domainp p then p
  else if mvar p=var then
    if remainder(ldeg p,vorder)=0 then
            lt p .+ negate!-variable(var,vorder,red p)
    else (lpow p .* negf lc p) .+ negate!-variable(var,vorder,red p)
  else (lpow p .* negate!-variable(var,vorder,lc p)) .+
        negate!-variable(var,vorder,red p);


symbolic procedure integer!-factors n;
% Return integer factors of N, with attached multiplicities. Assumes
% that N is fairly small;
  begin
    scalar l,q,m,w;
% L is list of results generated so far, Q is current test divisor,
% and M is associated multiplicity;
    if n=1 then return '((1 . 1));
    q := 2; m := 0;
    % Test divide by 2,3,5,7,9,11,13,...
top:
    w := divide(n,q);
    while cdr w=0 do << n := car w; w := divide(n,q); m := m+1 >>;
    if not m=0 then l := (q . m) . l;
    if q>car w then <<
      if not n=1 then l := (n . 1) . l;
      return reversewoc l >>;
%   q := ilogor(1,iadd1 q);
    q := iadd1 q;
    if q #> 3 then q := iadd1 q;
    m := 0;
    go to top
  end;


symbolic procedure factored!-divisors fl;
% FL is an association list of primes and exponents. Return a list
% of all subsets of this list, i.e. of numbers dividing the
% original integer. Exclude '1' from the list;
  if null fl then nil
  else begin
    scalar l,w;
    w := factored!-divisors cdr fl;
    l := w;
    for i := 1:cdar fl do <<
      l := list (caar fl . i) . l;
      for each p in w do
        l := ((caar fl . i) . p) . l >>;
    return l
  end;

symbolic procedure factorizex!*!*n!-1(var,degree,vorder);
  if evenp degree then append(factorizex!*!*n!+1(var,degree/2,vorder),
                              factorizex!*!*n!-1(var,degree/2,vorder))
  else if degree=1 then list((mksp(var,vorder) .* 1) .+ (-1))
  else begin
    scalar facdeg;
    facdeg := '((1 . 1)) . factored!-divisors integer!-factors degree;
    return for each fl in facdeg
       collect cyclotomic!-polynomial(var,fl,vorder)
  end;

symbolic procedure cyclotomic!-polynomial(var,fl,vorder);
% Create Psi<degree>(var**order)
% where degree is given by the association list of primes and
% multiplicities FL;
  if not cdar fl=1 then
    cyclotomic!-polynomial(var,(caar fl . sub1 cdar fl) . cdr fl,
                           vorder*caar fl)
  else if cdr fl=nil then
     if caar fl=1 then (mksp(var,vorder) .* 1) .+ (-1)
     else quotfail((mksp(var,vorder*caar fl) .* 1) .+ (-1),
                   (mksp(var,vorder) .* 1) .+ (-1))
  else quotfail(cyclotomic!-polynomial(var,cdr fl,vorder*caar fl),
                cyclotomic!-polynomial(var,cdr fl,vorder));



endmodule;


module imageset;

% Authors: A. C. Norman and P. M. A. Moore, 1979;

fluid '(!*force!-prime
        !*force!-zero!-set
        !*timings
        !*trfac
        bad!-case
        chosen!-prime
        current!-modulus
        f!-numvec
        factor!-level
        factor!-trace!-list
        factor!-x
        factored!-lc
        forbidden!-primes
        forbidden!-sets
        image!-content
        image!-lc
        image!-mod!-p
        image!-poly
        image!-set
        image!-set!-modulus
        kord!*
        m!-image!-variable
        modulus!/2
        multivariate!-input!-poly
        no!-of!-primes!-to!-try
        othervars
        polyzero
        save!-zset
        usable!-set!-found
        vars!-to!-kill
        zero!-set!-tried
        zerovarset
        zset);


%*******************************************************************;
%
%      this section deals with the image sets used in
%      factorising multivariate polynomials according
%      to wang's theories.
%       ref:  math. comp. vol.32 no.144 oct 1978 pp 1217-1220
%        'an improved multivariate polynomial factoring algorithm'
%
%*******************************************************************;


%*******************************************************************;
%    first we have routines for generating the sets
%*******************************************************************;


symbolic procedure generate!-an!-image!-set!-with!-prime
                      good!-set!-needed;
% given a multivariate poly (in a fluid) we generate an image set
% to make it univariate and also a random prime to use in the
% modular factorization. these numbers are random except that
% we will not allow anything in forbidden!-sets or forbidden!-primes;
  begin scalar currently!-forbidden!-sets,u,wtime;
    u:=multivariate!-input!-poly;
            % a bit of a handful to type otherwise!!!!   ;
    image!-set:=nil;
    currently!-forbidden!-sets:=forbidden!-sets;
tryanotherset:
    if image!-set then
      currently!-forbidden!-sets:=image!-set .
                                currently!-forbidden!-sets;
    wtime:=time();
    image!-set:=get!-new!-set currently!-forbidden!-sets;
%           princ "Trying imageset= ";
%           printc image!-set;
    trace!-time <<
      display!-time("    New image set found in ",time()-wtime);
      wtime:=time() >>;
    image!-lc:=make!-image!-lc!-list(lc u,image!-set);
            % list of image lc's wrt different variables in IMAGE-SET;
%    princ "Image set to try is:";% printc image!-set;
%    prin2!* "L.C. of poly is:";% printsf lc u;
%    printc "Image l.c.s with variables substituted on order:";
%    for each imlc in image!-lc do printsf imlc;
    trace!-time
      display!-time("    Image of lc made in ",time()-wtime);
    if (caar image!-lc)=0 then goto tryanotherset;
    wtime:=time();
    image!-poly:=make!-image(u,image!-set);
    trace!-time <<
      display!-time("    Image poly made in ",time()-wtime);
      wtime:=time() >>;
    image!-content:=get!.content image!-poly;
            % note: the content contains the image variable if it
            % is a factor of the image poly;
    trace!-time
      display!-time("    Content found in ",time()-wtime);
    image!-poly:=quotfail(image!-poly,image!-content);
            % make sure the image polynomial is primitive which includes
            % making the leading coefft positive (-ve content if
            % necessary).
            % If the image polynomial was of the form k*v^2 where v is
            % the image variable then GET.CONTENT will have taken out
            % one v and the k leaving the polynomial v here.
            % Divisibility by v here thus indicates that the image was
            % not square free, and so we will not be able to find a
            % sensible prime to use.
    if not didntgo quotf(image!-poly,!*k2f m!-image!-variable) then
        go to tryanotherset;
    wtime:=time();
    image!-mod!-p:=find!-a!-valid!-prime(image!-lc,image!-poly,
      not numberp image!-content);
    if image!-mod!-p='not!-square!-free then goto tryanotherset;
    trace!-time <<
      display!-time("    Prime and image mod p found in ",time()-wtime);
      wtime:=time() >>;
    if factored!-lc then
      if f!-numvec:=unique!-f!-nos(factored!-lc,image!-content,
          image!-set) then <<
        usable!-set!-found:=t;
        trace!-time
          display!-time("    Nos for lc found in ",time()-wtime) >>
      else <<
        trace!-time display!-time("    Nos for lc failed in ",
            time()-wtime);
        if (not usable!-set!-found) and good!-set!-needed then
          goto tryanotherset >>
  end;


symbolic procedure get!-new!-set forbidden!-s;
% associate each variable in vars-to-kill with a random no. mod
% image-set-modulus. If the boolean tagged with a variable is true then
% a value of 1 or 0 is no good and so rejected, however all other
% variables can take these values so they are tried exhaustively before
% using truly random values. sets in forbidden!-s not allowed;
  begin scalar old!.m,alist,n,nextzset,w;
    if zero!-set!-tried then <<
      if !*force!-zero!-set then
        errorf "Zero set tried - possibly it was invalid";
      image!-set!-modulus:=iadd1 image!-set!-modulus;
      old!.m:=set!-modulus image!-set!-modulus;
      alist:=for each v in vars!-to!-kill collect
      << n:=modular!-number next!-random!-number();
         if n>modulus!/2 then n:=n-current!-modulus;
         if cdr v then <<
           while n=0
              or n=1
              or (n = (isub1 current!-modulus)) do
             n:=modular!-number next!-random!-number();
           if n>modulus!/2 then n:=n-current!-modulus >>;
         car v . n >> >>
    else <<
      old!.m:=set!-modulus image!-set!-modulus;
      nextzset:=car zset;
      alist:=for each zv in zerovarset collect <<
        w:=zv . car nextzset;
        nextzset:=cdr nextzset;
        w >>;
      if othervars then alist:=
        append(alist,for each v in othervars collect <<
          n:=modular!-number next!-random!-number();
          while n=0
             or n=1
             or (n = (isub1 current!-modulus)) do
            n:=modular!-number next!-random!-number();
          if n>modulus!/2 then n:=n-current!-modulus;
          v . n >>);
      if null(zset:=cdr zset) then
        if null save!-zset then zero!-set!-tried:=t
        else zset:=make!-next!-zset save!-zset;
      alist:=for each v in cdr kord!* collect atsoc(v,alist);
            % Puts the variables in alist in the right order;
      >>;
    set!-modulus old!.m;
    return if member(alist,forbidden!-s) then
        get!-new!-set forbidden!-s
      else alist
  end;


%**********************************************************************
% now given an image/univariate polynomial find a suitable random prime;


symbolic procedure find!-a!-valid!-prime(lc!-u,u,factor!-x);
% finds a suitable random prime for reducing a poly mod p.
% u is the image/univariate poly. we are not allowed to use
% any of the primes in forbidden!-primes (fluid).
% lc!-u is either numeric or (in the multivariate case) a list of
% images of the lc;
  begin scalar currently!-forbidden!-primes,res,prime!-count,v,w;
    if factor!-x then u:=multf(u,v:=!*k2f m!-image!-variable);
    chosen!-prime:=nil;
    currently!-forbidden!-primes:=forbidden!-primes;
    prime!-count:=1;
tryanotherprime:
    if chosen!-prime then
      currently!-forbidden!-primes:=chosen!-prime .
                                 currently!-forbidden!-primes;
    chosen!-prime:=get!-new!-prime currently!-forbidden!-primes;
    set!-modulus chosen!-prime;
    if not atom lc!-u then <<
      w:=lc!-u;
      while w and
           ((domainp caar w and not(modular!-number caar w = 0))
        or not (domainp caar w or
                modular!-number l!-numeric!-c(caar w,cdar w)=0)) do
        w:=cdr w;
      if w then goto tryanotherprime >>
    else if modular!-number lc!-u=0 then goto tryanotherprime;
    res:=monic!-mod!-p reduce!-mod!-p u;
    if not square!-free!-mod!-p res then
      if multivariate!-input!-poly
         and (prime!-count:=prime!-count+1)>no!-of!-primes!-to!-try
        then <<no!-of!-primes!-to!-try := no!-of!-primes!-to!-try+1;
               res:='not!-square!-free>>
      else goto tryanotherprime;
    if factor!-x and not(res='not!-square!-free) then
      res:=quotfail!-mod!-p(res,!*f2mod v);
    return res
 end;

symbolic procedure get!-new!-prime forbidden!-p;
% get a small prime that is not in the list forbidden!-p;
% we pick one of the first 10 primes if we can;
  if !*force!-prime then !*force!-prime
  else begin scalar p,primes!-done;
    for each pp in forbidden!-p do
      if pp<32 then primes!-done:=pp.primes!-done;
tryagain:
    if null(p:=random!-teeny!-prime primes!-done) then <<
      p:=random!-small!-prime();
      primes!-done:='all >>
    else primes!-done:=p . primes!-done;
    if member(p,forbidden!-p) then goto tryagain;
    return p
  end;

%***********************************************************************
% find the numbers associated with each factor of the leading
% coefficient of our multivariate polynomial. this will help
% to distribute the leading coefficient later.;



symbolic procedure unique!-f!-nos(v,cont!.u0,im!.set);
% given an image set (im!.set), this finds the numbers associated with
% each factor in v subject to wang's condition (2) on the image set.
% this is an implementation of his algorithm n. if the condition
% is met the result is a vector containing the images of each factor
% in v, otherwise the result is nil;
  begin scalar d,k,q,r,lc!.image!.vec;
            % v's integer factor is at the front:  ;
    k:=length cdr v;
            % no. of non-trivial factors of v;
    if not numberp cont!.u0 then cont!.u0:=lc cont!.u0;
    putv(d:=mkvect k,0,abs(cont!.u0 * car v));
            % d will contain the special numbers to be used in the
            % loop below;
    putv(lc!.image!.vec:=mkvect k,0,abs(cont!.u0 * car v));
            % vector for result with 0th entry filled in;
    v:=cdr v;
            % throw away integer factor of v;
            % k is no. of non-trivial factors (say f(i)) in v;
            % d will contain the nos. associated with each f(i);
            % v is now a list of the f(i) (and their multiplicities);
    for i:=1:k do
    << q:=abs make!-image(caar v,im!.set);
       putv(lc!.image!.vec,i,q);
       v:=cdr v;
       for j:=isub1 i step -1 until 0 do
       << r:=getv(d,j);
          while not onep r do
          << r:=gcd(r,q); q:=q/r >>;
          if onep q then <<lc!.image!.vec:=nil; j := -1>>
            % if q=1 here then we have failed the condition so exit;
          >>;
      if null lc!.image!.vec then i := k+1 else putv(d,i,q);
            % else q is the ith number we want;
   >>;
    return lc!.image!.vec
  end;

symbolic procedure get!.content u;
% u is a univariate square free poly. gets the content of u (=integer);
% if lc u is negative then the minus sign is pulled out as well;
% nb. the content includes the variable if it is a factor of u;
  begin scalar c;
    c:=if poly!-minusp u then -(numeric!-content u)
       else numeric!-content u;
    if not didntgo quotf(u,!*k2f m!-image!-variable) then
      c:=adjoin!-term(mksp(m!-image!-variable,1),c,polyzero);
    return c
  end;


%********************************************************************;
%    finally we have the routines that use the numbers generated
%    by unique.f.nos to determine the true leading coeffts in
%    the multivariate factorization we are doing and which image
%    factors will grow up to have which true leading coefft.
%********************************************************************;




symbolic procedure distribute!.lc(r,im!.factors,s,v);
% v is the factored lc of a poly, say u, whose image factors (r of
% them) are in the vector im.factors. s is a list containing the
% image information including the image set, the image poly etc.
%  this uses wang's ideas for distributing the factors in v over
% those in im.factors. result is (delta . vector of the lc's of
% the full factors of u) , where delta is the remaining integer part
% of the lc that we have been unable to distribute.             ;
  (lambda factor!-level;
  begin scalar k,delta,div!.count,q,uf,i,d,max!.mult,f,numvec,
               dvec,wvec,dtwid,w;
    delta:=get!-image!-content s;
            % the content of the u image poly;
    dist!.lc!.msg1(delta,im!.factors,r,s,v);
    v:=cdr v;
            % we are not interested in the numeric factors of v;
    k:=length v;
            % number of things to distribute;
    numvec:=get!-f!-numvec s;
            % nos. associated with factors in v;
    dvec:=mkvect r;
    wvec:=mkvect r;
    for j:=1:r do <<
      putv(dvec,j,1);
      putv(wvec,j,delta*lc getv(im!.factors,j)) >>;
            % result lc's will go into dvec which we initialize to 1's;
            % wvec is a work vector that we use in the division process
            % below;
    v:=reverse v;
    for j:=k step -1 until 1 do
    << % (for each factor in v, call it f(j) );
      f:=caar v;
            % f(j) itself;
      max!.mult:=cdar v;
            % multiplicity of f(j) in v (=lc u);
      v:=cdr v;
      d:=getv(numvec,j);
            % number associated with f(j);
      i:=1; % we trial divide d into lc of each image
            % factor starting with 1st;
      div!.count:=0;
            % no. of d's that have been distributed;
      factor!-trace <<
        prin2!* "f("; prin2!* j; prin2!* ")= "; printsf f;
        prin2!* "There are "; prin2!* max!.mult;
        printstr " of these in the leading coefficient.";
        prin2!* "The absolute value of the image of f("; prin2!* j;
        prin2!* ")= "; printstr d >>;
      while ilessp(div!.count,max!.mult)
        and not igreaterp(i,r) do
      << q:=divide(getv(wvec,i),d);
            % first trial division;
        factor!-trace <<
          prin2!* "  Trial divide into ";
          prin2!* getv(wvec,i); printstr " :" >>;
        while (zerop cdr q) and ilessp(div!.count,max!.mult) do
        << putv(dvec,i,multf(getv(dvec,i),f));
            % f(j) belongs in lc of ith factor;
          factor!-trace <<
            prin2!* "    It goes so an f("; prin2!* j;
            prin2!* ") belongs in ";
            printsf getv(im!.factors,i);
            printstr "  Try again..." >>;
          div!.count:=iadd1 div!.count;
            % another d done;
          putv(wvec,i,car q);
            % save the quotient for next factor to distribute;
          q:=divide(car q,d);
            % try again;
        >>;
        i:=iadd1 i;
            % as many d's as possible have gone into that
            % factor so now try next factor;
        factor!-trace
           <<printstr "    no good so try another factor ..." >>>>;
            % at this point the whole of f(j) should have been
            % distributed by dividing d the maximum no. of times
            % (= max!.mult), otherwise we have an extraneous factor;
      if ilessp(div!.count,max!.mult) then
        <<bad!-case:=t; div!.count := max!.mult>>
    >>;
    if bad!-case then return;
    dist!.lc!.msg2(dvec,im!.factors,r);
    if onep delta then
    << for j:=1:r do <<
         w:=lc getv(im!.factors,j) /
          evaluate!-in!-order(getv(dvec,j),get!-image!-set s);
         if w<0 then begin
           scalar oldpoly;
           delta:= -delta;
           oldpoly:=getv(im!.factors,j);
           putv(im!.factors,j,negf oldpoly);
            % to keep the leading coefficients positive we negate the
            % image factors when necessary;
           multiply!-alphas(-1,oldpoly,getv(im!.factors,j));
            % remember to fix the alphas as well;
         end;
         putv(dvec,j,multf(abs w,getv(dvec,j))) >>;
      dist!.lc!.msg3(dvec,im!.factors,r);
      return (delta . dvec)
    >>;
      % if delta=1 then we know the true lc's exactly so put in their
      % integer contents and return with result.
      % otherwise try spreading delta out over the factors:      ;
    dist!.lc!.msg4 delta;
    for j:=1:r do
    << dtwid:=evaluate!-in!-order(getv(dvec,j),get!-image!-set s);
       uf:=getv(im!.factors,j);
       d:=gcddd(lc uf,dtwid);
       putv(dvec,j,multf(lc uf/d,getv(dvec,j)));
       putv(im!.factors,j,multf(dtwid/d,uf));
            % have to fiddle the image factors by an integer multiple;
       multiply!-alphas!-recip(dtwid/d,uf,getv(im!.factors,j));
            % fix the alphas;
       delta:=delta/(dtwid/d)
    >>;
    % now we've done all we can to distribute delta so we return with
    % what's left:                                    ;
    if delta<=0 then
      errorf list("FINAL DELTA IS -VE IN DISTRIBUTE!.LC",delta);
    factor!-trace <<
      printstr "     Finally we have:";
      for j:=1:r do <<
        prinsf getv(im!.factors,j);
        prin2!* " with l.c. ";
        printsf getv(dvec,j) >> >>;
    return (delta . dvec)
  end) (factor!-level * 10);

symbolic procedure dist!.lc!.msg1(delta,im!.factors,r,s,v);
    factor!-trace <<
      terpri(); terpri();
      printstr "We have a polynomial whose image factors (call";
      printstr "them the IM-factors) are:";
      prin2!* delta; printstr " (= numeric content, delta)";
      printvec(" f(",r,")= ",im!.factors);
      prin2!* "  wrt the image set: ";
      for each x in get!-image!-set s do <<
        prinvar car x; prin2!* "="; prin2!* cdr x; prin2!* ";" >>;
      terpri!*(nil);
      printstr "We also have its true multivariate leading";
      printstr "coefficient whose factors (call these the";
      printstr "LC-factors) are:";
      fac!-printfactors v;
      printstr "We want to determine how these LC-factors are";
      printstr "distributed over the leading coefficients of each";
      printstr "IM-factor.  This enables us to feed the resulting";
      printstr "image factors into a multivariate Hensel";
      printstr "construction.";
      printstr "We distribute each LC-factor in turn by dividing";
      printstr "its image into delta times the leading coefficient";
      printstr "of each IM-factor until it finds one that it";
      printstr "divides exactly. The image set is chosen such that";
      printstr "this will only happen for the IM-factors to which";
      printstr "this LC-factor belongs - (there may be more than";
      printstr "one if the LC-factor occurs several times in the";
      printstr "leading coefficient of the original polynomial).";
      printstr "This choice also requires that we distribute the";
      printstr "LC-factors in a specific order:"
      >>;

symbolic procedure dist!.lc!.msg2(dvec,im!.factors,r);
    factor!-trace <<
      printstr "The leading coefficients are now correct to within an";
      printstr "integer factor and are as follows:";
      for j:=1:r do <<
        prinsf getv(im!.factors,j);
        prin2!* " with l.c. ";
        printsf getv(dvec,j) >> >>;

symbolic procedure dist!.lc!.msg3(dvec,im!.factors,r);
      factor!-trace <<
        printstr "Since delta=1, we have no non-trivial content of the";
        printstr
          "image to deal with so we know the true leading coefficients";
        printstr
          "exactly.  We fix the signs of the IM-factors to match those";
        printstr "of their true leading coefficients:";
        for j:=1:r do <<
          prinsf getv(im!.factors,j);
          prin2!* " with l.c. ";
          printsf getv(dvec,j) >> >>;

symbolic procedure dist!.lc!.msg4 delta;
    factor!-trace <<
      prin2!* " Here delta is not 1 meaning that we have a content, ";
      printstr delta;
      printstr "of the image to distribute among the factors somehow.";
      printstr "For each IM-factor we can divide its leading";
      printstr "coefficient by the image of its determined leading";
      printstr "coefficient and see if there is a non-trivial result.";
      printstr "This will indicate a factor of delta belonging to this";
      printstr "IM-factor's leading coefficient." >>;

endmodule;


module pfactor;  % Factorization of polynomials modulo p.

% Author: A. C. Norman, 1978.

fluid '(!*backtrace
        !*gcd
        base!-time
        current!-modulus
        gc!-base!-time
        last!-displayed!-gc!-time
        last!-displayed!-time
        m!-image!-variable
        modular!-info
        modulus!/2
        user!-prime);

symbolic procedure pfactor(q,p);
   % Q is a standard form. Factorize and return the factors mod p.
   begin scalar base!-time,last!-displayed!-time,
         gc!-base!-time,last!-displayed!-gc!-time,
         user!-prime,current!-modulus,modulus!/2,r,x;
    set!-time();
    if not numberp p then typerr(p,"number")
     else if not primep p then typerr(p,"prime");
    user!-prime:=p;
    set!-modulus p;
    if domainp q or null reduce!-mod!-p lc q then
       printc "*** Degenerate case in modular factorization";
    if not (length variables!-in!-form q=1) then
       rederr "Multivariate input to modular factorization";
    r:=reduce!-mod!-p q;
%   LNCOEFF := LC R;
    x := lnc r;
    r :=monic!-mod!-p r;
    print!-time "About to call FACTOR-FORM-MOD-P";
    r:=errorset(list('factor!-form!-mod!-p,mkquote r),t,!*backtrace);
    print!-time "FACTOR-FORM-MOD-P returned";
    if not errorp r then return x . car r;
    printc "****** FACTORIZATION FAILED******";
    return list(1,prepf q)   % 1 needed by factorize.
  end;


symbolic procedure factor!-form!-mod!-p p;
% input:
% p is a reduce standard form that is to be factorized
% mod prime;
% result:
% ((p1 . x1) (p2 . x2) .. (pn . xn))
% where p<i> are standard forms and x<i> are integers,
% and p= product<i> p<i>**x<i>;
    sort!-factors factorize!-by!-square!-free!-mod!-p p;


symbolic procedure factorize!-by!-square!-free!-mod!-p p;
    if p=1 then nil
    else if domainp p then (p . 1) . nil
    else
     begin
      scalar dp,v;
      v:=(mksp(mvar p,1).* 1) .+ nil;
      dp:=0;
      while evaluate!-mod!-p(p,mvar v,0)=0 do <<
        p:=quotfail!-mod!-p(p,v);
        dp:=dp+1 >>;
      if dp>0 then return ((v . dp) .
        factorize!-by!-square!-free!-mod!-p p);
      dp:=derivative!-mod!-p p;
      if dp=nil then <<
%here p is a something to the power current!-modulus;
        p:=divide!-exponents!-by!-p(p,current!-modulus);
        p:=factorize!-by!-square!-free!-mod!-p p;
        return multiply!-multiplicities(p,current!-modulus) >>;
      dp:=gcd!-mod!-p(p,dp);
      if dp=1 then return factorize!-pp!-mod!-p p;
%now p is not square-free;
      p:=quotfail!-mod!-p(p,dp);
%factorize p and dp separately;
      p:=factorize!-pp!-mod!-p p;
      dp:=factorize!-by!-square!-free!-mod!-p dp;
% i feel that this scheme is slightly clumsy, but
% square-free decomposition mod p is not as straightforward
% as square free decomposition over the integers, and pfactor
% is probably not going to be slowed down too badly by
% this;
      return mergefactors(p,dp)
   end;




%**********************************************************************;
% code to factorize primitive square-free polynomials mod p;



symbolic procedure divide!-exponents!-by!-p(p,n);
    if isdomain p then p
    else (mksp(mvar p,exactquotient(ldeg p,n)) .* lc p) .+
       divide!-exponents!-by!-p(red p,n);

symbolic procedure exactquotient(a,b);
  begin
    scalar w;
    w:=divide(a,b);
    if cdr w=0 then return car w;
    error(50,list("Inexact division",list(a,b,w)))
  end;


symbolic procedure multiply!-multiplicities(l,n);
    if null l then nil
    else (caar l . (n*cdar l)) .
        multiply!-multiplicities(cdr l,n);


symbolic procedure mergefactors(a,b);
% a and b are lists of factors (with multiplicities),
% merge them so that no factor occurs more than once in
% the result;
    if null a then b
    else mergefactors(cdr a,addfactor(car a,b));

symbolic procedure addfactor(a,b);
%add factor a into list b;
    if null b then list a
    else if car a=caar b then
      (car a . (cdr a + cdar b)) . cdr b
    else car b . addfactor(a,cdr b);

symbolic procedure factorize!-pp!-mod!-p p;
%input a primitive square-free polynomial p,
% output a list of irreducible factors of p;
  begin
    scalar vars;
    if p=1 then return nil
    else if isdomain p then return (p . 1) . nil;
% now I am certain that p is not degenerate;
    print!-time "primitive square-free case detected";
    vars:=variables!-in!-form p;
    if length vars=1 then return unifac!-mod!-p p;
    errorf "SHAMBLED IN PFACTOR - MULTIVARIATE CASE RESURFACED"
  end;

symbolic procedure unifac!-mod!-p p;
%input p a primitive square-free univariate polynomial
%output a list of the factors of p over z mod p;
  begin
    scalar modular!-info,m!-image!-variable;
    if isdomain p then return nil
    else if ldeg p=1 then return (p . 1) . nil;
    modular!-info:=mkvect 1;
    m!-image!-variable:=mvar p;
    get!-factor!-count!-mod!-p(1,p,user!-prime,nil);
    print!-time "Factor counts obtained";
    get!-factors!-mod!-p(1,user!-prime);
    print!-time "Actual factors extracted";
    return for each z in getv(modular!-info,1) collect (z . 1)
  end;

endmodule;


module vecpoly;

% Authors: A. C. Norman and P. M. A. Moore, 1979;

fluid '(current!-modulus safe!-flag);


%**********************************************************************;
% Routines for working with modular univariate polynomials
% stored as vectors. Used to avoid unwarranted storage management
% in the mod-p factorization process;


safe!-flag:=carcheck 0;


symbolic procedure copy!-vector(a,da,b);
% Copy A into B;
 << for i:=0:da do
      putv(b,i,getv(a,i));
    da >>;

symbolic procedure times!-in!-vector(a,da,b,db,c);
% Put the product of A and B into C and return its degree.
% C must not overlap with either A or B;
  begin
    scalar dc,ic,w;
    if da#<0 or db#<0 then return minus!-one;
    dc:=da#+db;
    for i:=0:dc do putv(c,i,0);
    for ia:=0:da do <<
      w:=getv(a,ia);
      for ib:=0:db do <<
        ic:=ia#+ib;
        putv(c,ic,modular!-plus(getv(c,ic),
          modular!-times(w,getv(b,ib)))) >> >>;
    return dc
  end;


symbolic procedure quotfail!-in!-vector(a,da,b,db);
% Overwrite A with (A/B) and return degree of result.
% The quotient must be exact;
    if da#<0 then da
    else if db#<0 then errorf "Attempt to divide by zero"
    else if da#<db then errorf "Bad degrees in QUOTFAIL-IN-VECTOR"
    else begin
      scalar dc;
      dc:=da#-db; % Degree of result;
      for i:=dc step -1 until 0 do begin
        scalar q;
        q:=modular!-quotient(getv(a,db#+i),getv(b,db));
        for j:=0:db#-1 do
          putv(a,i#+j,modular!-difference(getv(a,i#+j),
            modular!-times(q,getv(b,j))));
        putv(a,db#+i,q)
      end;
      for i:=0:db#-1 do if getv(a,i) neq 0 then
        errorf "Quotient not exact in QUOTFAIL!-IN!-VECTOR";
      for i:=0:dc do
        putv(a,i,getv(a,db#+i));
      return dc
    end;


symbolic procedure remainder!-in!-vector(a,da,b,db);
% Overwrite the vector A with the remainder when A is
% divided by B, and return the degree of the result;
  begin
    scalar delta,db!-1,recip!-lc!-b,w;
    if db=0 then return minus!-one
    else if db=minus!-one then errorf "ATTEMPT TO DIVIDE BY ZERO";
    recip!-lc!-b:=modular!-minus modular!-reciprocal getv(b,db);
    db!-1:=db#-1; % Leading coeff of B treated specially, hence this;
    while not((delta:=da#-db) #< 0) do <<
      w:=modular!-times(recip!-lc!-b,getv(a,da));
      for i:=0:db!-1 do
        putv(a,i#+delta,modular!-plus(getv(a,i#+delta),
          modular!-times(getv(b,i),w)));
      da:=da#-1;
      while not(da#<0) and getv(a,da)=0 do da:=da#-1 >>;
    return da
  end;

symbolic procedure evaluate!-in!-vector(a,da,n);
% Evaluate A at N;
  begin
    scalar r;
    r:=getv(a,da);
    for i:=da#-1 step -1 until 0 do
      r:=modular!-plus(getv(a,i),
        modular!-times(r,n));
    return r
  end;

symbolic procedure gcd!-in!-vector(a,da,b,db);
% Overwrite A with the gcd of A and B. On input A and B are
% vectors of coefficients, representing polynomials
% of degrees DA and DB. Return DG, the degree of the gcd;
  begin
    scalar w;
    if da=0 or db=0 then << putv(a,0,1); return 0 >>
    else if da#<0 or db#<0 then errorf "GCD WITH ZERO NOT ALLOWED";
top:
% Reduce the degree of A;
    da:=remainder!-in!-vector(a,da,b,db);
    if da=0 then << putv(a,0,1); return 0 >>
    else if da=minus!-one then <<
      w:=modular!-reciprocal getv(b,db);
      for i:=0:db do putv(a,i,modular!-times(getv(b,i),w));
      return db >>;
% Now reduce degree of B;
    db:=remainder!-in!-vector(b,db,a,da);
    if db=0 then << putv(a,0,1); return 0 >>
    else if db=minus!-one then <<
      w:=modular!-reciprocal getv(a,da);
      if not (w=1) then
        for i:=0:da do putv(a,i,modular!-times(getv(a,i),w));
      return da >>;
    go to top
  end;



carcheck safe!-flag;


endmodule;


end;

Added r33/gentran.red version [34306458a2].























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
module util;    %%  GENTRAN Utility Functions  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Points:  ALL FUNCTIONS


symbolic$


% User-Accessible Primitive Function %
operator genstmtnum$

% User-Accessible Global Variables %
global '(genstmtincr!* genstmtnum!* tablen!*)$
share 'genstmtincr!*, 'genstmtnum!*, 'tablen!*$
genstmtincr!* := 1$
genstmtnum!*  := 25000$
tablen!*      := 4$

% GENTRAN Global Variables %
global '(!*lisparithexpops!* !*lispdefops!* !*lisplogexpops!*
         !*lispstmtgpops!* !*lispstmtops!* !*symboltable!*)$
!*lisparithexpops!* := '(expt minus plus quotient times)$
    %LISP arithmetic expression operators
!*lispdefops!*      := '(defun)$  %LISP function definition operator
!*lisplogexpops!*   := '(and equal geq greaterp leq lessp neq not or)$
    %LISP logical & relational exp operators
!*lispstmtgpops!*   := '(prog progn)$  %LISP statement group operators
!*lispstmtops!*     := '(break cond end for go read repeat
                         return setq stop while write)$
%LISP statement operators
!*symboltable!*     := '(!*main!*)$  %symbol table

global '(!*for!*)$


%%                                      %%
%% Statement Number Generation Function %%
%%                                      %%


procedure genstmtnum;
genstmtnum!* := genstmtnum!* + genstmtincr!*$


%%                                                        %%
%% Symbol Table Insertion, Retrieval & Deletion Functions %%
%%                                                        %%


procedure symtabput(name, type, value);
%                                                                      %
% CALL                                               INSERTS           %
% SymTabPut(subprogname, NIL,         NIL         )  subprogram name   %
% SymTabPut(subprogname, '!*Type!*,   subprogtype )  subprogram type   %
% SymTabPut(subprogname, '!*Params!*, paramlist   )  parameter list    %
% SymTabPut(subprogname, vname,  '(type d1 d2 ...))  type & dimensions %
%                                                    for variable,     %
%                                                    variable range,   %
%   if subprogname=NIL                               parameter, or     %
%      then subprogname <-- Car symboltable          function name     %
%                                                                      %
<<
    name := name or car !*symboltable!*;
    !*symboltable!* := name . delete(name, !*symboltable!*);
    if type memq '(!*type!* !*params!*) then
        put(name, type, value)
    else if type then
        begin
        scalar v, vtype, vdims, dec, decs;
        v := type;
        vtype := car value;
        vdims := cdr value;
        decs := get(name, '!*decs!*);
        dec := assoc(v, decs);
        decs := delete(dec, decs);
        vtype := vtype or (if length dec > 1 then cadr dec);
        vdims := vdims or (if length dec > 2 then cddr dec);
        dec := v . vtype . vdims;
        put(name, '!*decs!*, append(decs, list dec))
        end
>>$

procedure symtabget(name, type);
%                                                                      %
% CALL                                 RETRIEVES                       %
% SymTabGet(NIL,         NIL        )  all subprogram names            %
% SymTabGet(subprogname, '!*Type!*  )  subprogram type                 %
% SymTabGet(subprogname, '!*Params!*)  parameter list                  %
% SymTabGet(subprogname, vname      )  type & dimensions for variable, %
%                                      variable range, parameter, or   %
%                                      function name                   %
% SymTabGet(subprogname, '!*Decs!*  )  all types & dimensions          %
%                                                                      %
%   if subprogname=NIL & 2nd arg is non-NIL                            %
%      then subprogname <-- Car symboltable                            %
%                                                                      %
<<
    if type then name := name or car !*symboltable!*;
    if null name then
        !*symboltable!*
    else if type memq '(!*type!* !*params!* !*decs!*) then
        get(name, type)
    else
        assoc(type, get(name, '!*decs!*))
>>$

procedure symtabrem(name, type);
%                                                                      %
% CALL                                 DELETES                         %
% SymTabRem(subprogname, NIL        )  subprogram name                 %
% SymTabRem(subprogname, '!*Type!*  )  subprogram type                 %
% SymTabRem(subprogname, '!*Params!*)  parameter list                  %
% SymTabRem(subprogname, vname      )  type & dimensions for variable, %
%                                      variable range, parameter, or   %
%                                      function name                   %
% SymTabRem(subprogname, '!*Decs!*  )  all types & dimensions          %
%                                                                      %
%   if subprogname=NIL                                                 %
%      then subprogname <-- Car symboltable                            %
%                                                                      %
<<
    name := name or car !*symboltable!*;
    if null type then
        !*symboltable!* := delete(name, !*symboltable!*) or '(!*main!*)
    else if type memq '(!*type!* !*params!* !*decs!*) then
        remprop(name, type)
    else
        begin
        scalar v, dec, decs;
        v := type;
        decs := get(name, '!*decs!*);
        dec := assoc(v, decs);
        decs := delete(dec, decs);
        put(name, '!*decs!*, decs)
        end
>>$

procedure getvartype var;
begin
scalar type;
if listp var then
    var := car var;
type := symtabget(nil, var);
if type and length type >= 2 then
    type := cadr type
else
    type := nil;
return type
end$

procedure arrayeltp exp;
length symtabget(nil, car exp) > 2$


%%                                 %%
%% Functions for Making LISP Forms %%
%%                                 %%


procedure mkassign(var, exp);
list('setq, var, exp)$

procedure mkcond pairs;
'cond . pairs$

procedure mkdef(name, params, body);
append(list('defun, name, params), body)$

procedure mkreturn exp;
list('return, exp)$

procedure mkstmtgp(vars, stmts);
if numberp vars then
    'progn . stmts
else
    'prog . vars . stmts$


%% LISP Form Predicates %%


procedure lispassignp stmt;
   eqcar(stmt,'setq);

procedure lispbreakp form;
   eqcar(form,'break);

procedure lispcallp form;
listp form$

procedure lispcondp stmt;
   eqcar(stmt,'cond);

procedure lispdefp form;
   not atom form and car form memq !*lispdefops!*$

procedure lispexpp form;
atom form or
car form memq !*lisparithexpops!* or
car form memq !*lisplogexpops!* or
not (car form memq !*lispstmtops!*) and
not (car form memq !*lispstmtgpops!*) and
not (car form memq !*lispdefops!*)$

procedure lispendp form;
   eqcar(form,'end);

procedure lispforp form;
   eqcar(form,!*for!*);

procedure lispgop form;
   eqcar(form,'go);

procedure lisplabelp form;
atom form$

procedure lispprintp form;
   eqcar(form,'write);

procedure lispreadp form;
   eqcar(form,'read);

procedure lisprepeatp form;
   eqcar(form,'repeat);

procedure lispreturnp stmt;
   eqcar(stmt,'return);

procedure lispstmtp form;
atom form or
car form memq !*lispstmtops!* or
( atom car form and
  not (car form memq !*lisparithexpops!* or
       car form memq !*lisplogexpops!* or
       car form memq !*lispstmtgpops!* or
       car form memq !*lispdefops!*) )$

procedure lispstmtgpp form;
listp form and car form memq !*lispstmtgpops!*$

procedure lispstopp form;
   eqcar(form,'stop);

procedure lispwhilep form;
   eqcar(form,'while);


%%                                               %%
%% Type Predicates & Type List Forming Functions %%
%%                                               %%


procedure formtypelists varlists;
% ( (var TYPE d1 d2...)       ( (TYPE (var d1 d2...) ...)   %
%   :                     ==>   :                           %
%   (var TYPE d1 d2...) )       (TYPE (var d1 d2...) ...) ) %
begin
scalar type, typelists, tl;
for each vl in varlists do
<<
    type := cadr vl;
    if onep length(vl := delete(type, vl)) then
        vl := car vl;
    if (tl := assoc(type, typelists)) then
        typelists := delete(tl, typelists)
    else
        tl := list type;
    typelists := append(typelists, list append(tl, list vl))
>>;
return typelists
end$


procedure functionformp(stmt, name);
% Does stmt contain an assignment which assigns a value to name? %
% Does it contain a RETURN exp; stmt?                            %
% (i.e., (SETQ name exp) -or- (RETURN exp)                       %
if null stmt or atom stmt then
    nil
else if car stmt eq 'setq and cadr stmt eq name then
    t
else if car stmt eq 'return and cdr stmt then
    t
else
    eval('or . for each st in stmt collect functionformp(st, name))$

procedure implicitp type;
begin
scalar xtype, ximp, r;
xtype := explode2 type;
ximp := explode2 'implicit;
r := t;
repeat
    r := r and (car xtype eq car ximp)
until null(xtype := cdr xtype) or null(ximp := cdr ximp);
return r
end$


%%                 %%
%% Misc. Functions %%
%%                 %%


procedure insertcommas lst;
begin
scalar result;
if null lst then
    return nil;
result := list car lst;
while lst := cdr lst do
    result := car lst . '!, . result;
return reverse result
end$

procedure insertparens exp;
'!( . append(exp, list '!))$

procedure optype op;
get(op, '!*optype!*)$

put('minus,    '!*optype!*, 'unary )$
put('not,      '!*optype!*, 'unary )$
put('quotient, '!*optype!*, 'binary)$
put('expt,     '!*optype!*, 'binary)$
put('equal,    '!*optype!*, 'binary)$
put('neq,      '!*optype!*, 'binary)$
put('greaterp, '!*optype!*, 'binary)$
put('geq,      '!*optype!*, 'binary)$
put('lessp,    '!*optype!*, 'binary)$
put('leq,      '!*optype!*, 'binary)$
put('plus,     '!*optype!*, 'nary  )$
put('times,    '!*optype!*, 'nary  )$
put('and,      '!*optype!*, 'nary  )$
put('or,       '!*optype!*, 'nary  )$

procedure seqtogp lst;
if null lst or atom lst or lispstmtp lst or lispstmtgpp lst then
    lst
else if onep length lst and listp car lst then
    seqtogp car lst
else
    mkstmtgp(nil, for each st in lst collect seqtogp st)$

procedure stringtoatom a;
intern compress
    foreach c in append('!" . explode2 a, list '!")
        conc list('!!, c)$

procedure stripquotes a;
if atom a then
    intern compress
        for each c in explode2 a conc list('!!, c)
else if car a eq 'quote then
    stripquotes cadr a
else
    a$


endmodule;

module intrfc;    %%  GENTRAN Parsing Routines & Control Functions  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Points:
% DeclareStat, GENDECS, GenInStat (GentranIn), GenOutStat
% (GentranOutPush), GenPopStat (GentranPop), GenPushStat, GenShutStat
% (GentranShut), GenStat (Gentran), (GENTRANPAIRS),
% LiteralStat, SYM!-GENTRAN, SYM!-GENTRANIN, SYM!-GENTRANOUT,
% SYM!-GENTRANSHUT,
% SYM!-GENTRANPUSH, SYM!-GENTRANPOP


symbolic$


% GENTRAN Commands %
put('gentran,     'stat, 'genstat    )$
put('gentranin,   'stat, 'geninstat  )$
put('gentranout,  'stat, 'genoutstat )$
put('gentranshut, 'stat, 'genshutstat)$
put('gentranpush, 'stat, 'genpushstat)$
put('gentranpop,  'stat, 'genpopstat )$

% Form Analysis Function %
put('gentran,        'formfn, 'formgentran)$
put('gentranin,      'formfn, 'formgentran)$
put('gentranoutpush, 'formfn, 'formgentran)$
put('gentranshut,    'formfn, 'formgentran)$
put('gentranpop,     'formfn, 'formgentran)$

% GENTRAN Functions %
put('declare, 'stat, 'declarestat)$
put('literal, 'stat, 'literalstat)$

% GENTRAN Operators %
newtok '((!: !: !=)    lsetq )$  infix ::= $
newtok '((!: != !:)    rsetq )$  infix :=: $
newtok '((!: !: != !:) lrsetq)$  infix ::=:$

% User-Accessible Primitive Function %
operator gendecs$

% GENTRAN Mode Switches %
global '(!*gendecs)$
!*gendecs := t$
put('gendecs, 'simpfg, '((nil) (t (gendecs nil))))$
switch gendecs$

% GENTRAN Flags %
global '(
%%       !*GENTRANOPT
         !*gentranseg
         !*period)$
%%!*GENTRANOPT := NIL$
!*gentranseg := t$
switch gentranseg$

% User-Accessible Global Variable %
global '(gentranlang!*)$
share gentranlang!*$
gentranlang!* := 'fortran$

% GENTRAN Global Variable %
global '(!*term!* !*stdin!* !*stdout!* !*instk!* !*currin!* !*outstk!*
         !*currout!* !*outchanl!*)$
!*term!*     := (t . nil)$             %terminal filepair
!*stdin!*    := !*term!*$              %standard input filepair
!*stdout!*   := !*term!*$              %standard output filepair
!*instk!*    := list !*stdin!*$        %template file stack
!*currin!*   := car !*instk!*$         %current input filepair
!*outstk!*   := list !*stdout!*$       %output file stack
!*currout!*  := car !*outstk!*$        %current output filepair
!*outchanl!* := list cdr !*currout!*$  %current output channel list

global '(!*do!* !*for!*)$
off quotenewnam$
!*do!* := 'do$
!*for!* := 'for$
on quotenewnam$

% REDUCE Variables %
global '(cursym!* !*vars!*)$
fluid '(!*mode)$


%%                    %%
%%  PARSING ROUTINES  %%
%%                    %%


%%  GENTRAN Command Parsers  %%


procedure genstat;
%                     %
% GENTRAN             %
%     stmt            %
% [OUT f1,f2,...,fn]; %
%                     %
begin
scalar st;
flag('(out), 'delim);
st := xread t;
remflag('(out), 'delim);
if cursym!* eq 'out then
    return list('gentran, st, readfargs())
else if endofstmtp() then
    return list('gentran, st, nil)
else
    gentranerr('e, nil, "INVALID SYNTAX", nil)
end$


procedure geninstat;
%                     %
% GENTRANIN           %
%     f1,f2,...,fm    %
% [OUT f1,f2,...,fn]; %
%                     %
begin
scalar f1, f2;
flag('(out), 'delim);
f1 := xread nil;
if atom f1 then f1 := list f1 else f1 := cdr f1;
remflag('(out), 'delim);
if cursym!* eq 'out then
    f2 := readfargs();
return list('gentranin, f1, f2)
end$


procedure genoutstat;
%                          %
% GENTRANOUT f1,f2,...,fn; %
%                          %
list('gentranoutpush, readfargs())$


procedure genshutstat;
%                           %
% GENTRANSHUT f1,f2,...,fn; %
%                           %
list('gentranshut, readfargs())$


procedure genpushstat;
%                           %
% GENTRANPUSH f1,f2,...,fn; %
%                           %
list('gentranoutpush, readfargs())$


procedure genpopstat;
%                          %
% GENTRANPOP f1,f2,...,fn; %
%                          %
list('gentranpop, readfargs())$


%%  GENTRAN Function Parsers  %%


procedure declarestat;
%                              %
% DECLARE v1,v2,...,vn : type; %
%                              %
% DECLARE                      %
% <<                           %
%     v1,v2,...,vn1 : type1;   %
%     v1,v2,...,vn2 : type2;   %
%     .                        %
%     .                        %
%     v1,v2,...,vnn : typen    %
% >>;                          %
%                              %
begin
scalar res, varlst, type;
scan();
if cursym!* eq '!*lsqb!* then
<<
    scan();
    while cursym!* neq '!*rsqb!* do
    <<
        varlst := list xread1 'for;
        while cursym!* neq '!*colon!* do
            varlst := append(varlst, list xread 'for);
        type := declarestat1();
        res := append(res, list(type . varlst));
        if cursym!* eq '!*semicol!* then scan()
    >>;
    scan()
>>
else
<<
    varlst := list xread1 'for;
    while cursym!* neq '!*colon!* do
        varlst := append(varlst, list xread 'for);
    type := declarestat1();
    res := list (type . varlst);
>>;
if not endofstmtp() then
    gentranerr('e, nil, "INVALID SYNTAX", nil);
return ('declare . res)
end$

procedure declarestat1;
begin
scalar res;
scan();
if endofstmtp() then
    return nil;
if cursym!* eq 'implicit then
<<
    scan();
    res := intern compress append(explode 'implicit! , explode cursym!*)
>>
else
    res := cursym!*;
scan();
if cursym!* eq 'times then
<<
    scan();
    if numberp cursym!* then
    <<
        res := intern compress append(append(explode res, explode '!*),
                                      explode cursym!*);
        scan()
    >>
    else
        gentranerr('e, nil, "INVALID SYNTAX", nil)
>>;
return res
end$


procedure literalstat;
%                             %
% LITERAL arg1,arg2,...,argn; %
%                             %
begin
scalar res;
repeat
    res := append(res, list xread t)
until endofstmtp();
if atom res then
    return list('literal, res)
else if car res eq '!*comma!* then
    return rplaca(res, 'literal)
else
    return('literal . res)
end$


%%                           %%
%%  Symbolic Mode Functions  %%
%%                           %%


procedure sym!-gentran form;
eval formgentran(list('gentran, form, nil), !*vars!*, !*mode)$

procedure sym!-gentranin flist;
eval formgentran(list('gentranin,
                      if atom flist then list flist else flist,
                      nil),
                 !*vars!*, !*mode)$

procedure sym!-gentranout flist;
eval formgentran(list('gentranoutpush,
                      if atom flist then list flist else flist),
                 !*vars!*, !*mode)$

procedure sym!-gentranshut flist;
eval formgentran(list('gentranshut,
                      if atom flist then list flist else flist),
                 !*vars!*, !*mode)$

procedure sym!-gentranpush flist;
eval formgentran(list('gentranoutpush,
                      if atom flist then list flist else flist),
                 !*vars!*, !*mode)$

procedure sym!-gentranpop flist;
eval formgentran(list('gentranpop,
                      if atom flist then list flist else flist),
                 !*vars!*, !*mode)$


%%                           %%
%%  Form Analysis Functions  %%
%%                           %%


procedure formgentran(u, vars, mode);
(car u) . foreach arg in cdr u collect formgentran1(arg, vars, mode)$

procedure formgentran1(u, vars, mode);
if pairp u and not listp u then
    gentranerr('e, u, "SCALAR DEFINITIONS CANNOT BE TRANSLATED", nil)
else
if atom u then
    mkquote u
else if car u eq 'eval then
    list('aeval, form1(cadr u, vars, mode))
else if car u memq '(lsetq rsetq lrsetq) then
    % (LSETQ (var s1 s2 ... sn) exp)                                 %
    %   -> (SETQ (var (EVAL s1) (EVAL s2) ... (EVAL sn)) exp)        % 
    % (RSETQ var exp)                                                %
    %   -> (SETQ var (EVAL exp))                                     %
    % (LRSETQ (var s1 s2 ... sn) exp)                                %
    %   -> (SETQ (var (EVAL s1) (EVAL s2) ... (EVAL sn)) (EVAL exp)) %
    begin
    scalar op, lhs, rhs;
    op := car u;
    lhs := cadr u;
    rhs := caddr u;
    if op memq '(lsetq lrsetq) and listp lhs then
        lhs := car lhs . foreach s in cdr lhs collect list('eval, s);
    if op memq '(rsetq lrsetq) then
        rhs := list('eval, rhs);
    return formgentran1(list('setq, lhs, rhs), vars, mode)
    end
else
    'list . foreach elt in u
                collect formgentran1(elt, vars, mode)$


%%                     %%
%%  Control Functions  %%
%%                     %%


%%  Command Control Functions  %%


procedure gentran(forms, flist);
begin
if flist then
    eval list('gentranoutpush, list('quote, flist));
forms := preproc list forms;
gentranparse forms;
forms := lispcode forms;
%%IF !*GENTRANOPT THEN forms := Opt forms;
if !*gentranseg then forms := seg forms;
if gentranlang!* eq 'ratfor then
    formatrat ratcode forms
else if gentranlang!* eq 'c then
    formatc ccode forms
else
    formatfort fortcode forms;
if flist then
<<
    flist := car !*currout!* or ('list . cdr !*currout!*);
    eval '(gentranpop '(nil));
    return flist
>>
else
    return car !*currout!* or ('list . cdr !*currout!*)
end$


procedure gentranin(inlist, outlist);
begin
scalar ich;
foreach f in inlist do
    if listp f then
        gentranerr('e, f, "Wrong Type of Arg", nil)
    else if not !*filep!* f and f neq car !*stdin!* then
        gentranerr('e, f, "Nonexistent Input File", nil);
if outlist then
    eval list('gentranoutpush, mkquote outlist);
ich := rds nil;
foreach f in inlist do
<<
    if f = car !*stdin!* then
        pushinputstack !*stdin!*
    else if retrieveinputfilepair f then
        gentranerr('e, f, "Template File Already Open for Input", nil)
    else
        pushinputstack makeinputfilepair f;
    rds cdr !*currin!*;
    if gentranlang!* eq 'ratfor then
        procrattem()
    else if gentranlang!* eq 'c then
        procctem()
    else
        procforttem();
    rds ich;
    popinputstack()
>>;
if outlist then
<<
    outlist := car !*currout!* or ('list . cdr !*currout!*);
    eval '(gentranpop '(nil));
    return outlist
>>
else
    return car !*currout!* or ('list . cdr !*currout!*)
end$


procedure gentranoutpush flist;
<<
    if onep length (flist := fargstonames(flist, t)) then
        flist := car flist;
    pushoutputstack (retrieveoutputfilepair flist
                        or makeoutputfilepair flist);
    car !*currout!* or ('list . cdr !*currout!*)
>>$


procedure gentranshut flist;
%  close, delete, [output to T]  %
begin
scalar trm;
flist := fargstonames(flist, nil);
trm := if onep length flist then (car flist = car !*currout!*)
       else if car !*currout!*
        then (if car !*currout!* member flist then t)
       else eval('and . foreach f in cdr !*currout!*
                                collect (if f member flist then t));
deletefromoutputstack flist;
if trm and !*currout!* neq !*stdout!* then
    pushoutputstack !*stdout!*;
return car !*currout!* or ('list . cdr !*currout!*)
end$


procedure gentranpop flist;
<<
    if 'all!* member flist then
        while !*outstk!* neq list !*stdout!* do
            eval '(gentranpop '(nil))
    else
    <<
        flist := fargstonames(flist,nil);
        if onep length flist then
            flist := car flist;
        popoutputstack flist
    >>;
    car !*currout!* or ('list . cdr !*currout!*)
>>$


%%  Mode Switch Control Function  %%


procedure gendecs name;
%                      %
% ON/OFF GENDECS;      %
%                      %
% GENDECS subprogname; %
%                      %
<<
    if name equal 0 then name := nil;
    if gentranlang!* eq 'ratfor then
        formatrat ratdecs symtabget(name, '!*decs!*)
    else if gentranlang!* eq 'c then
        formatc cdecs symtabget(name, '!*decs!*)
    else
        formatfort fortdecs symtabget(name, '!*decs!*);
    symtabrem(name, nil);
    symtabrem(name, '!*decs!*)
>>$


%%  Misc. Control Functions  %%


procedure gentranpairs prs;
%                              %
% GENTRANPAIRS dottedpairlist; %
%                              %
if gentranlang!* eq 'ratfor then
    for each pr in prs do
        formatrat mkfratassign(lispcodeexp(car pr, !*period),
                               lispcodeexp(cdr pr, !*period))
else if gentranlang!* eq 'c then
    for each pr in prs do
        formatc mkfcassign(lispcodeexp(car pr, !*period),
                           lispcodeexp(cdr pr, !*period))
else
    for each pr in prs do
        formatfort mkffortassign(lispcodeexp(car pr, !*period),
                                 lispcodeexp(cdr pr, !*period))$


%%                                                  %%
%% Input & Output File Stack Manipulation Functions %%
%%                                                  %%


%%  Input Stack Manipulation Functions  %%


procedure makeinputfilepair fname;
(fname . open(mkfil fname, 'input))$

procedure retrieveinputfilepair fname;
retrievefilepair(fname, !*instk!*)$

procedure pushinputstack pr;
<<
    !*instk!* := pr . !*instk!*;
    !*currin!* := car !*instk!*;
    !*instk!*
>>$

procedure popinputstack;
begin scalar x;
x := !*currin!*;
if cdr !*currin!* then close cdr !*currin!*;
!*instk!* := cdr !*instk!* or list !*stdin!*;
!*currin!* := car !*instk!*;
return x
end$


%%  Output File Stack Manipulation Functions  %%


procedure makeoutputfilepair f;
if atom f then
    (f . open(mkfil f, 'output))
else
    aconc((nil . f) .
          foreach fn in f
                  conc if not retrieveoutputfilepair fn
                          then list makeoutputfilepair fn,
          (nil . nil))$

procedure retrieveoutputfilepair f;
if atom f
   then retrievefilepair(f, !*outstk!*)
   else retrievepfilepair(f, !*outstk!*)$

procedure pushoutputstack pr;
<<
    !*outstk!* := if atom cdr pr
                     then (pr . !*outstk!*)
                     else append(pr, !*outstk!*);
    !*currout!* := car !*outstk!*;
    !*outchanl!* := if car !*currout!*
                       then list cdr !*currout!*
                       else foreach f in cdr !*currout!*
                                   collect cdr retrieveoutputfilepair f;
    !*outstk!*
>>$

procedure popoutputstack f;
%  [close], remove top-most exact occurrence, reset vars  %
begin
scalar pr, s;
if atom f then
<<
    pr := retrieveoutputfilepair f;
    while !*outstk!* and car !*outstk!* neq pr do
        if caar !*outstk!* then
        <<s := aconc(s, car !*outstk!*);  !*outstk!* := cdr !*outstk!*>>
        else
        <<
            while car !*outstk!* neq (nil . nil) do
            <<  s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!* >>;
                s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!*
        >>;
    if !*outstk!* then s := append(s, cdr !*outstk!*);
    !*outstk!* := s;
    if not retrieveoutputfilepair f then close cdr pr
>>
else
<<
    pr := foreach fn in f collect retrieveoutputfilepair fn;
    while !*outstk!* and not filelistequivp(cdar !*outstk!*, f) do
        if caar !*outstk!* then
        <<  s := aconc(s, car !*outstk!*);
            !*outstk!* := cdr !*outstk!*  >>
        else
        <<
            while car !*outstk!* neq (nil . nil) do
            <<  s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!* >>;
                s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!*
        >>;
    if !*outstk!* then
    <<
        while car !*outstk!* neq (nil . nil) do
           !*outstk!* := cdr !*outstk!*;
        s := append(s, cdr !*outstk!*)
    >>;
    !*outstk!* := s;
    foreach fn in f do pr := delete(retrieveoutputfilepair fn, pr);
    foreach p in pr do close cdr p
>>;
!*outstk!* := !*outstk!* or list !*stdout!*;
!*currout!* := car !*outstk!*;
!*outchanl!* := if car !*currout!*
                   then list cdr !*currout!*
                   else foreach fn in cdr !*currout!*
                                collect cdr retrieveoutputfilepair fn;
return f
end$

procedure deletefromoutputstack f;
begin
scalar s, pr;
    if atom f then
    <<
        pr := retrieveoutputfilepair f;
        while retrieveoutputfilepair f do
            !*outstk!* := delete(pr, !*outstk!*);
        close cdr pr;
        foreach pr in !*outstk!* do
            if listp cdr pr and f member cdr pr then
                rplacd(pr, delete(f, cdr pr))
    >>
    else
    <<
        foreach fn in f do
            deletefromoutputstack fn;
        foreach fn in f do
            foreach pr in !*outstk!* do
                if listp cdr pr and fn member cdr pr then
                    rplacd(pr, delete(fn, cdr pr))
    >>;
    while !*outstk!* do
        if caar !*outstk!* and caar !*outstk!* neq 't then
        <<
            s := aconc(s, car !*outstk!*);
            !*outstk!* := cdr !*outstk!*
        >>
        else if cdar !*outstk!* and cdar !*outstk!* neq '(t) then
        <<
            while car !*outstk!* neq (nil . nil) do
            <<
                s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!*
            >>;
            s := aconc(s, car !*outstk!*);
            !*outstk!* := cdr !*outstk!*
        >>
        else
            !*outstk!* := cddr !*outstk!*;
    !*outstk!* := s or list !*stdout!*;
    !*currout!* := car !*outstk!*;
    !*outchanl!* := if car !*currout!*
                       then list cdr !*currout!*
                       else foreach fn in cdr !*currout!*
                                 collect cdr retrieveoutputfilepair fn;
return f
end$


procedure retrievefilepair(fname, stk);
if null stk then
    nil
else if caar stk and mkfil fname = mkfil caar stk then
    car stk
else
    retrievefilepair(fname, cdr stk)$

procedure retrievepfilepair(f, stk);
if null stk then
    nil
else if null caar stk and filelistequivp(f, cdar stk) then
    list(car stk, (nil . nil))
else
    retrievepfilepair(f, cdr stk)$

procedure filelistequivp(f1, f2);
if listp f1 and listp f2 then
<<
    f1 := foreach f in f1 collect mkfil f;
    f2 := foreach f in f2 collect mkfil f;
    while (car f1 member f2) do
    <<
        f2 := delete(car f1, f2);
        f1 := cdr f1
    >>;
    null f1 and null f2
>>$


%%

procedure !*filep!* f;
   not errorp errorset(list('close,
                            list('open,list('mkfil,mkquote f),''input)),
                       nil,nil)$

%%                                     %%
%% Scanning & Arg-Conversion Functions %%
%%                                     %%


procedure endofstmtp;
if cursym!* member '(!*semicol!* !*rsqb!* end) then t$

procedure fargstonames(fargs, openp);
begin
scalar names;
fargs :=
    for each a in fargs conc
        if a memq '(nil 0) then
            if car !*currout!* then
                list car !*currout!*
            else
                cdr !*currout!*
        else if a eq 't then
            list car !*stdout!*
        else if a eq 'all!* then
            for each fp in !*outstk!* conc
               (if car fp and not(fp equal !*stdout!*) then list car fp)
        else if atom a then
            if openp then
            <<
                if !*filep!* a and null assoc(a, !*outstk!*) then
                    gentranerr('w, a, "OUTPUT FILE ALREADY EXISTS",
                               "CONTINUE?");
                list a
            >>
            else
                if retrieveoutputfilepair a then
                    list a
                else
                    gentranerr('w, a, "File not Open for Output", nil)
        else
            gentranerr('e, a, "WRONG TYPE OF ARG", nil);
repeat
    if not (car fargs member names) then
        names := append(names, list car fargs)
until null (fargs := cdr fargs);
return names
end$

procedure readfargs;
begin
scalar f;
while not endofstmtp() do
    f := append(f, list xread t);
return f or list nil
end$


endmodule;


module templt;    %%  GENTRAN Template Processing Routines  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Points:  ProcCTem, ProcFortTem, ProcRatTem


symbolic$

% User-Accessible Global Variables %
global '(gentranlang!* !*gendecs !$!#)$
share 'gentranlang!*, '!$!#$
gentranlang!* := 'fortran$
!$!# := 0$
switch gendecs$

global '(!*space!* !*stdout!* !$eof!$ !$eol!$)$
        % GENTRAN Global Variables      %

!*space!* := '! $

fluid '(!*mode)$


%%                          %%
%% Text Processing Routines %%
%%                          %%


%% FORTRAN %%


procedure procforttem;
begin
scalar c, linelen;
linelen := linelength 150;
c := procfortcomm();
while c neq !$eof!$ do
    if c memq '(!F !f !S !s) then
    <<
        pprin2 c;
        c := procsubprogheading c
    >>
    else if c eq !$eol!$ then
    <<
        pterpri();
        c := procfortcomm()
    >>
    else if c eq '!; then
        c := procactive()
    else
    <<
        pprin2 c;
        c := readch()
    >>;
linelength linelen
end$

procedure procfortcomm;
% <col 1>C ... <cr> %
% <col 1>c ... <cr> %
begin
scalar c;
while (c := readch()) memq '(!C !c) do
<<
    pprin2 c;
    repeat
        if (c := readch()) neq !$eol!$ then
           pprin2 c
    until c eq !$eol!$;
    pterpri()
>>;
return c
end$


%% RATFOR %%


procedure procrattem;
begin
scalar c, linelen;
linelen := linelength 150;
c := readch();
while c neq !$eof!$ do
    if c memq '(!F !f !S !s) then
    <<
        pprin2 c;
        c := procsubprogheading c
    >>
    else if c eq '!# then
        c := procratcomm()
    else if c eq '!; then
        c := procactive()
    else if c eq !$eol!$ then
    <<
        pterpri();
        c := readch()
    >>
    else
    <<
        pprin2 c;
        c := readch()
    >>;
linelength linelen
end$

procedure procratcomm;
% # ... <cr> %
begin
scalar c;
pprin2 '!#;
while (c := readch()) neq !$eol!$ do
    pprin2 c;
pterpri();
return readch()
end$


%%


procedure procsubprogheading c;
begin
scalar lst, name, i, propname;
lst := if c memq '(!F !f)
          then '((!U !u) (!N !n) (!C !c) (!T !t) (!I !i) (!O !o)
                 (!N !n))
          else '((!U !u) (!B !b) (!R !r) (!O !o) (!U !u)
                 (!T !t) (!I !i) (!N !n) (!E !e));
while lst and (c := readch()) memq car lst do
<<  pprin2 c;  lst := cdr lst  >>;
if lst then return c;
while seprp(c := readch()) do
    if c eq !$eol!$
        then pterpri()
        else pprin2 c;
while not(seprp c or c eq '!() do
<<  name := aconc(name, c);  pprin2 c;  c := readch()  >>;
name := intern compress name;
if not !*gendecs then
    symtabput(name, nil, nil);
propname := if gentranlang!* eq 'fortran
               then '!*fortranname!*
               else '!*ratforname!*;
put('!$0, propname, name);
while seprp c do
<<
    if c eq !$eol!$
        then pterpri()
        else pprin2 c;
    c := readch()
>>;
if c neq '!( then return c;
i := 1;
pprin2 c;
c := readch();
while c neq '!) do
<<
    while seprp c or c eq '!, do
    << 
        if c eq !$eol!$
            then pterpri()
            else pprin2 c;
        c := readch()
    >>;
    name := list c;
    pprin2 c;
    while not (seprp (c := readch()) or c memq list('!,, '!))) do
    <<  name := aconc(name, c);  pprin2 c  >>;
    put(intern compress append(explode2 '!$, explode2 i),
        propname,
        intern compress name);
    i := add1 i;
    while seprp c do
    <<
        if c eq !$eol!$
            then pterpri()
            else pprin2 c;
        c := readch()
    >>
>>;
!$!# := sub1 i;
while get(name := intern compress append(explode2 '!$, explode2 i),
          propname) do
    remprop(name, propname);
return c
end$


%% C %%


procedure procctem;
begin
scalar c, linelen;
linelen := linelength 150;
c := readch();
if c eq '!# then c := procc!#line c;
while c neq !$eof!$ do
    if c eq !$eol!$ then
        c := procc!#line c
    else if c eq '!/ then
        c := procccomm()
    else if c eq '!; then
        c := procactive()
    else
        c := proccheader(c);
linelength linelen
end$

procedure procc!#line c;
%  # ... <cr>  %
begin
if c eq !$eol!$ then
<<  pterpri();  c := readch()  >>;
if c eq '!# then
    repeat
    <<  pprin2 c;  c := readch()  >>
    until c eq !$eol!$;
return c
end$

procedure procccomm;
% /* ... */ %
begin
scalar c;
pprin2 '!/;
c := readch();
if c eq '!* then
<<
    pprin2 c;
    c := readch();
    repeat
    <<
        while c neq '!* do
        <<
            if c eq !$eol!$
                then pterpri()
                else pprin2 c;
            c := readch()
        >>;
        pprin2 c;
        c := readch()
    >>
    until c eq '!/;
    pprin2 c;
    c := readch()
>>;
return c
end$

procedure proccheader c;
begin
scalar name, i;
while seprp c and c neq !$eol!$ do
<<  pprin2 c;  c := readch()  >>;
while not(seprp c or c memq list('!/, '!;, '!()) do
<<  name := aconc(name, c);  pprin2 c;  c := readch()  >>;
if c memq list(!$eol!$, '!/, '!;) then return c;
while seprp c and c neq !$eol!$ do
<<  pprin2 c;  c := readch()  >>;
if c neq '!( then return c;
name := intern compress name;
if not !*gendecs then
    symtabput(name, nil, nil);
put('!$0, '!*cname!*, name);
pprin2 c;
i := 1;
c := readch();
while c neq '!) do
<<
    while seprp c or c eq '!, do
    <<
        if c eq !$eol!$
            then pterpri()
            else pprin2 c;
        c := readch()
    >>;
    name := list c;
    pprin2 c;
    while not(seprp (c := readch()) or c memq list('!,, '!))) do
    <<  name := aconc(name, c);  pprin2 c  >>;
    put(intern compress append(explode2 '!$, explode2 i),
        '!*cname!*,
        intern compress name);
    i := add1 i;
    while seprp c do
    <<
        if c eq !$eol!$
            then pterpri()
            else pprin2 c;
        c := readch()
    >>
>>;
!$!# := sub1 i;
while get(name := intern compress append(explode2 '!$, explode2 i),
          '!*cname!*) do
    remprop(name, '!*cname!*);
return proccfunction c
end$

procedure proccfunction c;
begin
scalar !{!}count;
while c neq '!{ do
    if c eq '!/ then
        c := procccomm()
    else if c eq '!; then
        c := procactive()
    else if c eq !$eol!$ then
    <<  pterpri();  c := readch()  >>
    else
    <<  pprin2 c;  c := readch()  >>;
pprin2 c;
!{!}count := 1;
c := readch();
while !{!}count > 0 do
    if c eq '!{ then
    <<  !{!}count := add1 !{!}count;  pprin2 c;  c := readch()  >>
    else if c eq '!} then
    <<  !{!}count := sub1 !{!}count;  pprin2 c;  c := readch()  >>
    else if c eq '!/ then
        c := procccomm()
    else if c eq '!; then
        c := procactive()
    else if c eq !$eol!$ then
    <<  pterpri();  c := readch()  >>
    else
    <<  pprin2 c;  c := readch()  >>;
return c
end$


%%                                   %%
%% Template File Active Part Handler %%
%%                                   %%


procedure procactive;
% active parts:  ;BEGIN; ... ;END; %
% eof markers:   ;END;             %
begin
scalar c, buf, mode, och;
c := readch();
if c eq 'e then
    if (c := readch()) eq 'n then
        if (c := readch()) eq 'd then
            if (c := readch()) eq '!; then
                return !$eof!$
            else buf := '!;end
        else buf := '!;en
    else buf := '!;e
else if c eq 'b then
    if (c := readch()) eq 'e then
        if (c := readch()) eq 'g then
            if (c := readch()) eq 'i then
                if (c := readch()) eq 'n then
                    if (c := readch()) eq '!; then
                    <<
                        mode := !*mode;
                        !*mode := 'algebraic;
                        och := wrs cdr !*stdout!*;
                        begin1();
                        wrs och;
                        !*mode := mode;
                        linelength 150;
                        return if (c := readch()) eq !$eol!$ 
                                  then readch()
                                  else c
                    >>
                    else buf := '!;begin
                else buf := '!;begi
            else buf := '!;beg
        else buf := '!;be
    else buf := '!;b
else buf := '!;;
pprin2 buf;
return c
end$


endmodule;


module pre;    %%  GENTRAN Preprocessing Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  Preproc


symbolic$


procedure preproc exp;
begin
scalar r;
r := preproc1 exp;
if r then
    return car r
else
    return r
end$

procedure preproc1 exp;
if atom exp then
    list exp
else if car exp eq '!*sq then
    % (!*SQ dpexp) --> (PREPSQ dpexp) %
    preproc1 prepsq cadr exp
else if car exp eq 'procedure then
<<
    % Store subprogram name & parameters in symbol table %
    symtabput(cadr exp, '!*params!*, car cddddr exp);
    list for each e in exp
             conc preproc1 e
>>
else if car exp eq 'declare then
<<
    % Store type declarations in symbol table %
    exp := car preproc1 cdr exp;
    exp := preprocdec exp;
    for each dec in exp do
        for each var in cdr dec do
            if car dec memq '(subroutine function) then
                symtabput(var, '!*type!*, car dec)
            else
                symtabput(nil,
                          if atom var then var else car var,
                          if atom var then list car dec
                                      else (car dec . cdr var));
    nil
>>
else
    list for each e in exp
             conc preproc1 e$


procedure preprocdec arg;
% (TIMES type int) --> type!*int     %
% (IMPLICIT type) --> IMPLICIT! type %
% (DIFFERENCE v1 v2) --> v1!-v2      %
if atom arg then
    arg
else if car arg eq 'times then
    intern
         compress
            append( append( explode cadr arg, explode '!* ),
                    explode caddr arg )
else if car arg eq 'implicit then
    intern
        compress
            append( explode 'implicit! , explode preprocdec cadr arg )
else if car arg eq 'difference then
    intern
        compress
            append( append( explode cadr arg, explode '!- ),
                    explode caddr arg )
else
    for each a in arg collect
        preprocdec a$


endmodule;


module gparser;    %%  GENTRAN Parser Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  GentranParse


symbolic$

% GENTRAN Global Variable %
global '(!*reservedops!*)$
!*reservedops!* := '(and block cond difference equal expt for geq go
                     greaterp leq lessp mat minus neq not or plus
                     procedure progn quotient read recip repeat return
                     setq times while write)$ %reserved operators


procedure gentranparse forms;
for each f in forms do
    if not(gpstmtp f or gpexpp f or gpdefnp f) then
        gentranerr('e, f, "CANNOT BE TRANSLATED", nil)$

procedure gpexpp exp;
%  exp  ::=  id | number | (PLUS exp exp') | (MINUS exp) |             %
%         (DIFFERENCE exp exp) | (TIMES exp exp exp') |                %
%         (RECIP exp) |(QUOTIENT exp exp) | (EXPT exp exp) | (id arg') %
if atom exp then
    idp exp or numberp exp
else
    if car exp eq 'plus then
        length exp >= 2 and gpexpp cadr exp and gpexp1p cddr exp
    else if car exp memq '(minus recip) then
        length exp=2 and gpexpp cadr exp
    else if car exp memq '(difference quotient expt) then
        length exp=3 and gpexpp cadr exp and gpexpp caddr exp
    else if car exp eq 'times then
        length exp >= 3 and gpexpp cadr exp and gpexpp caddr exp and
         gpexp1p cdddr exp
    else if unresidp car exp then
        gparg1p cdr exp$

procedure gpexp1p exp;
%  exp'  ::=  exp exp' | eps  %
null exp or (gpexpp car exp and gpexp1p cdr exp)$

procedure gplogexpp exp;
%  logexp  ::=  id | (EQUAL exp exp) | (NEQ exp exp) |                 %
%            (GREATERP exp exp) |(GEQ exp exp) | (LESSP exp exp) |     %
%            (LEQ exp exp) | (NOT logexp) | (AND logexp logexp logexp')%
%            | (OR logexp logexp logexp') | (id arg')                  %
if atom exp then
    idp exp
else
    if car exp memq '(equal neq greaterp geq lessp leq) then
        length exp=3 and gpexpp cadr exp and gpexpp caddr exp
    else if car exp eq 'not then
        length exp=2 and gplogexpp cadr exp
    else if car exp memq '(and or) then
        length exp >= 3 and gplogexpp cadr exp and gplogexpp caddr exp
        and gplogexp1p cdddr exp
    else if unresidp car exp then
        gparg1p cdr exp$

procedure gplogexp1p exp;
%  logexp'  ::=  logexp logexp' | eps  %
null exp or (gplogexpp car exp and gplogexp1p cdr exp)$

procedure gpargp exp;
%  arg  ::=  string | exp | logexp  %
stringp exp or gpexpp exp or gplogexpp exp$

procedure gparg1p exp;
%  arg'  ::=  arg arg' | eps  %
null exp or (gpargp car exp and gparg1p cdr exp)$

procedure gpvarp exp;
%  var  ::=  id | (id exp exp')  %
if atom exp then
    idp exp
else
    if unresidp car exp then
        length exp >= 2 and gpexpp cadr exp and gpexp1p cddr exp$

procedure gplistp exp;
%  list  ::=  (exp exp')  %
if listp exp then
    length exp >= 1 and gpexpp car exp and gpexp1p cdr exp$

procedure gplist1p exp;
%  list'  ::=  list list' | eps  %
null exp or (gplistp car exp and gplist1p cdr exp)$

procedure gpid1p exp;
%  id'  ::=  id id' | eps  %
null exp or (idp car exp and gpid1p cdr exp)$

procedure gpstmtp exp;
%  stmt  ::=  id | (SETQ setq') | (COND cond') | (WHILE logexp stmt) | %
%             (REPEAT stmt logexp) | (FOR var (exp exp exp) DO stmt) | %
%             (GO id) | (RETURN arg) | (WRITE arg arg') |              %
%             (PROGN stmt stmt') | (BLOCK (id') stmt') | (id arg')     %
if atom exp then
    idp exp
else
    if car exp eq 'setq then
        gpsetq1p cdr exp
    else if car exp eq 'cond then
        gpcond1p cdr exp
    else if car exp eq 'while then
        length exp=3 and gplogexpp cadr exp and gpstmtp caddr exp
    else if car exp eq 'repeat then
        length exp=3 and gpstmtp cadr exp and gplogexpp caddr exp
    else if car exp eq 'for then
        length exp=5 and gpvarp cadr exp and listp caddr exp and
         (length caddr exp=3 and gpexpp car caddr exp and
          gpexpp cadr caddr exp and gpexpp caddr caddr exp) and
           cadddr exp eq 'do and gpstmtp car cddddr exp
    else if car exp eq 'go then
        length exp=2 and idp cadr exp
    else if car exp eq 'return then
        length exp=2 and gpargp cadr exp
    else if car exp eq 'write then
        length exp >= 2 and gpargp cadr exp and gparg1p cddr exp
    else if car exp eq 'progn then
        length exp >= 2 and gpstmtp cadr exp and gpstmt1p cddr exp
    else if car exp eq 'block then
        length exp >= 2 and gpid1p cadr exp and gpstmt1p cddr exp
    else if unresidp car exp then
        gparg1p cdr exp$

procedure gpsetq1p exp;
%  setq'  ::=  id setq'' | (id exp exp') setq'''  %
if exp and length exp=2 then
    if atom car exp then
        idp car exp and gpsetq2p cdr exp
    else
        (length car exp >= 2 and idp car car exp
             and unresidp car car exp and gpexpp cadr car exp
             and gpexp1p cddr car exp) and gpsetq3p cdr exp$

procedure gpsetq2p exp;
%  setq''  ::=  (MAT list list') | setq'''  %
if exp then
    if listp car exp and caar exp eq 'mat then
        onep length exp and (gplistp cadar exp and gplist1p cddar exp)
    else
        gpsetq3p exp$

procedure gpsetq3p exp;
% setq''' ::= (FOR var (exp exp exp) forop exp) | (READ) | exp | logexp
if exp and onep length exp then
    gpexpp car exp or
     gplogexpp car exp or
        (if caar exp eq 'for then
            length car exp=5 and gpvarp cadar exp and
             (listp caddar exp and length caddar exp=3 and
              gpexpp car caddar exp and gpexpp cadr caddar exp and
               gpexpp caddr caddar exp) and gpforopp car cdddar exp and
                gpexpp cadr cdddar exp
        else if caar exp eq 'read then
            onep length car exp)$

procedure gpforopp exp;
%  forop  ::=  SUM | PRODUCT  %
exp memq '(sum product)$

procedure gpcond1p exp;
%  cond'  ::=  (logexp stmt) cond' | eps  %
null exp or
    (listp car exp and length car exp=2 and gplogexpp caar exp and
     gpstmtp cadar exp and gpcond1p cdr exp)$

procedure gpstmt1p exp;
%  stmt'  ::=  stmt stmt' | eps  %
null exp or (gpstmtp car exp and gpstmt1p cdr exp)$

procedure gpdefnp exp;
%  defn  ::=  (PROCEDURE id NIL EXPR (id') stmt)  %
listp exp and car exp eq 'procedure and length exp=6 and
 idp cadr exp and null caddr exp and atom cadddr exp and
  gpid1p car cddddr exp and gpstmtp cadr cddddr exp
   and not idp cadr cddddr exp$


%%            %%
%% Predicates %%
%%            %%


procedure unresidp id;
not (id memq !*reservedops!*)$


endmodule;


module redlsp;    %%  GENTRAN LISP Code Generation Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  LispCode


symbolic$

% GENTRAN Global Variables %
global '(!*lisparithexpops!* !*lisplogexpops!* !*redarithexpops!*
        !*redlogexpops!* !*redreswds!* !*redstmtgpops!* !*redstmtops!*)$
!*redarithexpops!*:= '(difference expt minus plus quotient recip times)$
!*redlogexpops!*   := '(and equal geq greaterp leq lessp neq not or)$
!*redreswds!* := '(and block cond de difference end equal expt !~for for
                   geq getel go greaterp leq lessp list minus neq not or
                   plus plus2 prog progn procedure quotient read recip
                   repeat return setel setk setq stop times times2
                   while write)$ %REDUCE reserved words
!*redstmtgpops!*   := '(block progn)$
!*redstmtops!*     := '(cond end !~for for go repeat return setq stop
                        while write)$

% REDUCE Global Variable %
global '(!*period)$

global '(!*do!* !*for!*)$


procedure lispcode forms;
for each f in forms collect
    if redexpp f then
        lispcodeexp(f, !*period)
    else if redstmtp f or redstmtgpp f then
        lispcodestmt f
    else if reddefp f then
        lispcodedef f
    else if listp f then
        for each e in f collect lispcode e$

procedure lispcodeexp(form, fp);
% (RECIP exp) ==> (QUOTIENT 1.0 exp)                   %
% (DIFFERENCE exp1 exp2) ==> (PLUS exp1 (MINUS exp2))  %
% integer ==> floating point  iff  PERIOD flag is ON & %
%                                  not exponent &      %
%                                  not subscript &     %
%                                  not loop index      %
if numberp form then
    if fp then
        float form
    else
        form
else if atom form then
    form
else if car form eq 'expt then
    list('expt, lispcodeexp(cadr form, fp),
         lispcodeexp(caddr form, nil))
else if car form eq 'recip then
    if fp then
        list('quotient, 1.0, lispcodeexp(cadr form, fp))
    else
        list('quotient, 1, lispcodeexp(cadr form, fp))
else if car form eq 'difference then
    list('plus, lispcodeexp(cadr form, fp),
                list('minus, lispcodeexp(caddr form, fp)))
else if not car form memq !*lisparithexpops!* and
        not car form memq !*lisplogexpops!* then
    for each elt in form collect lispcodeexp(elt, nil)
else
    for each elt in form collect lispcodeexp(elt, fp)$


procedure lispcodestmt form;
if atom form then
    form
else if redassignp form then
    lispcodeassign form
else if redreadp form then
    lispcoderead form
else if redprintp form then
    lispcodeprint form
else if redwhilep form then
    lispcodewhile form
else if redrepeatp form then
    lispcoderepeat form
else if redforp form then
    lispcodefor form
else if redcondp form then
    lispcodecond form
else if redreturnp form then
    lispcodereturn form
else if redstmtgpp form then
    lispcodestmtgp form
else if reddefp form then
    lispcodedef form
else if car form eq 'literal then
    for each elt in form collect lispcodeexp(elt, nil)
else
    for each elt in form collect lispcodeexp(elt, !*period)$


procedure lispcodeassign form;
% (SETQ var (MAT lst lst')) --> (PROGN (SETQ (var 1 1) exp11)          %
%                                      (SETQ (var 1 2) exp12)          %
%                                       .                              %
%                                       .                              %
%                                      (SETQ (var m n) expmn))         %
if listp caddr form and caaddr form eq 'mat then
    begin
    scalar name, r, c, relts, result;
    name := cadr form;
    form := caddr form;
    r := c := 1;
    while form := cdr form do
    <<
        relts := car form;
        repeat
        <<
            result := mkassign(list(name, r, c),
                               lispcodeexp(car relts, !*period))
                                  . result;
            c := add1 c
        >>
        until null(relts := cdr relts);
        r := add1 r;
        c := 1
    >>;
    return mkstmtgp(nil, reverse result)
    end
else
    mkassign(lispcodeexp(cadr form, !*period),
             lispcodeexp(caddr form, !*period))$

procedure lispcoderead form;
% (SETQ var (READ)) --> (READ var) %
list('read, lispcodeexp(cadr form, nil))$

procedure lispcodeprint form;
'write . for each elt in cdr form collect lispcodeexp(elt, !*period)$

procedure lispcodewhile form;
'while . lispcodeexp(cadr form, !*period) .
         foreach st in cddr form collect lispcodestmt st$

procedure lispcoderepeat form;
begin
scalar body, logexp;
body := reverse cdr form;
logexp := car body;
body := reverse cdr body;
return 'repeat . append(foreach st in body collect lispcodestmt st,
                        list lispcodeexp(logexp, !*period))
end$

procedure lispcodefor form;
% (SETQ var1 (FOR var (exp1 exp2 exp3) SUM exp))
%   --> (PROGN (SETQ var1 0/0.0)
%             (FOR var (exp1 exp2 exp3) DO (SETQ var1 (PLUS var1 exp))))
% (SETQ var1 (FOR var (exp1 exp2 exp3) PRODUCT exp))
%   --> (PROGN (SETQ var1 1/1.0)
%            (FOR var (exp1 exp2 exp3) DO (SETQ var1 (TIMES var1 exp))))
if car form eq 'for then
    begin
    scalar explst, stmtlst;
    explst := list(cadr form, caddr form);
    stmtlst := cddddr form;
    return append(!*for!* .
                    foreach exp in explst collect lispcodeexp(exp, nil),
                  !*do!* .
                    foreach st in stmtlst collect lispcodestmt st)
    end
else
    begin
    scalar var1, var, explst, op, exp;
    var1 := cadr form;
    form := caddr form;
    var := cadr form;
    explst := caddr form;
    if cadddr form eq 'sum then
        op := 'plus
    else
        op := 'times;
    exp := car cddddr form;
    form := list('prog, nil,
                 list('setq, var1, if op eq 'plus then 0 else 1),
                 list(!*for!*, var, explst, !*do!*,
                      list('setq, var1, list(op, var1, exp))));
    return lispcodestmt form
    end$

procedure lispcodecond form;
begin
scalar result, pr;
while form := cdr form do
<<
    pr := car form;
    pr := lispcodeexp(car pr, !*period)
            . for each stmt in cdr pr collect lispcodestmt stmt;
    result := pr . result
>>;
return mkcond reverse result
end$

procedure lispcodereturn form;
% (RETURN NIL) --> (RETURN) %
if form member '((return) (return nil)) then
    list 'return
else
    mkreturn lispcodeexp(cadr form, !*period)$

procedure lispcodestmtgp form;
% (BLOCK () stmt1 stmt2 .. stmtm)      %
%   --> (PROG () stmt1 stmt2 .. stmtm) %
if car form memq '(prog block) then
    mkstmtgp(cadr form,
             for each stmt in cddr form collect lispcodestmt stmt)
else
    mkstmtgp(0, for each stmt in cdr form collect lispcodestmt stmt)$

procedure lispcodedef form;
% (PROCEDURE id NIL EXPR (p1 p2 .. pn) stmt') %
%   --> (DEFUN id (p1 p2 .. pn) stmt')        %
if car form eq 'procedure then
    mkdef(cadr form, car cddddr form, for each stmt in cdr cddddr form
                                              collect lispcodestmt stmt)
else
    mkdef(cadr form, caddr form, for each stmt in cdddr form
                                          collect lispcodestmt stmt)$


%% REDUCE Form Predicates %%


procedure redassignp form;
listp form and car form eq 'setq and redassign1p caddr form$

procedure redassign1p form;
if atom form then
    t
else if car form eq 'setq then
    redassign1p caddr form
else if car form memq '(read for) then
    nil
else
    t$

procedure redcondp form;
listp form and car form eq 'cond$

procedure reddefp form;
listp form and car form eq 'procedure$

procedure redexpp form;
atom form or
car form memq !*redarithexpops!* or
car form memq !*redlogexpops!* or
not(car form memq !*redreswds!*)$

procedure redforp form;
if listp form then
    if car form eq 'for then
        t
    else if car form eq 'setq then
        redfor1p caddr form$

procedure redfor1p form;
if atom form then
    nil
else if car form eq 'setq then
    redfor1p caddr form
else if car form eq 'for then
    t$

procedure redprintp form;
listp form and car form eq 'write$

procedure redreadp form;
listp form and car form eq 'setq and redread1p caddr form$

procedure redread1p form;
if atom form then
    nil
else if car form eq 'setq then
    redread1p caddr form
else if car form eq 'read then
    t$

procedure redrepeatp form;
listp form and car form eq 'repeat$

procedure redreturnp form;
listp form and car form eq 'return$

procedure redstmtp form;
atom form or
car form memq !*redstmtops!* or
atom car form and not(car form memq !*redreswds!*)$

procedure redstmtgpp form;
listp form and car form memq !*redstmtgpops!*$

procedure redwhilep form;
listp form and car form eq 'while$


endmodule;


module segmnt;    %%  Segmentation Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry points:  Seg, MARKEDVARP, MARKVAR, TEMPVAR, UNMARKVAR


symbolic$

% User-Accessible Global Variables %
global '(gentranlang!* maxexpprintlen!* tempvarname!* tempvarnum!*
         tempvartype!*)$
share 'gentranlang!*, 'maxexpprintlen!*, 'tempvarname!*, 'tempvarnum!*,
      'tempvartype!*$
maxexpprintlen!* := 800$
tempvarname!*    := 't$
tempvarnum!*     := 0$
tempvartype!*    := nil$

% User-Accessible Primitive Functions %
operator markedvarp, markvar, tempvar, unmarkvar$

global '(!*do!* !*for!*)$


%%                       %%
%% Segmentation Routines %%
%%                       %%


procedure seg forms;
% exp --+--> exp                                          %
%       +--> (assign    assign    ... assign      exp   ) %
%                   (1)       (2)           (n-1)    (n)  %
% stmt --+--> stmt                                        %
%        +--> stmtgp                                      %
% stmtgp --> stmtgp                                       %
% def --> def                                             %
for each f in forms collect
    if lispexpp f then
        if toolongexpp f then
            segexp(f, 'unknown)
        else
            f
    else if lispstmtp f then
        segstmt f
    else if lispstmtgpp f then
        if toolongstmtgpp f then
            seggroup f
        else
            f
    else if lispdefp f then
        if toolongdefp f then
            segdef f
        else
            f
    else
        f$


procedure segexp(exp, type);
% exp --> (assign    assign    ... assign      exp   ) %
%                (1)       (2)           (n-1)    (n)  %
reverse segexp1(exp, type)$

procedure segexp1(exp, type);
% exp --> (exp    assign      assign      ... assign   ) %
%             (n)       (n-1)       (n-2)           (1)  %
begin
scalar res;
res := segexp2(exp, type);
unmarkvar res;
if car res = cadadr res then
<<
    res := cdr res;
    rplaca(res, caddar res)
>>;
return res
end$

procedure segexp2(exp, type);
% exp --> (exp    assign      assign      ... assign   ) %
%             (n)       (n-1)       (n-2)           (1)  %
begin
scalar expn, assigns, newassigns, unops, op, termlist, var, tmp;
expn := exp;
while length expn=2 do
<<  unops := car expn . unops;  expn := cadr expn  >>;
op := car expn;
for each term in cdr expn do
<<
    if toolongexpp term then
    <<
        tmp := segexp2(term, type);
        term := car tmp;
        newassigns := cdr tmp
    >>
    else
        newassigns := '();
    if toolongexpp (op . term . termlist) and
       termlist and
       (length termlist > 1 or listp car termlist) then
        <<
            unmarkvar termlist;
            var := var or tempvar type;
            markvar var;
            assigns := mkassign(var, if onep length termlist
                                        then car termlist
                                        else op . termlist) . assigns;
            termlist := list(var, term)
        >>
        else
            termlist := append(termlist, list term);
        assigns := append(newassigns, assigns)
>>;
expn := if onep length termlist
           then car termlist
           else op . termlist;
while unops do
<<  expn := list(car unops, expn);  unops := cdr unops  >>;
if expn = exp then
<<
    unmarkvar expn;
    var := var or tempvar type;
    markvar var;
    assigns := list mkassign(var, expn);
    expn := var
>>;
return expn . assigns
end$


procedure segstmt stmt;
% assign --+--> assign %
%          +--> stmtgp %
% cond --+--> cond     %
%        +--> stmtgp   %
% while --+--> while   %
%         +--> stmtgp  %
% repeat --> repeat    %
% for --+--> for       %
%       +--> stmtgp    %
% return --+--> return %
%          +--> stmtgp %
if lispassignp stmt then
    if toolongassignp stmt then
        segassign stmt
    else
        stmt
else if lispcondp stmt then
    if toolongcondp stmt then
        segcond stmt
    else
        stmt
else if lispwhilep stmt then
    if toolongwhilep stmt then
        segwhile stmt
    else
        stmt
else if lisprepeatp stmt then
    if toolongrepeatp stmt then
        segrepeat stmt
    else
        stmt
else if lispforp stmt then
    if toolongforp stmt then
        segfor stmt
    else
        stmt
else if lispreturnp stmt then
    if toolongreturnp stmt then
        segreturn stmt
    else
        stmt
else
    stmt$


procedure segassign stmt;
% assign --> stmtgp %
begin
scalar var, exp, type;
var := cadr stmt;
type := getvartype var;
exp := caddr stmt;
stmt := segexp1(exp, type);
rplaca(stmt, mkassign(var, car stmt));
return mkstmtgp(nil, reverse stmt)
end$

procedure segcond condd;
% cond --+--> cond   %
%        +--> stmtgp %
begin
scalar tassigns, res, markedvars, type;
if gentranlang!* eq 'c
    then type := 'int
    else type := 'logical;
while condd := cdr condd do
    begin
    scalar exp, stmt;
    if toolongexpp(exp := caar condd) then
    <<
        exp := segexp1(exp, type);
        tassigns := append(cdr exp, tassigns);
        exp := car exp;
        markvar exp;
        markedvars := exp . markedvars
    >>;
    stmt := for each st in cdar condd conc seg list st;
    res := (exp . stmt) . res
    end;
unmarkvar markedvars;
return
    if tassigns then
        mkstmtgp(nil, reverse(mkcond reverse res . tassigns))
    else
        mkcond reverse res
end$

procedure segwhile stmt;
% while --+--> while  %
%         +--> stmtgp %
begin
scalar logexp, stmtlst, tassigns, type, res;
logexp := cadr stmt;
stmtlst := cddr stmt;
if toolongexpp logexp then
<<
    if gentranlang!* eq 'c
       then type := 'int
       else type := 'logical;
    tassigns := segexp1(logexp, type);
    logexp := car tassigns;
    tassigns := cdr tassigns
>>;
stmtlst := foreach st in stmtlst
                   conc seg list st;
res := 'while . logexp . stmtlst;
if tassigns then
<<
    res := append(res, reverse tassigns);
    res := 'progn . append(reverse tassigns, list res)
>>;
return res
end$

procedure segrepeat stmt;
% repeat --> repeat %
begin
scalar stmtlst, logexp, type;
stmt := reverse cdr stmt;
logexp := car stmt;
stmtlst := reverse cdr stmt;
stmtlst := foreach st in stmtlst conc seg list st;
if toolongexpp logexp then
<<
    if gentranlang!* eq 'c
       then type := 'int
       else type := 'logical;
    logexp := segexp1(logexp, type);
    stmtlst := append(stmtlst, reverse cdr logexp);
    logexp := car logexp
>>;
return 'repeat . append(stmtlst, list logexp)
end$

procedure segfor stmt;
% for --+--> for    %
%       +--> stmtgp %
begin
scalar var, loexp, stepexp, hiexp, stmtlst, tassigns1, tassigns2, type,
       markedvars, res;
var := cadr stmt;
type := getvartype var;
stmt := cddr stmt;
loexp := caar stmt;
stepexp := cadar stmt;
hiexp := caddar stmt;
stmtlst := cddr stmt;
if toolongexpp loexp then
<<
    loexp := segexp1(loexp, type);
    tassigns1 := reverse cdr loexp;
    loexp := car loexp;
    markvar loexp;
    markedvars := loexp . markedvars
>>;
if toolongexpp stepexp then
<<
    stepexp := segexp1(stepexp, type);
    tassigns2 := reverse cdr stepexp;
    stepexp := car stepexp;
    markvar stepexp;
    markedvars := stepexp . markedvars
>>;
if toolongexpp hiexp then
<<
    hiexp := segexp1(hiexp, type);
    tassigns1 := append(tassigns1, reverse cdr hiexp);
    tassigns2 := append(tassigns2, reverse cdr hiexp);
    hiexp := car hiexp
>>;
unmarkvar markedvars;
stmtlst := foreach st in stmtlst conc seg list st;
stmtlst := append(stmtlst, tassigns2);
res := !*for!* . var . list(loexp, stepexp, hiexp) . !*do!* . stmtlst;
if tassigns1 then
    return mkstmtgp(nil, append(tassigns1, list res))
else
    return res
end$

procedure segreturn ret;
% return --> stmtgp %
<<
    ret := segexp1(cadr ret, 'unknown);
    rplaca(ret, mkreturn car ret);
    mkstmtgp(nil, reverse ret)
>>$

procedure seggroup stmtgp;
% stmtgp --> stmtgp %
begin
scalar locvars, res;
if car stmtgp eq 'prog then
<<
    locvars := cadr stmtgp;
    stmtgp := cdr stmtgp
>>
else
    locvars := 0;
while stmtgp := cdr stmtgp do
    res := append(seg list car stmtgp, res);
return mkstmtgp(locvars, reverse res)
end$

procedure segdef deff;
% def --> def %
mkdef(cadr deff, caddr deff,
      for each stmt in cdddr deff conc seg list stmt)$


%%                                        %%
%% Long Statement & Expression Predicates %%
%%                                        %%


procedure toolongexpp exp;
numprintlen exp > maxexpprintlen!*$

procedure toolongstmtp stmt;
if atom stmt then nil else
if lispstmtp stmt then
    if lispcondp stmt then
        toolongcondp stmt
    else if lispassignp stmt then
        toolongassignp stmt
    else if lispreturnp stmt then
        toolongreturnp stmt
    else if lispwhilep stmt then
        toolongwhilep stmt
    else if lisprepeatp stmt then
        toolongrepeatp stmt
    else if lispforp stmt then
        toolongforp stmt
    else
        eval('or . for each exp in stmt collect  toolongexpp exp)
else
    toolongstmtgpp stmt$

procedure toolongassignp assign;
toolongexpp caddr assign$

procedure toolongcondp condd;
begin
scalar toolong;
while condd := cdr condd do
    if toolongexpp caar condd or toolongstmtp cadar condd then
        toolong := t;
return toolong
end$

procedure toolongwhilep stmt;
toolongexpp cadr stmt or
eval('or . foreach st in cddr stmt collect
                   toolongstmtp st        )$

procedure toolongrepeatp stmt;
<<
    stmt := reverse cdr stmt;
    toolongexpp car stmt or
    eval('or . foreach st in cdr stmt collect
                       toolongstmtp st       )
>>$

procedure toolongforp stmt;
eval('or . foreach exp in caddr stmt collect
                   toolongexpp exp          ) or
eval('or . foreach st in cddddr stmt collect
                   toolongstmtp st          )$

procedure toolongreturnp ret;
toolongexpp cadr ret$

procedure toolongstmtgpp stmtgp;
eval('or . for each stmt in cdr stmtgp collect
               toolongstmtp stmt              )$

procedure toolongdefp deff;
if lispstmtgpp cadddr deff then
    toolongstmtgpp cadddr deff
else
    eval('or . for each stmt in cdddr deff collect
                   toolongstmtp stmt             )$


%%                       %%
%% Print Length Function %%
%%                       %%


procedure numprintlen exp;
if atom exp then
    length explode exp
else if onep length exp then
    numprintlen car exp
else
    length exp + eval('plus . for each elt in cdr exp collect
                                numprintlen elt              )$


%%                                                              %%
%% Temporary Variable Generation, Marking & Unmarking Functions %%
%%                                                              %%


procedure tempvar type;
%                                                             %
%  IF type Member '(NIL 0) THEN type <- TEMPVARTYPE!*         %
%                                                             %
%  IF type Neq 'NIL And type Neq 'UNKNOWN THEN                %
%    var <- 1st unmarked tvar of VType type or of VType NIL   %
%           which isn't in the symbol table                   %
%    put type on var's VType property list                    %
%    put declaration in symbol table                          %
%  ELSE IF type = NIL THEN                                    %
%    var <- 1st unmarked tvar of type NIL which isn't in the  %
%           symbol table                                      %
%  ELSE type = 'UNKNOWN                                       %
%    var <- 1st unmarked tvar of type NIL which isn't in the  %
%           symbol table                                      %
%    put 'UNKNOWN on var's VType property list                %
%    print warning - "undeclared"                             %
%                                                             %
%  RETURN var                                                 %
%                                                             %
begin
scalar tvar, xname, num;
if type memq '(nil 0) then type := tempvartype!*;
xname := explode tempvarname!*;
num := tempvarnum!*;
if type memq '(nil unknown) then
    repeat
    <<
        tvar := intern compress append(xname, explode num);
        num := add1 num
    >>
    until not markedvarp tvar and not get(tvar, '!*vtype!*) and
          not getvartype tvar
else
    repeat
    <<
        tvar := intern compress append(xname, explode num);
        num := add1 num
    >>
    until not markedvarp tvar and
          (get(tvar, '!*vtype!*) eq type or
           not get(tvar, '!*vtype!*) and not getvartype tvar);
put(tvar, '!*vtype!*, type);
if type eq 'unknown then
    gentranerr('w, tvar, "UNDECLARED VARIABLE", nil)
else if type then
    symtabput(nil, tvar, list type);
return tvar
end$

procedure markvar var;
if numberp var then
    var
else if atom var then
<<  flag(list var, '!*marked!*);  var  >>
else
<<  for each v in var do markvar v;  var  >>$

procedure markedvarp var;
flagp(var, '!*marked!*)$

procedure unmarkvar var;
if atom var then
    if numberp var then
        var
    else
        remflag(list var, '!*marked!*)
else
    foreach elt in var do
        unmarkvar elt$


endmodule;


module lspfor;    %%  GENTRAN LISP-to-FORTRAN Translation Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  FortCode


symbolic$


global '(!*gendecs)$
switch gendecs$

% User-Accessible Global Variables %
global '(fortcurrind!* tablen!*)$
share 'fortcurrind!*, 'tablen!*$
fortcurrind!* := 0$

% GENTRAN Global Variables %
global '(!*endofloopstack!* !*subprogname!*)$
!*endofloopstack!* := nil$
!*subprogname!*    := nil$  %name of subprogram being generated

global '(!*do!*)$


%%                                       %%
%% LISP-to-FORTRAN Translation Functions %%
%%                                       %%


%% Control Function %%


procedure fortcode forms;
for each f in forms conc
    if atom f then
        fortexp f
    else if lispstmtp f or lispstmtgpp f then
        if !*gendecs then
            begin
            scalar r;
            r := append(fortdecs symtabget('!*main!*, '!*decs!*),
                        fortstmt f);
            symtabrem('!*main!*, '!*decs!*);
            return r
            end
        else
            fortstmt f
    else if lispdefp f then
        fortsubprog f
    else
        fortexp f$


%% Subprogram Translation %%


procedure fortsubprog deff;
begin
scalar type, stype, name, params, body, lastst, r;
name := !*subprogname!* := cadr deff;
if onep length (body := cdddr deff) and lispstmtgpp car body then
<<  body := cdar body;  if null car body then body := cdr body  >>;
if lispreturnp (lastst := car reverse body) then
    body := append(body, list '(end))
else if not lispendp lastst then
    body := append(body, list('(return), '(end)));
if (type := symtabget(name, name)) then
<<  type := cadr type;  symtabrem(name, name)  >>;
stype := symtabget(name, '!*type!*) or
         (    if type or functionformp(body, name)
                 then 'function
                 else 'subroutine    );
symtabrem(name, '!*type!*);
params := symtabget(name, '!*params!*) or caddr deff;
symtabrem(name, '!*params!*);
r := mkffortsubprogdec(type, stype, name, params);
if !*gendecs then
    r := append(r, fortdecs symtabget(name, '!*decs!*));
r := append(r, for each s in body
                   conc fortstmt s);
if !*gendecs then
<<  symtabrem(name, nil);  symtabrem(name, '!*decs!*)  >>;
return r
end$


%% Generation of Declarations %%


procedure fortdecs decs;
for each tl in formtypelists decs
    conc mkffortdec(car tl, cdr tl)$


%% Expression Translation %%


procedure fortexp exp;
fortexp1(exp, 0)$

procedure fortexp1(exp, wtin);
if atom exp then
    list fortranname exp
else
    if onep length exp then
        fortranname exp
    else if optype car exp then
        begin
        scalar wt, op, res;
        wt := fortranprecedence car exp;
        op := fortranop car exp;
        exp := cdr exp;
        if onep length exp then
            res := op . fortexp1(car exp, wt)
        else
        <<
            res := fortexp1(car exp, wt);
            if op eq '!+ then
                while exp := cdr exp do
                <<
                    if atom car exp or caar exp neq 'minus then
                        res := append(res, list op);
                    res := append(res, fortexp1(car exp, wt))
                >>
            else
                while exp := cdr exp do
                    res := append(append(res, list op),
                                  fortexp1(car exp, wt))
        >>;
        if wtin > wt then res := insertparens res;
        return res
        end
    else if car exp eq 'literal then
        fortliteral exp
    else
        begin
        scalar op, res;
        op := fortranname car exp;
        exp := cdr exp;
        res := fortexp1(car exp, 0);
        while exp := cdr exp do
            res := append(append(res, list '!,),
                          fortexp1(car exp, 0));
        return op . insertparens res
        end$


procedure fortranop op;
get(op, '!*fortranop!*) or op$

put('or,       '!*fortranop!*, '!.or!. )$
put('and,      '!*fortranop!*, '!.and!.)$
put('not,      '!*fortranop!*, '!.not!.)$
put('equal,    '!*fortranop!*, '!.eq!. )$
put('neq,      '!*fortranop!*, '!.ne!. )$
put('greaterp, '!*fortranop!*, '!.gt!. )$
put('geq,      '!*fortranop!*, '!.ge!. )$
put('lessp,    '!*fortranop!*, '!.lt!. )$
put('leq,      '!*fortranop!*, '!.le!. )$
put('plus,     '!*fortranop!*, '!+     )$
put('times,    '!*fortranop!*, '!*     )$
put('quotient, '!*fortranop!*, '/      )$
put('minus,    '!*fortranop!*, '!-     )$
put('expt,     '!*fortranop!*, '!*!*   )$

procedure fortranname a;
if stringp a then
    stringtoatom a    %  convert a to atom containing "'s
else
    get(a, '!*fortranname!*) or a$

put(t,   '!*fortranname!*, '!.true!. )$
put(nil, '!*fortranname!*, '!.false!.)$

procedure fortranprecedence op;
get(op, '!*fortranprecedence!*) or 9$

put('or,       '!*fortranprecedence!*, 1)$
put('and,      '!*fortranprecedence!*, 2)$
put('not,      '!*fortranprecedence!*, 3)$
put('equal,    '!*fortranprecedence!*, 4)$
put('neq,      '!*fortranprecedence!*, 4)$
put('greaterp, '!*fortranprecedence!*, 4)$
put('geq,      '!*fortranprecedence!*, 4)$
put('lessp,    '!*fortranprecedence!*, 4)$
put('leq,      '!*fortranprecedence!*, 4)$
put('plus,     '!*fortranprecedence!*, 5)$
put('times,    '!*fortranprecedence!*, 6)$
put('quotient, '!*fortranprecedence!*, 6)$
put('minus,    '!*fortranprecedence!*, 7)$
put('expt,     '!*fortranprecedence!*, 8)$


%% Statement Translation %%


procedure fortstmt stmt;
if null stmt then
    nil
else if lisplabelp stmt then
    fortstmtnum stmt
else if car stmt eq 'literal then
    fortliteral stmt
else if lispreadp stmt then
    fortread stmt
else if lispassignp stmt then
    fortassign stmt
else if lispprintp stmt then
    fortwrite stmt
else if lispcondp stmt then
    fortif stmt
else if lispbreakp stmt then
    fortbreak stmt
else if lispgop stmt then
    fortgoto stmt
else if lispreturnp stmt then
    fortreturn stmt
else if lispstopp stmt then
    fortstop stmt
else if lispendp stmt then
    fortend stmt
else if lispwhilep stmt then
    fortwhile stmt
else if lisprepeatp stmt then
    fortrepeat stmt
else if lispforp stmt then
    fortfor stmt
else if lispstmtgpp stmt then
    fortstmtgp stmt
else if lispdefp stmt then
    fortsubprog stmt
else if lispcallp stmt then
    fortcall stmt$


procedure fortassign stmt;
mkffortassign(cadr stmt, caddr stmt)$

procedure fortbreak stmt;
if null !*endofloopstack!* then
    gentranerr('e, nil, "BREAK NOT INSIDE LOOP - CANNOT BE TRANSLATED",
               nil)
else if atom car !*endofloopstack!* then
    begin
    scalar n1;
    n1 := genstmtnum();
    rplaca(!*endofloopstack!*, list(car !*endofloopstack!*, n1));
    return mkffortgo n1
    end
else
    mkffortgo cadar !*endofloopstack!*$

procedure fortcall stmt;
mkffortcall(car stmt, cdr stmt)$

procedure fortfor stmt;
begin
scalar n1, result, var, loexp, stepexp, hiexp, stmtlst;
var := cadr stmt;
stmt := cddr stmt;
loexp := caar stmt;
stepexp := cadar stmt;
hiexp := caddar stmt;
stmtlst := cddr stmt;
n1 := genstmtnum();
!*endofloopstack!* := n1 . !*endofloopstack!*;
result := mkffortdo(n1, var, loexp, hiexp, stepexp);
indentfortlevel(+1);
result := append(result, for each st in stmtlst conc fortstmt st);
indentfortlevel(-1);
result := append(result, mkffortcontinue n1);
if listp car !*endofloopstack!* then
    result := append(result, mkffortcontinue cadar !*endofloopstack!*);
!*endofloopstack!* := cdr !*endofloopstack!*;
return result
end$

procedure fortend stmt;
mkffortend()$

procedure fortgoto stmt;
begin
scalar stmtnum;
if not ( stmtnum := get(cadr stmt, '!*stmtnum!*) ) then
    stmtnum := put(cadr stmt, '!*stmtnum!*, genstmtnum());
return mkffortgo stmtnum
end$

procedure fortif stmt;
begin
scalar n1, n2, res;
stmt := cdr stmt;
if onep length stmt then
    if caar stmt eq t then
        return for each st in cdar stmt conc fortstmt st
    else
        return
        <<
            n1 := genstmtnum();
            res := mkffortifgo(list('not, caar stmt), n1);
            indentfortlevel(+1);
            res := append(res,
                          for each st in cdar stmt conc fortstmt st);
            indentfortlevel(-1);
            append(res, mkffortcontinue n1)
        >>
else
    return
    <<
        n1 := genstmtnum();
        n2 := genstmtnum();
        res := mkffortifgo(list('not, caar stmt), n1);
        indentfortlevel(+1);
        res := append(res, for each st in cdar stmt conc fortstmt st);
        res := append(res, mkffortgo n2);
        indentfortlevel(-1);
        res := append(res, mkffortcontinue n1);
        indentfortlevel(+1);
        res := append(res, fortif('cond . cdr stmt));
        indentfortlevel(-1);
        append(res, mkffortcontinue n2)
    >>
end$

procedure fortliteral stmt;
mkffortliteral cdr stmt$

procedure fortread stmt;
mkffortread cadr stmt$

procedure fortrepeat stmt;
begin
scalar n, result, stmtlst, logexp;
stmtlst := reverse cdr stmt;
logexp := car stmtlst;
stmtlst := reverse cdr stmtlst;
n := genstmtnum();
!*endofloopstack!* := 'dummy . !*endofloopstack!*;
result := mkffortcontinue n;
indentfortlevel(+1);
result := append(result, for each st in stmtlst conc fortstmt st);
indentfortlevel(-1);
result := append(result, mkffortifgo(list('not, logexp), n));
if listp car !*endofloopstack!* then
    result := append(result, mkffortcontinue cadar !*endofloopstack!*);
!*endofloopstack!* := cdr !*endofloopstack!*;
return result
end$

procedure fortreturn stmt;
if onep length stmt then
    mkffortreturn()
else if !*subprogname!* then
    append(mkffortassign(!*subprogname!*, cadr stmt), mkffortreturn())
else
    gentranerr('e, nil,
               "RETURN NOT INSIDE FUNCTION - CANNOT BE TRANSLATED",
               nil)$

procedure fortstmtgp stmtgp;
<<
    if car stmtgp eq 'progn then
        stmtgp := cdr stmtgp
    else
        stmtgp := cddr stmtgp;
    for each stmt in stmtgp conc fortstmt stmt
>>$

procedure fortstmtnum label;
begin
scalar stmtnum;
if not ( stmtnum := get(label, '!*stmtnum!*) ) then
    stmtnum := put(label, '!*stmtnum!*, genstmtnum());
return mkffortcontinue stmtnum
end$

procedure fortstop stmt;
mkffortstop()$

procedure fortwhile stmt;
begin
scalar n1, n2, result, logexp, stmtlst;
logexp := cadr stmt;
stmtlst := cddr stmt;
n1 := genstmtnum();
n2 := genstmtnum();
!*endofloopstack!* := n2 . !*endofloopstack!*;
result := append(list(n1, '! ), mkffortifgo(list('not, logexp), n2));
indentfortlevel(+1);
result := append(result, for each st in stmtlst conc fortstmt st);
result := append(result, mkffortgo n1);
indentfortlevel(-1);
result := append(result, mkffortcontinue n2);
if listp car !*endofloopstack!* then
    result := append(result, mkffortcontinue cadar !*endofloopstack!*);
!*endofloopstack!* := cdr !*endofloopstack!*;
return result
end$

procedure fortwrite stmt;
mkffortwrite cdr stmt$


%%                                   %%
%% FORTRAN Code Formatting Functions %%
%%                                   %%


%% Statement Formatting %%


procedure mkffortassign(lhs, rhs);
append(append(mkforttab() . fortexp lhs, '!= . fortexp rhs),
       list mkfortterpri())$

procedure mkffortcall(fname, params);
<<
    if params then
        params := append(append(list '!(,
                                for each p in insertcommas params
                                              conc fortexp p),
                         list '!));
    append(append(list(mkforttab(), 'call, '! ), fortexp fname),
           append(params, list mkfortterpri()))
>>$

procedure mkffortcontinue stmtnum;
list(stmtnum, '! , mkforttab(), 'continue, mkfortterpri())$

procedure mkffortdec(type, varlist);
<<
    type := type or 'dimension;
    varlist := for each v in insertcommas varlist
                   conc fortexp v;
    if implicitp type then
        append(list(mkforttab(), type, '! , '!(),
               append(varlist, list('!), mkfortterpri())))
    else
        append(list(mkforttab(), type, '! ),
               append(varlist,list mkfortterpri()))
>>$

procedure mkffortdo(stmtnum, var, lo, hi, incr);
<<
    if onep incr then
        incr := nil
    else if incr then
        incr := '!, . fortexp incr;
    append(append(append(list(mkforttab(), !*do!*, '! , stmtnum, '! ),
                         fortexp var),
                  append('!= . fortexp lo, '!, . fortexp hi)),
           append(incr, list mkfortterpri()))
>>$

procedure mkffortend;
list(mkforttab(), 'end, mkfortterpri())$

procedure mkffortgo stmtnum;
list(mkforttab(), 'goto, '! , stmtnum, mkfortterpri())$

procedure mkffortifgo(exp, stmtnum);
append(append(list(mkforttab(), 'if, '! , '!(), fortexp exp),
       list('!), '! , 'goto, '! , stmtnum, mkfortterpri()))$

procedure mkffortliteral args;
for each a in args conc
    if a eq 'tab!* then
        list mkforttab()
    else if a eq 'cr!* then
        list mkfortterpri()
    else if listp a then
        fortexp a
    else
        list stripquotes a$

procedure mkffortread var;
append(list(mkforttab(), 'read, '!(!*!,!*!), '! ),
       append(fortexp var, list mkfortterpri()))$

procedure mkffortreturn;
list(mkforttab(), 'return, mkfortterpri())$

procedure mkffortstop;
list(mkforttab(), 'stop, mkfortterpri())$

procedure mkffortsubprogdec(type, stype, name, params);
<<
    if params then
        params := append('!( . for each p in insertcommas params
                                   conc fortexp p,
                          list '!));
    if type then
        type := list(mkforttab(), type, '! , stype, '! )
    else
        type := list(mkforttab(), stype, '! );
    append(append(type, fortexp name),
           append(params, list mkfortterpri()))
>>$

procedure mkffortwrite arglist;
append(append(list(mkforttab(), 'write, '!(!*!,!*!), '! ),
              for each arg in insertcommas arglist conc fortexp arg),
       list mkfortterpri())$


%% Indentation Control %%


procedure mkforttab;
list('forttab, fortcurrind!* + 6)$


procedure indentfortlevel n;
fortcurrind!* := fortcurrind!* + n * tablen!*$


procedure mkfortterpri;
list 'fortterpri$


endmodule;


module lsprat;    %%  GENTRAN LISP-to-RATFOR Translation Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  RatCode


symbolic$


global '(!*gendecs)$
switch gendecs$

% User-Accessible Global Variables %
global '(ratcurrind!* tablen!*)$
share 'ratcurrind!*, 'tablen!*$
ratcurrind!* := 0$

global '(!*do!*)$


%%                                      %%
%% LISP-to-RATFOR Translation Functions %%
%%                                      %%


%% Control Function %%


procedure ratcode forms;
for each f in forms conc
    if atom f then
        ratexp f
    else if lispstmtp f or lispstmtgpp f then
        if !*gendecs then
            begin
            scalar r;
            r := append(ratdecs symtabget('!*main!*, '!*decs!*),
                        ratstmt f);
            symtabrem('!*main!*, '!*decs!*);
            return r
            end
        else
            ratstmt f
    else if lispdefp f then
        ratsubprog f
    else
        ratexp f$


%% Subprogram Translation %%


procedure ratsubprog deff;
begin
scalar type, stype, name, params, body, lastst, r;
name := cadr deff;
if onep length(body := cdddr deff) and lispstmtgpp car body then
<<  body := cdar body;  if null car body then body := cdr body  >>;
if lispreturnp (lastst := car reverse body) then
    body := append(body, list '(end))
else if not lispendp lastst then
    body := append(body, list('(return), '(end)));
if (type := symtabget(name, name)) then
<<  type := cadr type;  symtabrem(name, name)  >>;
stype := symtabget(name, '!*type!*) or
         (    if type or functionformp(body, name)
                 then 'function
                 else 'subroutine    );
symtabrem(name, '!*type!*);
params := symtabget(name, '!*params!*) or caddr deff;
symtabrem(name, '!*params!*);
r := mkfratsubprogdec(type, stype, name, params);
if !*gendecs then
    r := append(r, ratdecs symtabget(name, '!*decs!*));
r := append(r, for each s in body
                   conc ratstmt s);
if !*gendecs then
<<  symtabrem(name, nil);  symtabrem(name, '!*decs!*)  >>;
return r
end$


%% Generation of Declarations %%


procedure ratdecs decs;
for each tl in formtypelists decs
    conc mkfratdec(car tl, cdr tl)$


%% Expression Translation %%


procedure ratexp exp;
ratexp1(exp, 0)$

procedure ratexp1(exp, wtin);
if atom exp then
    list ratforname exp
else
    if onep length exp then
        ratforname exp
    else if optype car exp then
        begin
        scalar wt, op, res;
        wt := ratforprecedence car exp;
        op := ratforop car exp;
        exp := cdr exp;
        if onep length exp then
            res := op . ratexp1(car exp, wt)
        else
        <<
            res := ratexp1(car exp, wt);
            if op eq '!+ then
                while exp := cdr exp do
                <<
                    if atom car exp or caar exp neq 'minus then
                        res := append(res, list op);
                    res := append(res, ratexp1(car exp, wt))
                >>
            else
                while exp := cdr exp do
                    res := append(append(res, list op),
                                  ratexp1(car exp, wt))
        >>;
        if wtin > wt then res := insertparens res;
        return res
        end
    else if car exp eq 'literal then
        ratliteral exp
    else
        begin
        scalar op, res;
        op := ratforname car exp;
        exp := cdr exp;
        res := ratexp1(car exp, 0);
        while exp := cdr exp do
            res := append(append(res, list '!,), ratexp1(car exp, 0));
        return op . insertparens res
        end$


procedure ratforop op;
get(op, '!*ratforop!*) or op$

put('or,       '!*ratforop!*, '|   )$
put('and,      '!*ratforop!*, '&   )$
put('not,      '!*ratforop!*, '!!  )$
put('equal,    '!*ratforop!*, '!=!=)$
put('neq,      '!*ratforop!*, '!!!=)$
put('greaterp, '!*ratforop!*, '>   )$
put('geq,      '!*ratforop!*, '!>!=)$
put('lessp,    '!*ratforop!*, '<   )$
put('leq,      '!*ratforop!*, '!<!=)$
put('plus,     '!*ratforop!*, '!+  )$
put('times,    '!*ratforop!*, '*   )$
put('quotient, '!*ratforop!*, '/   )$
put('minus,    '!*ratforop!*, '!-  )$
put('expt,     '!*ratforop!*, '!*!*)$

procedure ratforname a;
if stringp a then
    stringtoatom a    % convert a to atom containing "'s
else
    get(a, '!*ratforname!*) or a$

put(t,   '!*ratforname!*, '!.true!. )$
put(nil, '!*ratforname!*, '!.false!.)$

procedure ratforprecedence op;
get(op, '!*ratforprecedence!*) or 9$

put('or,       '!*ratforprecedence!*, 1)$
put('and,      '!*ratforprecedence!*, 2)$
put('not,      '!*ratforprecedence!*, 3)$
put('equal,    '!*ratforprecedence!*, 4)$
put('neq,      '!*ratforprecedence!*, 4)$
put('greaterp, '!*ratforprecedence!*, 4)$
put('geq,      '!*ratforprecedence!*, 4)$
put('lessp,    '!*ratforprecedence!*, 4)$
put('leq,      '!*ratforprecedence!*, 4)$
put('plus,     '!*ratforprecedence!*, 5)$
put('times,    '!*ratforprecedence!*, 6)$
put('quotient, '!*ratforprecedence!*, 6)$
put('minus,    '!*ratforprecedence!*, 7)$
put('expt,     '!*ratforprecedence!*, 8)$


%% Statement Translation %%


procedure ratstmt stmt;
if null stmt then
    nil
else if lisplabelp stmt then
    ratstmtnum stmt
else if car stmt eq 'literal then
    ratliteral stmt
else if lispreadp stmt then
    ratread stmt
else if lispassignp stmt then
    ratassign stmt
else if lispprintp stmt then
    ratwrite stmt
else if lispcondp stmt then
    ratif stmt
else if lispbreakp stmt then
    ratbreak stmt
else if lispgop stmt then
    ratgoto stmt
else if lispreturnp stmt then
    ratreturn stmt
else if lispstopp stmt then
    ratstop stmt
else if lispendp stmt then
    ratend stmt
else if lisprepeatp stmt then
    ratrepeat stmt
else if lispwhilep stmt then
    ratwhile stmt
else if lispforp stmt then
    ratforfor stmt
else if lispstmtgpp stmt then
    ratstmtgp stmt
else if lispdefp stmt then
    ratsubprog stmt
else if lispcallp stmt then
    ratcall stmt$


procedure ratassign stmt;
mkfratassign(cadr stmt, caddr stmt)$

procedure ratbreak stmt;
mkfratbreak()$

procedure ratcall stmt;
mkfratcall(car stmt, cdr stmt)$

procedure ratforfor stmt;
begin
scalar r, var, loexp, stepexp, hiexp, stmtlst;
var := cadr stmt;
stmt := cddr stmt;
loexp := caar stmt;
stepexp := cadar stmt;
hiexp := caddar stmt;
stmtlst := cddr stmt;
r := mkfratdo(var, loexp, hiexp, stepexp);
indentratlevel(+1);
r := append(r, foreach st in stmtlst conc ratstmt st);
indentratlevel(-1);
return r
end$

procedure ratend stmt;
mkfratend()$

procedure ratgoto stmt;
begin
scalar stmtnum;
stmtnum := get(cadr stmt, '!*stmtnum!*) or
          put(cadr stmt, '!*stmtnum!*, genstmtnum());
return mkfratgo stmtnum
end$

procedure ratif stmt;
begin
scalar r, st;
r := mkfratif caadr stmt;
indentratlevel(+1);
st := seqtogp cdadr stmt;
if listp st and car st eq 'cond and length st=2 then
    st := mkstmtgp(0, list st);
r := append(r, ratstmt st);
indentratlevel(-1);
stmt := cdr stmt;
while (stmt := cdr stmt) and caar stmt neq t do
<<
    r := append(r, mkfratelseif caar stmt);
    indentratlevel(+1);
    st := seqtogp cdar stmt;
    if listp st and car st eq 'cond and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, ratstmt st);
    indentratlevel(-1)
>>;
if stmt then
<<
    r := append(r, mkfratelse());
    indentratlevel(+1);
    st := seqtogp cdar stmt;
    if listp st and car st eq 'cond and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, ratstmt st);
    indentratlevel(-1)
>>;
return r
end$

procedure ratliteral stmt;
mkfratliteral cdr stmt$

procedure ratread stmt;
mkfratread cadr stmt$

procedure ratrepeat stmt;
begin
scalar r, stmtlst, logexp;
stmt := reverse cdr stmt;
logexp := car stmt;
stmtlst := reverse cdr stmt;
r := mkfratrepeat();
indentratlevel(+1);
r := append(r, foreach st in stmtlst conc ratstmt st);
indentratlevel(-1);
return append(r, mkfratuntil logexp)
end$

procedure ratreturn stmt;
if cdr stmt then
    mkfratreturn cadr stmt
else
    mkfratreturn nil$

procedure ratstmtgp stmtgp;
begin
scalar r;
if car stmtgp eq 'progn then
    stmtgp := cdr stmtgp
else
    stmtgp := cddr stmtgp;
r := mkfratbegingp();
indentratlevel(+1);
r := append(r, for each stmt in stmtgp conc ratstmt stmt);
indentratlevel(-1);
return append(r, mkfratendgp())
end$

procedure ratstmtnum label;
begin
scalar stmtnum;
stmtnum := get(label, '!*stmtnum!*) or
          put(label, '!*stmtnum!*, genstmtnum());
return mkfratcontinue stmtnum
end$

procedure ratstop stmt;
mkfratstop()$

procedure ratwhile stmt;
begin
scalar r, logexp, stmtlst;
logexp := cadr stmt;
stmtlst := cddr stmt;
r := mkfratwhile logexp;
indentratlevel(+1);
r := append(r, foreach st in stmtlst conc ratstmt st);
indentratlevel(-1);
return r
end$

procedure ratwrite stmt;
mkfratwrite cdr stmt$


%%                                  %%
%% RATFOR Code Formatting Functions %%
%%                                  %%


%% Statement Formatting %%


procedure mkfratassign(lhs, rhs);
append(append(mkrattab() . ratexp lhs, '!= . ratexp rhs),
       list mkratterpri())$

procedure mkfratbegingp;
list(mkrattab(), '!{, mkratterpri())$

procedure mkfratbreak;
list(mkrattab(), 'break, mkratterpri())$

procedure mkfratcall(fname, params);
<<
    if params then
        params := append(append(list '!(,
                                for each p in insertcommas params
                                              conc ratexp p),
                         list '!));
    append(append(list(mkrattab(), 'call, '! ), ratexp fname),
           append(params, list mkratterpri()))
>>$

procedure mkfratcontinue stmtnum;
list(stmtnum, '! , mkrattab(), 'continue, mkratterpri())$

procedure mkfratdec(type, varlist);
<<
    type := type or 'dimension;
    varlist := for each v in insertcommas varlist
                   conc ratexp v;
    if implicitp type then
        append(list(mkrattab(), type, '! , '!(),
               append(varlist, list('!), mkratterpri())))
    else
        append(list(mkrattab(), type, '! ),
               append(varlist, list mkratterpri()))
>>$

procedure mkfratdo(var, lo, hi, incr);
<<
    if onep incr then
        incr := nil
    else if incr then
        incr := '!, . ratexp incr;
    append(append(append(list(mkrattab(), !*do!*, '! ), ratexp var),
                  append('!= . ratexp lo, '!, . ratexp hi)),
           append(incr, list mkratterpri()))
>>$

procedure mkfratelse;
list(mkrattab(), 'else, mkratterpri())$

procedure mkfratelseif exp;
append(append(list(mkrattab(), 'else, '! , 'if, '! , '!(), ratexp exp),
       list('!), mkratterpri()))$

procedure mkfratend;
list(mkrattab(), 'end, mkratterpri())$

procedure mkfratendgp;
list(mkrattab(), '!}, mkratterpri())$

procedure mkfratgo stmtnum;
list(mkrattab(), 'goto, '! , stmtnum, mkratterpri())$

procedure mkfratif exp;
append(append(list(mkrattab(), 'if, '! , '!(), ratexp exp),
       list('!), mkratterpri()))$

procedure mkfratliteral args;
for each a in args conc
    if a eq 'tab!* then
        list mkrattab()
    else if a eq 'cr!* then
        list mkratterpri()
    else if listp a then
        ratexp a
    else
        list stripquotes a$

procedure mkfratread var;
append(list(mkrattab(), 'read, '!(!*!,!*!), '! ),
       append(ratexp var, list mkratterpri()))$

procedure mkfratrepeat;
list(mkrattab(), 'repeat, mkratterpri())$

procedure mkfratreturn exp;
if exp then
    append(append(list(mkrattab(), 'return, '!(), ratexp exp),
           list('!), mkratterpri()))
else
    list(mkrattab(), 'return, mkratterpri())$

procedure mkfratstop;
list(mkrattab(), 'stop, mkratterpri())$

procedure mkfratsubprogdec(type, stype, name, params);
<<
    if params then
        params := append('!( . for each p in insertcommas params
                                  conc ratexp p,
                         list '!));
    if type then
        type := list(mkrattab(), type, '! , stype, '! )
    else
        type := list(mkrattab(), stype, '! );
    append(append(type, ratexp name),
           append(params,list mkratterpri()))
>>$

procedure mkfratuntil logexp;
append(list(mkrattab(), 'until, '! , '!(),
       append(ratexp logexp, list('!), mkratterpri())))$

procedure mkfratwhile exp;
append(append(list(mkrattab(), 'while, '! , '!(), ratexp exp),
       list('!), mkratterpri()))$

procedure mkfratwrite arglist;
append(append(list(mkrattab(), 'write, '!(!*!,!*!), '! ),
              for each arg in insertcommas arglist conc ratexp arg),
       list mkratterpri())$


%% Indentation Control %%


procedure mkrattab;
list('rattab, ratcurrind!*)$


procedure indentratlevel n;
ratcurrind!* := ratcurrind!* + n * tablen!*$


procedure mkratterpri;
list 'ratterpri$


endmodule;


module lspc;    %%  GENTRAN LISP-to-C Translation Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  CCode


symbolic$


global '(!*gendecs)$
switch gendecs$

% User-Accessible Global Variables %
global '(ccurrind!* tablen!*)$
share 'ccurrind!*, 'tablen!*$
ccurrind!* := 0$

global '(!*do!* !*for!*)$


%%                                 %%
%% LISP-to-C Translation Functions %%
%%                                 %%


%% Control Function %%


procedure ccode forms;
for each f in forms conc
    if atom f then
        cexp f
    else if lispstmtp f or lispstmtgpp f then
        if !*gendecs then
            begin
            scalar r;
            r := append(cdecs symtabget('!*main!*, '!*decs!*),
                        cstmt f);
            symtabrem('!*main!*, '!*decs!*);
            return r
            end
        else
            cstmt f
    else if lispdefp f then
        cproc f
    else
        cexp f$


%% Procedure Translation %%


procedure cproc deff;
begin
scalar type, name, params, paramtypes, vartypes, body, r;
name := cadr deff;
if onep length (body := cdddr deff) and lispstmtgpp car body then
<<  body := cdar body;  if null car body then body := cdr body  >>;
if (type := symtabget(name, name)) then
<<  type := cadr type;  symtabrem(name, name)  >>;
params := symtabget(name, '!*params!*) or caddr deff;
symtabrem(name, '!*params!*);
for each dec in symtabget(name, '!*decs!*) do
    if car dec memq params
       then paramtypes := append(paramtypes, list dec)
       else vartypes := append(vartypes, list dec);
r := append( append( mkfcprocdec(type, name, params),
                     cdecs paramtypes ),
             mkfcbegingp() );
indentclevel(+1);
if !*gendecs then
    r := append(r, cdecs vartypes);
r := append(r, for each s in body
                   conc cstmt s);
indentclevel(-1);
r := append(r, mkfcendgp());
if !*gendecs then
<<  symtabrem(name, nil);  symtabrem(name, '!*decs!*)  >>;
return r
end$


%% Generation of Declarations %%


procedure cdecs decs;
for each tl in formtypelists decs
    conc mkfcdec(car tl, cdr tl)$


%% Expression Translation %%


procedure cexp exp;
cexp1(exp, 0)$

procedure cexp1(exp, wtin);
if atom exp then
    list cname exp
else
    if onep length exp then
        append(cname exp, insertparens(()))
    else if car exp eq 'expt then
        'power . insertparens append(cexp1(cadr exp, 0),
                                     '!, . cexp1(caddr exp, 0))
    else if optype car exp then
        begin
        scalar wt, op, res;
        wt := cprecedence car exp;
        op := cop car exp;
        exp := cdr exp;
        if onep length exp then
            res := op . cexp1(car exp, wt)
        else
        <<
            res := cexp1(car exp, wt);
            if op eq '!+ then
                while exp := cdr exp do
                <<
                    if atom car exp or caar exp neq 'minus then
                        res := append(res, list op);
                    res := append(res, cexp1(car exp, wt))
                >>
            else
                while exp := cdr exp do
                    res := append(append(res, list op),
                                  cexp1(car exp, wt))
        >>;
        if wtin > wt then res := insertparens res;
        return res
        end
    else if car exp eq 'literal then
        cliteral exp
    else if arrayeltp exp then
        cname car exp . foreach s in cdr exp conc
                                insertbrackets cexp1(s, 0)
    else
        begin
        scalar op, res;
        op := cname car exp;
        exp := cdr exp;
        res := cexp1(car exp, 0);
        while exp := cdr exp do
            res := append(append(res, list '!,), cexp1(car exp, 0));
        return op . insertparens res
        end$


procedure cop op;
get(op, '!*cop!*) or op$

put('or,       '!*cop!*, '!|!|)$
put('and,      '!*cop!*, '!&!&)$
put('not,      '!*cop!*, '!!  )$
put('equal,    '!*cop!*, '!=!=)$
put('neq,      '!*cop!*, '!!!=)$
put('greaterp, '!*cop!*, '>   )$
put('geq,      '!*cop!*, '!>!=)$
put('lessp,    '!*cop!*, '<   )$
put('leq,      '!*cop!*, '!<!=)$
put('plus,     '!*cop!*, '!+  )$
put('times,    '!*cop!*, '*   )$
put('quotient, '!*cop!*, '/   )$
put('minus,    '!*cop!*, '!-  )$

procedure cname a;
if stringp a then
    stringtoatom a    % convert a to atom containing "'s
else
    get(a, '!*cname!*) or a$

put(t,   '!*cname!*, 1)$
put(nil, '!*cname!*, 0)$

procedure cprecedence op;
get(op, '!*cprecedence!*) or 8$

put('or,       '!*cprecedence!*, 1)$
put('and,      '!*cprecedence!*, 2)$
put('equal,    '!*cprecedence!*, 3)$
put('neq,      '!*cprecedence!*, 3)$
put('greaterp, '!*cprecedence!*, 4)$
put('geq,      '!*cprecedence!*, 4)$
put('lessp,    '!*cprecedence!*, 4)$
put('leq,      '!*cprecedence!*, 4)$
put('plus,     '!*cprecedence!*, 5)$
put('times,    '!*cprecedence!*, 6)$
put('quotient, '!*cprecedence!*, 6)$
put('not,      '!*cprecedence!*, 7)$
put('minus,    '!*cprecedence!*, 7)$


%% Statement Translation %%


procedure cstmt stmt;
if null stmt then
    nil
else if lisplabelp stmt then
    clabel stmt
else if car stmt eq 'literal then
    cliteral stmt
else if lispassignp stmt then
    cassign stmt
else if lispcondp stmt then
    cif stmt
else if lispbreakp stmt then
    cbreak stmt
else if lispgop stmt then
    cgoto stmt
else if lispreturnp stmt then
    creturn stmt
else if lispstopp stmt then
    cexit stmt
else if lisprepeatp stmt then
    crepeat stmt
else if lispwhilep stmt then
    cwhile stmt
else if lispforp stmt then
    cfor stmt
else if lispstmtgpp stmt then
    cstmtgp stmt
else if lispdefp stmt then
    cproc stmt
else
    cexpstmt stmt$


procedure cassign stmt;
mkfcassign(cadr stmt, caddr stmt)$

procedure cbreak stmt;
mkfcbreak()$

procedure cexit stmt;
mkfcexit()$

procedure cexpstmt exp;
append(mkctab() . cexp exp, list('!;, mkcterpri()))$

procedure cfor stmt;
begin
scalar r, var, loexp, stepexp, hiexp, stmtlst;
var := cadr stmt;
stmt := cddr stmt;
loexp := caar stmt;
stepexp := cadar stmt;
hiexp := caddar stmt;
stmtlst := cddr stmt;
r := mkfcfor(var, loexp, list('leq, var, hiexp), var,
             list('plus, var, stepexp));
indentclevel(+1);
r := append(r, foreach st in stmtlst conc cstmt st);
indentclevel(-1);
return r
end$

procedure cgoto stmt;
mkfcgo cadr stmt$

procedure cif stmt;
begin
scalar r, st;
r := mkfcif caadr stmt;
indentclevel(+1);
st := seqtogp cdadr stmt;
if listp st and car st eq 'cond and length st=2 then
    st := mkstmtgp(0, list st);
r := append(r, cstmt st);
indentclevel(-1);
stmt := cdr stmt;
while (stmt := cdr stmt) and caar stmt neq t do
<<
    r := append(r, mkfcelseif caar stmt);
    indentclevel(+1);
    st := seqtogp cdar stmt;
    if listp st and car st eq 'cond and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, cstmt st);
    indentclevel(-1)
>>;
if stmt then
<<
    r := append(r, mkfcelse());
    indentclevel(+1);
    st := seqtogp cdar stmt;
    if listp st and car st eq 'cond and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, cstmt st);
    indentclevel(-1)
>>;
return r
end$

procedure clabel label;
mkfclabel label$

procedure cliteral stmt;
mkfcliteral cdr stmt$

procedure crepeat stmt;
begin
scalar r, stmtlst, logexp;
stmt := reverse cdr stmt;
logexp := car stmt;
stmtlst := reverse cdr stmt;
r := mkfcdo();
indentclevel(+1);
r := append(r, foreach st in stmtlst conc cstmt st);
indentclevel(-1);
return append(r, mkfcdowhile list('not, logexp))
end$

procedure creturn stmt;
if cdr stmt then
    mkfcreturn cadr stmt
else
    mkfcreturn nil$

procedure cstmtgp stmtgp;
begin
scalar r;
if car stmtgp eq 'progn then
    stmtgp := cdr stmtgp
else
    stmtgp :=cddr stmtgp;
r := mkfcbegingp();
indentclevel(+1);
r := append(r, for each stmt in stmtgp conc cstmt stmt);
indentclevel(-1);
return append(r, mkfcendgp())
end$

procedure cwhile stmt;
begin
scalar r, logexp, stmtlst;
logexp := cadr stmt;
stmtlst := cddr stmt;
r := mkfcwhile logexp;
indentclevel(+1);
r := append(r, foreach st in stmtlst conc cstmt st);
indentclevel(-1);
return r
end$


%%                             %%
%% C Code Formatting Functions %%
%%                             %%


%% Statement Formatting %%


procedure mkfcassign(lhs, rhs);
begin
scalar st;
if length rhs = 3 and lhs member rhs then
    begin
    scalar op, exp1, exp2;
    op := car rhs;
    exp1 := cadr rhs;
    exp2 := caddr rhs;
    if op = 'plus then
        if onep exp1 or onep exp2 then
            st := ('!+!+ . cexp lhs)
        else if exp1 member '(-1 (minus 1))
           or exp2 member '(-1 (minus 1)) then
            st := ('!-!- . cexp lhs)
        else if listp exp1 and car exp1 = 'minus then
            st := append(cexp lhs, '!-!= . cexp cadr exp1)
        else if listp exp2 and car exp2 = 'minus then
            st := append(cexp lhs, '!-!= . cexp cadr exp2)
        else if exp1 = lhs then
            st := append(cexp lhs, '!+!= . cexp exp2)
        else
            st := append(cexp lhs, '!+!= . cexp exp1)
    else if op = 'difference and onep exp2 then
        st := ('!-!- . cexp lhs)
    else if op = 'difference and exp1 = lhs then
        st := append(cexp lhs, '!-!= . cexp exp2)
    else if op = 'times and exp1 = lhs then
        st := append(cexp lhs, '!*!= . cexp exp2)
    else if op = 'times then
        st := append(cexp lhs, '!*!= . cexp exp1)
    else if op = 'quotient and exp1 = lhs then
        st := append(cexp lhs, '!/!= . cexp exp2)
    else
        st := append(cexp lhs, '!= . cexp rhs)
    end
else
    st := append(cexp lhs, '!= . cexp rhs);
return append(mkctab() . st, list('!;, mkcterpri()))
end$

procedure mkfcbegingp;
list(mkctab(), '!{, mkcterpri())$

procedure mkfcbreak;
list(mkctab(), 'break, '!;, mkcterpri())$

procedure mkfcdec(type, varlist);
<<
    varlist := for each v in varlist collect
                   if atom v then
                       v
                   else
                       car v . for each dim in cdr v collect add1 dim;
    append(mkctab() . type . '!  . for each v in insertcommas varlist
                                       conc cexp v,
           list('!;, mkcterpri()))
>>$

procedure mkfcdo;
list(mkctab(), !*do!*, mkcterpri())$

procedure mkfcdowhile exp;
append(append(list(mkctab(), 'while, '! , '!(), cexp exp),
       list('!), '!;, mkcterpri()))$

procedure mkfcelse;
list(mkctab(), 'else, mkcterpri())$

procedure mkfcelseif exp;
append(append(list(mkctab(), 'else, '! , 'if, '! , '!(), cexp exp),
       list('!), mkcterpri()))$

procedure mkfcendgp;
list(mkctab(), '!}, mkcterpri())$

procedure mkfcexit;
list(mkctab(), 'exit, '!(, 0, '!), '!;, mkcterpri())$

procedure mkfcfor(var1, lo, cond, var2, nextexp);
<<
    if var1 then
        var1 := append(cexp var1, '!= . cexp lo);
    if cond then
        cond := cexp cond;
    if var2 then
    <<
        var2 := cdr mkfcassign(var2, nextexp);
        var2 := reverse cddr reverse var2
    >>;
    append(append(append(list(mkctab(), !*for!*, '! , '!(), var1),
                         '!; . cond),
           append('!; . var2, list('!), mkcterpri())))
>>$

procedure mkfcgo label;
list(mkctab(), 'goto, '! , label, '!;, mkcterpri())$

procedure mkfcif exp;
append(append(list(mkctab(), 'if, '! , '!(), cexp exp),
       list('!), mkcterpri()))$

procedure mkfclabel label;
list(label, '!:, mkcterpri())$

procedure mkfcliteral args;
for each a in args conc
    if a eq 'tab!* then
        list mkctab()
    else if a eq 'cr!* then
        list mkcterpri()
    else if listp a then
        cexp a
    else
        list stripquotes a$

procedure mkfcprocdec(type, name, params);
<<
    params := append('!( . for each p in insertcommas params
                              conc cexp p,
                     list '!));
    if type then
        append(mkctab() . type . '!  . cexp name,
               append(params,list mkcterpri()))
    else
        append(mkctab() . cexp name, append(params, list mkcterpri()))
>>$

procedure mkfcreturn exp;
if exp then
    append(append(list(mkctab(), 'return, '!(), cexp exp),
           list('!), '!;, mkcterpri()))
else
    list(mkctab(), 'return, '!;, mkcterpri())$

procedure mkfcwhile exp;
append(append(list(mkctab(), 'while, '! , '!(), cexp exp),
       list('!), mkcterpri()))$


%% Indentation Control %%


procedure mkctab;
list('ctab, ccurrind!*)$


procedure indentclevel n;
ccurrind!* := ccurrind!* + n * tablen!*$


procedure mkcterpri;
list 'cterpri$


%%                 %%
%% Misc. Functions %%
%%                 %%


procedure insertbrackets exp;
'![ . append(exp, list '!])$


endmodule;


module goutput;  % GENTRAN Code Formatting & Printing and Error Handler

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Points:  FormatC, FormatFort, FormatRat, GentranErr


symbolic$

% User-Accessible Global Variable %
global '(clinelen!* fortlinelen!* minclinelen!* minfortlinelen!*
         minratlinelen!* ratlinelen!*)$
share 'clinelen!*, 'fortlinelen!*, 'minclinelen!*, 'minfortlinelen!*,
      'minratlinelen!*, 'ratlinelen!*$
clinelen!*       := 80$
fortlinelen!*    := 72$
minclinelen!*    := 40$
minfortlinelen!* := 40$
minratlinelen!*  := 40$
ratlinelen!*     := 80$

% GENTRAN Global Variables %
global '(!*ccurrind!* !*errchan!* !*fortcurrind!* !*outchanl!*
         !*posn!* !*ratcurrind!* !*stdin!* !*stdout!* !$eol!$)$
!*ccurrind!*    := 0$     %current level of indentation for C code
!*errchan!*     := nil$   %error channel number
!*fortcurrind!* := 6$     %current level of indentation for FORTRAN code
!*posn!*        := 0$     %current position on output line
!*ratcurrind!*  := 0$     %current level of indentation for RATFOR code


%%                                      %%
%% Code Formatting & Printing Functions %%
%%                                      %%


%% FORTRAN Code Formatting & Printing Functions %%


procedure formatfort lst;
begin
scalar linelen;
linelen := linelength 300;
!*posn!* := 0;
for each elt in lst do
    if listp elt then
        eval elt
    else
    <<
        if !*posn!* + length explode2 elt > fortlinelen!* then
            fortcontline();
        pprin2 elt
    >>;
linelength linelen
end$

procedure fortcontline;
<<
    fortterpri();
    pprin2 "     .";
    forttab !*fortcurrind!*;
    pprin2 " "
>>$

procedure fortterpri;
pterpri()$

procedure forttab n;
<<
    !*fortcurrind!* := max(min0(n, fortlinelen!* - minfortlinelen!*),6);
    if (n := !*fortcurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$


%% RATFOR Code Formatting & Printing Functions %%


procedure formatrat lst;
begin
scalar linelen;
linelen := linelength 300;
!*posn!* := 0;
for each elt in lst do
    if listp elt then
        eval elt
    else
    <<
        if !*posn!* + length explode2 elt > ratlinelen!* then
            ratcontline();
        pprin2 elt
    >>;
linelength linelen
end$

procedure ratcontline;
<<
    ratterpri();
    rattab !*ratcurrind!*;
    pprin2 " "
>>$

procedure ratterpri;
pterpri()$

procedure rattab n;
<<
    !*ratcurrind!* := min0(n, ratlinelen!* - minratlinelen!*);
    if (n := !*ratcurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$


%% C Code Formatting & Printing Functions %%


procedure formatc lst;
begin
scalar linelen;
linelen := linelength 300;
!*posn!* := 0;
for each elt in lst do
    if listp elt then
        eval elt
    else
    <<
        if !*posn!* + length explode2 elt > clinelen!* then
            ccontline();
        pprin2 elt
    >>;
linelength linelen
end$

procedure ccontline;
<<
    cterpri();
    ctab !*ccurrind!*;
    pprin2 " "
>>$

procedure cterpri;
pterpri()$

procedure ctab n;
<<
    !*ccurrind!* := min0(n, clinelen!* - minclinelen!*);
    if (n := !*ccurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$


%%                            %%
%% General Printing Functions %%
%%                            %%


procedure pprin2 arg;
begin
scalar ch;
ch := wrs nil;
for each c in !*outchanl!* do
<<  wrs c;  prin2 arg  >>;
!*posn!* := !*posn!* + length explode2 arg;
wrs ch
end$

procedure pterpri;
begin
scalar ch;
ch := wrs nil;
for each c in !*outchanl!* do
<<  wrs c;  terpri()  >>;
!*posn!* := 0;
wrs ch
end$


%%               %%
%% Error Handler %%
%%               %%


%% Error & Warning Message Printing Routine %%


procedure gentranerr(msgtype, exp, msg1, msg2);
begin
scalar holdich, holdoch, resp, emsg;
holdich := rds !*errchan!*;
holdoch := wrs !*errchan!*;
terpri();
if exp then prettyprint exp;
if msgtype eq 'e then
<<
    rds cdr !*stdin!*;
    wrs cdr !*stdout!*;
    rederr msg1
>>;
prin2 "*** ";
prin2t msg1;
if msg2 then resp := yesp msg2;
wrs holdoch;
rds holdich;
if not resp then error1()
end$


%%                 %%
%% Misc. Functions %%
%%                 %%


procedure min0(n1, n2);
max(min(n1, n2), 0)$

procedure nspaces n;
   % Note n is assumed > 0 here.
   begin scalar s;
      for i := 1:n do s := ('!! . '!  . s);
      return intern compress s
   end$


endmodule;


end;

Added r33/groebner.red version [e3cb8b7cfc].































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
module consel;

%/*Constructors and selectors for a distributed polynomial form*/

%/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/

%/*A distributive polynomial has the following informal syntax:
%
%   <dipoly> ::= dipzero
%                | <exponent vector> . <base coefficient> . <dipoly>*/

%define dipzero = 'nil;

fluid '(dipzero);
     %/*Until we understand how to define something to nil*/


smacro procedure dipzero!? u; null u;

smacro procedure diplbc p;
%  /* Distributive polynomial leading base coefficient.
%    p is a distributive polynomial. diplbc(p)  returns
%    the leading base coefficient of p. */
   cadr p;

smacro procedure dipmoncomp (a,e,p);
%  /* Distributive polynomial monomial composition. a is a base
%    coefficient, e is an exponent vector and p is a
%    distributive polynomial. dipmoncomp(a,e,p) returns a dis-
%    tributive polynomial with p as monomial reductum, e as
%    exponent vector of the leading monomial and a as leading
%    base coefficient. */
   e . a . p;

smacro procedure dipevlmon p;
%  /* Distributive polynomial exponent vector leading monomial.
%    p is a distributive polynomial. dipevlmon(p) returns the
%    exponent vector of the leading monomial of p. */
   car p;

smacro procedure dipfmon (a,e);
%  /* Distributive polynomial from monomial. a is a base coefficient
%    and e is an exponent vector. dipfmon(a,e) returns a
%    distributive polynomial with e as exponent vector and
%    a as base coefficient. */
   e . a . dipzero;

smacro procedure dipnov p;
%  /* Distributive polynomial number of variables. p is a distributive
%    polynomial. dipnov(p) returns a digit, the number of variables
%    of the distributive polynomial p. */
   length car p;

smacro procedure dipmred p;
%  /* Distributive polynomial reductum. p is a distributive polynomial
%    dipmred(p) returns the reductum of the distributive polynomial p,
%    a distributive polynomial. */
   cddr p;

endmodule;


module bcoeff;  % Computation of base coefficients.


%/*Definitions of base coefficient operations for distributive
% polynomial package.  We assume that only field elements are used, but
% no check is made for this.  In this module, a standard quotient
% coefficient is assumed*/


%/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/

global '(!*nat);

expr procedure bcless!? (a1,a2);
%  /* Base coefficient less. a1 and a2 are base coefficients.
%    bcless!?(a1,a2) returns a boolean expression, true if
%    a1 is less than a2 else false. */
     minusf numr addsq(a1,negsq a2);


smacro procedure bcminus!? u;
%   /* Boolean function. Returns true if u is a negative base coeff*/
   minusf numr u;


smacro procedure bczero!? u;
%  /* Returns a boolean expression, true if the base coefficient u is
%    zero*/
   null numr u;


expr procedure bccomp (a1,a2);
%  /* Base coefficient compare a1 and a2 are base coefficients.
%    bccomp(a1,a2) compares the base coefficients a1 and a2 and returns
%    a digit 1 if a1 greater than a2, a digit 0 if a1 equals a2 else a
%    digit -1. */
     (if bczero!? sl then 0
       else if bcminus!? sl then -1
       else 1)
       where sl = bcdif(a1, a2);


expr procedure bcfi a;
%  /* Base coefficient from integer. a is an integer. bcfi(a) returns
%    the base coefficient a. */
     mkbc(a,1);


expr procedure bclcmd(u,v);
% Base coefficient least common multiple of denominators.
% u and v are two base coefficients. bclcmd(u,v) calculates the
% least common multiple of the denominator of u and the
% denominator of v and returns a base coefficient of the form
% 1/lcm(denom u,denom v).
  if bczero!? u then mkbc(1,denr v)
   else if bczero!? v then mkbc(1,denr u)
   else mkbc(1,multf(quotf(denr u,gcdf(denr u,denr v)),denr v));


expr procedure bclcmdprod(u,v);
% Base coefficient least common multiple denominator product.
% u is a basecoefficient of the form 1/integer. v is a base
% coefficient. bclcmdprod(u,v) calculates (denom u/denom v)*nom v/1
% and returns a base coefficient.
  mkbc(multf(quotf(denr u,denr v),numr v),1);


expr procedure bcquod(u,v);
% Base coefficient quotient. u and v are base coefficients.
% bcquod(u,v) calculates u/v and returns a base coefficient.
  bcprod(u,bcinv v);


expr procedure bcone!? u;
%  /* Base coefficient one. u is a base coefficient.
%    bcone!?(u) returns a boolean expression, true if the
%    base coefficient u is equal 1. */
   denr u = 1 and numr u = 1;


expr procedure bcinv u;
%  /* Base coefficient inverse. u is a base coefficient.
%    bcinv(u) calculates 1/u and returns a base coefficient. */
    invsq u;


expr procedure bcneg u;
%  /* Base coefficient negative. u is a base coefficient.
%    bcneg(u) returns the negative of the base coefficient
%    u, a base coefficient. */
   negsq u;


expr procedure bcprod (u,v);
%  /* Base coefficient product. u and v are base coefficients.
%    bcprod(u,v) calculates u*v and returns a base coefficient.
   multsq(u,v);

expr procedure mkbc(u,v);
%   /* Convert u and v into u/v in lowest terms*/
   if v = 1 then u ./ v
    else if v<0 then mkbc(negf u,negf  v)
    else quotf(u,m) ./ quotf(v,m) where m = gcdf(u,v);


expr procedure bcquot (u,v);
%  /* Base coefficient quotient. u and v are base coefficients.
%    bcquot(u,v) calculates u/v and returns a base coefficient. */
   quotsq(u,v);


expr procedure bcsum (u,v);
%  /* Base coefficient sum. u and v are base coefficients.
%    bcsum(u,v) calculates u+v and returns a base coefficient. */
   addsq(u,v);


expr procedure bcdif(u,v);
%  /* Base coefficient difference. u and v are base coefficients.
%    bcdif(u,v) calculates u-v and returns a base coefficient. */
   bcsum(u,bcneg v);


expr procedure bcpow(u,n);
%   /*Returns the base coefficient u raised to the nth power, where
%    n is an integer*/
   exptsq(u,n);


expr procedure a2bc u;
%   /*Converts the algebraic (kernel) u into a base coefficient.
    simp!* u;


expr procedure bc2a u;
%   /* Returns the prefix equivalent of the base coefficient u*/
   prepsq u;


expr procedure bcprin u;
%   /* Prints a base coefficient in infix form*/
   begin scalar nat;
      nat := !*nat;
      !*nat := nil;
      sqprint u;
      !*nat := nat
    end;

endmodule;


module expvec;

% /*Specific support for distributive polynomial exponent vectors*/

% /* Authors: R. Gebauer, A. C. Hearn, H. Kredel */

%   We assume here that an exponent vector is a list of integers.  This
%   version uses small integer arithmetic on the individual exponents
%   and assumes that a compiled function can be dynamically redefined*/


fluid '(dipsortmode!* dipvars!*);


expr procedure evperm (e1,n);
%  /* Exponent vector permutation. e1 is an exponent vector, n is a
%    index list , a list of digits. evperm(e1,n) returns a list e1
%    permuted in respect to n. */
     if null n then nil
        else evnth(e1, car n) . evperm(e1, cdr n);


expr procedure evcons (e1,e2);
%  /* Exponent vector construct. e1 and e2 are exponents. evcons(e1,e2)
%    constructs an exponent vector. */
     e1 . e2;


expr procedure evnth (e1,n);
%  /* Exponent vector n-th element. e1 is an exponent vector, n is a
%    digit. evnth(e1,n) returns the n-th element of e1, an exponent. */
     if n = 1 then evfirst e1
        else evnth(evred e1, n - 1);


expr procedure evred e1;
%  /* Exponent vector reductum. e1 is an exponent vector. evred(e1)
%    returns the reductum of the exponent vector e1. */
     cdr e1;


expr procedure evfirst e1;
%  /* Exponent vector first. e1 is an exponent vector. evfirst(e1)
%   returns the first element of the exponent vector e1, an exponent. */
     car e1;


expr procedure evsum0(n,p);
% exponent vector sum version 0. n is the length of dipvars!*.
% p is a distributive polynomial.
  if dipzero!? p then evzero1 n else
  evsum(dipevlmon p, evsum0(n,dipmred p));


expr procedure evzero1 n;
% Returns the exponent vector power representation
% of length n for a zero power.
  begin scalar x;
   for i:=1: n do << x := 0 . x >>;
  return x
  end;


expr procedure indexcpl(ev,n);
% returns a list of indixes of non zero exponents.
  if null ev then ev else ( if car ev = 0 then
                            indexcpl(cdr ev,n + 1) else
     ( n . indexcpl(cdr ev,n + 1))  );


expr procedure evzer1!? e;
% returns a boolean expression. true if e is null else false.
  null e;


expr procedure evzero!? e;
%  /* Returns a boolean expression. True if all exponents are zero*/
   null e or car e = 0 and evzero!? cdr e;


expr procedure evzero;
%  /* Returns the exponent vector representation for a zero power*/
   % for i := 1:length dipvars!* collect 0;
   begin scalar x;
      for i := 1:length dipvars!* do <<x := 0 . x>>;
      return x
   end;


expr procedure mkexpvec u;
%  /* Returns an exponent vector with a 1 in the u place*/
   if not(u member dipvars!*) then typerr(u,"dipoly variable")
    else for each x in dipvars!* collect if x eq u then 1 else 0;


expr procedure evcompless!?(e1,e2);
%  /* Exponent vector compare less. e1, e2 are exponent vectors
%    in some order. Evcompless? is a boolean function which returns
%    true if e1 is ordered less than e2. This function is assigned a
%    value by the ordering mechanism, so is dummy for now*/
   apply(get(dipsortmode!*,'evcompless!?),list(e1,e2));


expr procedure evlexcompless!?(e1,e2);
%  /* Exponent vector lexicographical compare less. e1, e2 are exponent
%    vectors in lexicographical order. Evlexcompless?(e1,e2) is a
%    boolean function which returns true if e1 is ordered less than e2*/
   if null e1 then nil
    else if car e1 = car e2 then evlexcompless!?(cdr e1,cdr e2)
    else car e1 #> car e2;


expr procedure evcomp (e1,e2);
%  /* Exponent vector compare. e1, e2 are exponent vectors in some
%    order.  Evcomp(e1,e2) returns the digit 0 if exponent vector e1 is
%    equal exponent vector e2, the digit 1 if e1 is greater than e2,
%    else the digit -1. This function is assigned a value by the
%    ordering mechanism, so is dummy for now*/
   apply(get(dipsortmode!*,'evcomp),list(e1,e2));


expr procedure evilcompless!?(e1,e2);
% /* Exponent vector inverse lexicographical compare less. e1, e2 are
%  exponent vectors in lexicographical order.  Evilcompless?(e1,e2) is
%  a boolean function which returns true if e1 is ordered less than e2*/
   if null e1 then nil
    else if car e1 = car e2 then evilcompless!?(cdr e1,cdr e2)
    else car e1 #< car e2;


expr procedure evlexcomp(e1,e2);
%  /* Exponent vector lexicographical compare. e1, e2 are exponent
%    vectors in lexicographical order.  Evlexcomp(e1,e2) returns the
%    digit 0 if exponent vector e1 is equal exponent vector e2, 1 if e1
%    is greater than e2, else the digit -1. */
   if null e1 then 0
    else if car e1 = car e2 then evlexcomp(cdr e1,cdr e2)
    else if car e1 #< car e2 then 1
    else -1;


expr procedure evilcomp (e1,e2);
%  /* Exponent vector inverse lexicographical compare. The
%    exponent vectors e1 and e2 are in inverse lexicographical
%    ordering. evilcomp(e1,e2) returns the digit 0 if exponent
%    vector e1 is equal exponent vector e2, the digit 1 if e1 is
%    greater than e2, else the digit -1. */
   if null e1 then 0
    else if car e1 = car e2 then evilcomp(cdr e1,cdr e2)
    else if car e1 #> car e2 then 1
    else -1;


expr procedure evitdcompless!?(e1,e2);
%  /* Exponent vector inverse total degree compare less.
%    The exponent vectors e1 and e2 are in inverse total degree
%    ordering. evitdcompless!?(e1,e2) is a boolean function that
%    returns true if exponent vector e1 is ordered less than e2*/
   if null e1 then nil
    else if car e1 = car e2 then evitdcompless!?(cdr e1, cdr e2)
    else (if te1 = te2 then car e1 #< car e2 else te1 #< te2)
          where te1 = evtdeg e1, te2 = evtdeg e2;


expr procedure evtdcompless!?(e1,e2);
%  /*Exponent vector total degree compare less.*/
   if null e1 then nil
     else if car e1 = car e2 then evtdcompless!?(cdr e1,cdr e2)
     else (if te1 = te2 then car e1 #> car e2 else te1 #< te2)
           where te1 = evtdeg e1, te2 = evtdeg e2;


expr procedure evitdcomp (e1,e2);
%  /* Exponent vector inverse total degree compare.
%    The exponent vectors e1 and e2 are in inverse total degree
%    ordering. evitdcomp(e1,e2) returns the digit 0 if exponent
%    vector e1 is equal exponent vector e2, the digit 1 if e1 is
%    greater than e2, else the digit -1. */
   if null e1 then 0
    else if car e1 = car e2 then evitdcomp(cdr e1, cdr e2)
    else (if te1 = te2 then if car e1 #> car e2 then 1 else -1
           else if te1 #> te2 then 1 else -1)
          where te1 = evtdeg e1, te2 = evtdeg e2;


expr procedure evtdcomp (e1,e2);
% /* ... */
   if null e1 then 0
    else if car e1 = car e2 then evtdcomp(cdr e1,cdr e2)
    else (if te1 = te2 then if car e1 #< car e2 then 1 else -1
           else if te1 #> te2 then 1 else -1)
          where te1 = evtdeg e1, te2 = evtdeg e2;


expr procedure evtdeg e1;
%  /* Exponent vector total degree. e1 is an exponent vector.
%    evtdeg(e1) calculates the total degree of the exponent
%    e1 and returns an integer. */
   (<<while e1 do <<x := car e1 #+ x; e1 := cdr e1>>; x>>) where x = 0;


expr procedure evlcm (e1,e2);
%  /* Exponent vector least common multiple. e1 and e2 are
%    exponent vectors. evlcm(e1,e2) computes the least common
%    multiple of the exponent vectors e1 and e2, and returns
%    an exponent vector. */
   % for each lpart in e1 each rpart in e2 collect
   %     if lpart #> rpart then lpart else rpart;
   begin scalar x;
      while e1 do
         <<x := (if car e1 #> car e2 then car e1 else car e2) . x;
           e1 := cdr e1; e2 := cdr e2>>;
      return reversip x
   end;


expr procedure evmtest!? (e1,e2);
%  /* Exponent vector multiple test. e1 and e2 are compatible exponent
%    vectors. evmtest!?(e1,e2) returns a boolean expression.
%    True if exponent vector e1 is a multiple of exponent
%    vector e2, else false. */
   null e1 or not(car e1 #< car e2) and evmtest!?(cdr e1,cdr e2);


expr procedure evsum (e1,e2);
%  /* Exponent vector sum. e1 and e2 are exponent vectors.
%    evsum(e1,e2) calculates the sum of the exponent vectors.
%    e1 and e2 componentwise and returns an exponent vector. */
   % for each lpart in e1 each rpart in e2 collect lpart #+ rpart;
     begin scalar x;
      while e1 do
         <<x := (car e1 #+ car e2) . x; e1 := cdr e1; e2 := cdr e2>>;
      return reversip x
   end;


expr procedure evdif (e1,e2);
%  /* Exponent vector difference. e1 and e2 are exponent
%    vectors. evdif(e1,e2) calculates the difference of the
%    exponent vectors e1 and e2 componentwise and returns an
%    exponent vector. */
   % for each lpart in e1 each rpart in e2 collect lpart #- rpart;
   begin scalar x;
      while e1 do
         <<x := (car e1 #- car e2) . x; e1 := cdr e1; e2 := cdr e2>>;
      return reversip x
   end;


expr procedure intevprod(n,e);
% /* Multiplies each element of the exponent vector u by the integer n*/
   for each x in e collect n #* x;


expr procedure expvec2a e;
%  /* Returns list of prefix equivalents of exponent vector e*/
   expvec2a1(e,dipvars!*);


expr procedure expvec2a1(u,v);
%  /* Sub function of expvec2a */
   if null u then nil
    else if car u = 0 then expvec2a1(cdr u,cdr v)
    else if car u = 1 then car v . expvec2a1(cdr u,cdr v)
    else list('expt,car v,car u) . expvec2a1(cdr u,cdr v);


expr procedure dipevlpri(e,v);
%  /* Print exponent vector e in infix form. V is a boolean variable
%    which is true if an element in a product has preceded this one*/
   dipevlpri1(e,dipvars!*,v);


expr procedure dipevlpri1(e,u,v);
%  /* Sub function of dipevlpri */
   if null e then nil
    else if car e = 0 then dipevlpri1(cdr e,cdr u,v)
    else <<if v then dipprin2 "*";
           dipprin2 car u;
           if car e #> 1 then <<dipprin2 "**"; dipprin2 car e>>;
           dipevlpri1(cdr e,cdr u,t)>>;


remprop('torder,'stat);

expr procedure torder u;
   % algebraic mode interface to dipsortingmode.
   dipsortingmode car u;

put('torder,'stat,'rlis);

expr procedure dipsortingmode u;
%  /* Sets the exponent vector sorting mode. Returns the previous mode*/
   if not idp u or not flagp(u,'dipsortmode)
     then typerr(u,"term ordering mode")
    else begin scalar x;
            x := dipsortmode!*; dipsortmode!* := u; return x
         end;


flag('(lex invlex totaldegree invtotaldegree),'dipsortmode);

put('lex,'evcompless!?,'evlexcompless!?);

put('lex,'evcomp,'evlexcomp);

put('invlex,'evcompless!?,'evilcompless!?);

put('invlex,'evcomp,'evilcomp);

put('invtotaldegree,'evcompless!?,'evitdcompless!?);

put('invtotaldegree,'evcomp,'evitdcomp);

put('totaldegree,'evcompless!?,'evtdcompless!?);

put('totaldegree,'evcomp,'evtdcomp);

dipsortingmode 'invlex;   % /*Default value*/


endmodule;


module dipoly;  % /*Distributive polnomial algorithms*/

%/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/

fluid '(dipvars!* dipzero);

fexpr procedure polyin p; a2dip car p;

expr procedure dipconst!? p;
 not dipzero!? p
 and dipzero!? dipmred p
 and evzero!? dipevlmon p;


expr procedure   dfcprint pl;
% h polynomial factor list of distributive polynomials print.
for each p in pl do dfcprintin p;

expr procedure   dfcprintin p;
% factor with exponent print.
( if cdr p neq 1 then << prin2 " ( "; dipprint1(p1,nil); prin2 " )** ";
  prin2 cdr p; terprit 2  >> else << prin2 "  "; dipprint p1>> )
      where p1:= dipmonic a2dip prepf car p;

expr procedure   dfcprin p;
% print content, factors and exponents of factorized polynomial p.
   << terpri(); prin2 " content of factorized polynomials  =  ";
   prin2 car p;
   terprit 2; dfcprint cdr p >>;


expr procedure diplcm p;
% Distributive polynomial least common multiple of denomiators.
% p is a distributive rational polynomial. diplcm(p) calculates
% the least common multiple of the denominators and returns a
% base coefficient of the form  1/lcm(denom bc1,.....,denom bci).
  if dipzero!? p then mkbc(1,1)
     else bclcmd(diplbc p, diplcm dipmred p);

expr procedure diprectoint(p,u);
% Distributive polynomial conversion rational to integral.
% p is a distributive rational polynomial, u is a base coefficient
% ( 1/lcm denom p ). diprectoint(p,u) returns a primitive
% associate pseudo integral ( denominators are 1 ) distributive
% polynomial.
  if bczero!? u then dipzero
     else if bcone!? u then p
          else diprectoint1(p,u);

expr procedure diprectoint1(p,u);
% Distributive polynomial conversion rational to integral internall 1.
% diprectoint1 is used in diprectoint.
  if dipzero!? p then dipzero
     else dipmoncomp(bclcmdprod(u,diplbc p),dipevlmon p,
                     diprectoint1(dipmred p,u));


expr procedure dipresul(p1,p2);
% test for fast downwards calculation
% p1 and p2 are two bivariate distributive polynomials.
% dipresul(p1,p2) returns the resultant of p1 and p2 with respect
% respect to the first variable of the variable list (car dipvars!*).
 begin scalar q1,q2,q,ct;
 q1:=dip2a diprectoint(p1,diplcm p1);
 q2:=dip2a diprectoint(p2,diplcm p2);
 ct := time();
 q:= a2dip prepsq simpresultant list(q1,q2,car dipvars!*);
 ct := time() - ct;
 prin2 " resultant : "; dipprint dipmonic q; terpri();
 prin2 " time resultant : "; prin2 ct; terpri();
 end;

expr procedure   dipbcprod (p,a);
%   /* Distributive polynomial base coefficient product.
%     p is a distributive polynomial, a is a base coefficient.
%     dipbcprod(p,a) computes p*a, a distributive polynomial. */

     if bczero!? a then dipzero
                  else if bcone!? a then p
                                   else dipbcprodin(p,a);

expr procedure   dipbcprodin (p,a);
%   /* Distributive polynomial base coefficient product internal.
%     p is a distributive polynomial, a is a base coefficient,
%     where a is not equal 0 and not equal 1.
%     dipbcprodin(p,a) computes p*a, a distributive polynomial. */

     if dipzero!? p then dipzero
                   else dipmoncomp(bcprod(a, diplbc p),
                                   dipevlmon p,
                                   dipbcprodin(dipmred p, a));


expr procedure dipdif (p1,p2);
%   /* Distributive polynomial difference. p1 and p2 are distributive
%    polynomials. dipdif(p1,p2) calculates the difference of the
%    two distributive polynomials p1 and p2, a distributive polynomial*/
     if dipzero!? p1 then dipneg p2
        else if dipzero!? p2 then p1
             else ( if sl = 1 then dipmoncomp(diplbc p1,
                                              ep1,
                                              dipdif(dipmred p1, p2) )
                  else if sl = -1 then dipmoncomp(bcneg diplbc p2,
                                                  ep2,
                                                  dipdif(p1,dipmred p2))
                       else ( if bczero!? al
                                then dipdif(dipmred p1, dipmred p2)
                              else dipmoncomp(al,
                                              ep1,
                                              dipdif(dipmred p1,
                                                     dipmred p2) )
                            ) where al = bcdif(diplbc p1, diplbc p2)
                  ) where sl = evcomp(ep1, ep2)
                       where ep1 = dipevlmon p1, ep2 = dipevlmon p2;

expr procedure   diplength p;
%   /* Distributive polynomial length. p is a distributive
%     polynomial. diplength(p) returns the number of terms
%     of the distributive polynomial p, a digit.*/

     if dipzero!? p then 0 else 1 + diplength dipmred p;



expr procedure   diplistsum pl;
%   /* Distributive polynomial list sum. pl is a list of distributive
%     polynomials. diplistsum(pl) calculates the sum of all polynomials
%     and returns a list of one distributive polynomial. */

     if null pl or null cdr pl then pl
        else diplistsum(dipsum(car pl, cadr pl) . diplistsum cddr pl);



expr procedure   diplmerge (pl1,pl2);
%  /* Distributive polynomial list merge. pl1 and pl2 are lists
%    of distributive polynomials where pl1 and pl2 are in non
%    decreasing order. diplmerge(pl1,pl2) returns the merged
%    distributive polynomial list of pl1 and pl2. */

    if null pl1 then pl2
       else if null pl2 then pl1
            else ( if sl >= 0 then cpl1 . diplmerge(cdr pl1, pl2)
                 else cpl2 . diplmerge(cdr pl2, pl1)
                 ) where sl = evcomp(ep1, ep2)
                      where ep1 = dipevlmon cpl1, ep2 = dipevlmon cpl2
                         where cpl1 = car pl1, cpl2 = car pl2;

expr procedure   diplsort pl;
%  /* Distributive polynomial list sort. pl is a list of
%    distributive polynomials. diplsort(pl) returns the
%    sorted distributive polynomial list of pl.
   sort(pl, function dipevlcomp);

expr procedure   dipevlcomp (p1,p2);
%  /*  Distributive polynomial exponent vector leading monomial
%     compare. p1 and p2 are distributive polynomials.
%     dipevlcomp(p1,p2) returns a boolean expression true if the
%     distributive polynomial p1 is smaller or equal the distributive
%     polynomial p2 else false. */

   not evcompless!?(dipevlmon p1, dipevlmon p2);



expr procedure   dipmonic p;
%   /* Distributive polynomial monic. p is a distributive
%     polynomial. dipmonic(p) computes p/lbc(p) if p is
%     not equal dipzero and returns a distributive
%     polynomial, else dipmonic(p) returns dipzero. */

     if dipzero!? p then p
                   else dipbcprod(p, bcinv diplbc p);



expr procedure   dipneg p;
%  /* Distributive polynomial negative. p is a distributive
%    polynomial. dipneg(p) returns the negative of the distributive
%    polynomial p, a distributive polynomial. */

    if dipzero!? p then p
       else dipmoncomp ( bcneg diplbc p,
                         dipevlmon p,
                         dipneg dipmred p );



expr procedure   dipone!? p;
%  /* Distributive polynomial one.  p is a distributive polynomial.
%    dipone!?(p) returns a boolean value. If p is the distributive
%    polynomial one then true else false. */

    not dipzero!? p
        and dipzero!? dipmred p
            and evzero!? dipevlmon p
                and bcone!? diplbc p;



expr procedure   dippairsort pl;
%  /* Distributive polynomial list pair merge sort. pl is a list
%    of distributive polynomials. dippairsort(pl) returns the
%    list of merged and in non decreasing order sorted
%    distributive polynomials. */

    if null pl or null cdr pl then pl
       else diplmerge(diplmerge( car(pl) . nil, cadr(pl) . nil ),
                      dippairsort cddr pl);



expr procedure   dipprod (p1,p2);
%   /* Distributive polynomial product. p1 and p2 are distributive
%    polynomials. dipprod(p1,p2) calculates the product of the
%    two distributive polynomials p1 and p2, a distributive polynomial*/

     if diplength p1 <= diplength p2 then dipprodin(p1, p2)
        else dipprodin(p2, p1);



expr procedure   dipprodin (p1,p2);
%   /* Distributive polynomial product internal. p1 and p2 are distrib
%    polynomials. dipprod(p1,p2) calculates the product of the
%    two distributive polynomials p1 and p2, a distributive polynomial*/

     if dipzero!? p1 or dipzero!? p2 then dipzero
        else ( dipmoncomp(bcprod(bp1, diplbc p2),
                        evsum(ep1, dipevlmon p2),
                        dipsum(dipprodin(dipfmon(bp1, ep1),
                                         dipmred p2),
                               dipprodin(dipmred p1, p2) ) )
             ) where bp1 = diplbc p1,
                     ep1 = dipevlmon p1;



expr procedure   dipprodls (p1,p2);
%   /* Distributive polynomial product. p1 and p2 are distributive
%     polynomials. dipprod(p1,p2) calculates the product of the
%     two distributive polynomials p1 and p2, a distributive polynomial
%     using distributive polynomials list sum (diplistsum). */

     if dipzero!? p1 or dipzero!? p2 then dipzero
        else car diplistsum if diplength p1 <= diplength p2
                               then dipprodlsin(p1, p2)
                               else dipprodlsin(p2, p1);



expr procedure   dipprodlsin (p1,p2);
%   /* Distributive polynomial product. p1 and p2 are distributive
%     polynomials. dipprod(p1,p2) calculates the product of the
%     two distributive polynomials p1 and p2, a distributive polynomial
%     using distributive polynomials list sum (diplistsum). */

     if dipzero!? p1 or dipzero!? p2 then nil
        else ( dipmoncomp(bcprod(bp1, diplbc p2),
                          evsum(ep1, dipevlmon p2),
                          car dipprodlsin(dipfmon(bp1, ep1),
                                          dipmred p2))
                          . dipprodlsin(dipmred p1, p2)
             ) where bp1 = diplbc p1,
                     ep1 = dipevlmon p1;



expr procedure   dipsum (p1,p2);
%  /* Distributive polynomial sum. p1 and p2 are distributive
%    polynomials. dipsum(p1,p2) calculates the sum of the
%    two distributive polynomials p1 and p2, a distributive polynomial*/

    if dipzero!? p1 then p2
       else if dipzero!? p2 then p1
            else ( if sl = 1 then dipmoncomp(diplbc p1,
                                             ep1,
                                             dipsum(dipmred p1, p2) )
                 else if sl = -1 then dipmoncomp(diplbc p2,
                                                 ep2,
                                                 dipsum(p1,dipmred p2))
                      else ( if bczero!? al then dipsum(dipmred p1,
                                                        dipmred p2)
                             else dipmoncomp(al,
                                             ep1,
                                             dipsum(dipmred p1,
                                                    dipmred p2) )
                           ) where al = bcsum(diplbc p1, diplbc p2)
                 ) where sl = evcomp(ep1, ep2)
                      where  ep1 = dipevlmon p1, ep2 = dipevlmon p2;

endmodule;


module dipvars;

%/* Determine distributive polynomial variables in a prefix form*/

%/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/

expr procedure dipvars u;
%   /* Returns list of variables in prefix form u*/
   dipvars1(u,nil);

expr procedure dipvars1(u,v);
   if atom u then if constantp u or u memq v then v else u . v
    else if idp car u and get(car u,'dipfn)
     then dipvarslist(cdr u,v)
    else if u memq v then v
    else u . v;

expr procedure dipvarslist(u,v);
   if null u then v
    else dipvarslist(cdr u,union(dipvars car u,v));

endmodule;


module a2dip;
  %/*Convert an algebraic (prefix) form to distributive polynomial*/

%/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/

fluid '(dipvars!* dipzero);

expr procedure a2dip u;
%   /*Converts the algebraic (prefix) form u to a distributive poly.
%     We assume that all variables used have been previously
%     defined in dipvars!*, but a check is also made for this*/
   if atom u then a2dipatom u
    else if not atom car u or not idp car u 
     then typerr(car u,"dipoly operator")
    else (if x then apply(x,list for each y in cdr u collect a2dip y)
           else a2dipatom u)
          where x = get(car u,'dipfn);

expr procedure a2dipatom u;
%   /*Converts the atom (or kernel) u into a distributive polynomial*/
   if u=0 then dipzero
    else if numberp u or not(u member dipvars!*)
      then dipfmon(a2bc u,evzero())
    else dipfmon(a2bc 1,mkexpvec u);

expr procedure dipfnsum u;
%   /*U is a list of dip expressions. Result is the distributive poly
%    representation for the sum*/
   (<<for each y in cdr u do x := dipsum(x,y); x>>) where x = car u;

put('plus,'dipfn,'dipfnsum);

put('plus2,'dipfn,'dipfnsum);

expr procedure dipfnprod u;
%   /*U is a list of dip expressions. Result is the distributive poly
%    representation for the product*/
%   /*Maybe we should check for a zero*/
   (<<for each y in cdr u do x := dipprod(x,y); x>>) where x = car u;

put('times,'dipfn,'dipfnprod);

put('times2,'dipfn,'dipfnprod);

expr procedure dipfndif u;
%   /*U is a list of two dip expressions. Result is the distributive
%    polynomial representation for the difference*/
   dipsum(car u,dipneg cadr u);

put('difference,'dipfn,'dipfndif);

expr procedure dipfnpow u;
%   /*U is a pair of dip expressions. Result is the distributive poly
%    representation for the first raised to the second power*/
  (if not fixp n or n<0 
     then typerr(n,"distributive polynomial exponent")
    else if n=0 then if dipzero!? v then rederr "0**0 invalid"
                      else w
    else if dipzero!? v or n=1 then v
    else if dipzero!? dipmred v
     then dipfmon(bcpow(diplbc v,n),intevprod(n,dipevlmon v))
    else <<while n>0 do
           <<if not evenp n then w := dipprod(w,v);
             n := n/2;
             if n>0 then v := dipprod(v,v)>>;
           w>>)
    where n := dip2a cadr u, v := car u,
          w := dipfmon(a2bc 1,evzero());

put('expt,'dipfn,'dipfnpow);

expr procedure dipfnneg u;
%   /*U is a list of one dip expression. Result is the distributive
%    polynomial representation for the negative*/
   (if dipzero!? v then v
    else dipmoncomp(bcneg diplbc v,dipevlmon v,dipmred v))
    where v = car u;

put('minus,'dipfn,'dipfnneg);

expr procedure dipfnquot u;
%   /*U is a list of two dip expressions. Result is the distributive
%    polynomial representation for the quotient*/
   if dipzero!? cadr u or not dipzero!? dipmred cadr u
         or not evzero!? dipevlmon cadr u
      then typerr(dip2a cadr u,"distributive polynomial denominator")
    else dipfnquot1(car u,diplbc cadr u);

expr procedure dipfnquot1(u,v);
   if dipzero!? u then u
    else dipmoncomp(bcquot(diplbc u,v),
                    dipevlmon u,
                    dipfnquot1(dipmred u,v));

put('quotient,'dipfn,'dipfnquot);

endmodule;


module dip2a;

%/* Functions for converting distributive forms into prefix forms*/

%/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/

expr procedure dip2a u;
%   /* Returns prefix equivalent of distributive polynomial u*/
   if dipzero!? u then 0 else dipreplus dip2a1 u;

expr procedure dip2a1 u;
   if dipzero!? u then nil
    else ((if bcminus!? x then list('minus,dipretimes(bc2a bcneg x . y))
           else dipretimes(bc2a x . y))
          where x = diplbc u, y = expvec2a dipevlmon u)
                 . dip2a1 dipmred u;

expr procedure dipreplus u;
   if atom u then u else if null cdr u then car u else 'plus . u;

expr procedure dipretimes u;
%   /* U is a list of prefix expressions the first of which is a number.
%     Result is prefix representation for their product*/
   if car u = 1 then if cdr u then dipretimes cdr u else 1
    else if null cdr u then car u
    else 'times . u;

endmodule;


module dipprint;   %/* printing routines for distributive polynomials*/

%/*Authors: R. Gebauer, A. C. Hearn, H. Kredel*/

fluid '(dipvars!*);

expr procedure diplprint u;
%   /* Prints a list of distributive polynomials using dipprint*/
     for each v in u do dipprint v;

expr procedure dipprint u;
%   /* Prints a distributive polynomial in infix form*/
   <<terpri(); dipprint1(u,nil); terpri(); terpri()>>;

expr procedure dipprint1(u,v);
%   /* Prints a distributive polynomial in infix form.
%     U is a distributive form. V is a flag which is true if a term
%     has preceded current form*/
   if dipzero!? u then if null v then dipprin2 0 else nil
    else begin scalar bool,w;
       w := diplbc u;
       if bcminus!? w then <<bool := t; w := bcneg w>>;
       if bool then dipprin2 " - " else if v then dipprin2 " + ";
       (if not bcone!? w or evzero!? x then <<bcprin w; dipevlpri(x,t)>>
         else dipevlpri(x,nil))
           where x = dipevlmon u;
       dipprint1(dipmred u,t)
     end;

expr procedure dipprin2 u;
%   /* Prints u, preceding by two EOL's if we have reached column 70*/
   <<if posn()>69 then <<terpri(); terpri()>>; prin2 u>>;

endmodule;


module grinterf;  % Interface of Groebner package to REDUCE.

% /*Authors: R. Gebauer, A. C. Hearn, M. Moeller.

fluid '(dipvars!*);

expr procedure groebnereval u;
   begin integer n;
      n := length u;
      if n=1 then return groebner(reval car u,nil)
       else if n neq 2
        then rederr "GROEBNER called with wrong number of arguments"
       else return groebner(reval car u,reval cadr u)
      end;

put('groebner,'psopfn,'groebnereval);

expr procedure greduce u;
% /* Polynomial reduction modulo a Groebner basis driver. u is an
% expression and v a list of expressions.  Greduce calculates the
% polynomial u reduced wrt the list of expressions v reduced to a
% groebner basis modulo using the optional third argument as the
% order of variables.
   begin integer n; scalar dipvars!*,v;
      n := length u;
      v := for each j in getrlist reval cadr u collect
                      if eqexpr j then !*eqn2a j else j;
      if n=2
        then dipvars!* := for each j in gvarlis v collect !*a2k j
       else if n=3 then dipvars!* := getrlist caddr u
       else rederr "GREDUCE called with wrong number of arguments";
      v := groebner2 for each j in v collect a2dip j;
      if cdr v then errach list("Groebner",u)
       else  if null cdar v and dip2a caar v = 1
        then rederr "Inconsistent Basis";
      return dip2a dipnorform(car v,a2dip reval car u)
   end;

put('greduce,'psopfn,'greduce);

expr procedure preduce(u,v);
% /* Polynomial reduction driver. u is an expression and v a list of
% expressions.  Preduce calculates the polynomial u reduced wrt the list
% of expressions v. */
   begin scalar dipvars!*;
      v := for each j in getrlist reval v collect
              if eqexpr j then !*eqn2a j else j;
      dipvars!* := for each j in gvarlis v collect !*a2k j;
      return dip2a dipnorform(for each j in v collect a2dip j,
                              a2dip reval u)
   end;

flag('(preduce),'opfn);

endmodule;


module groebner;  % Basic Groebner base code using Buchberger algorithm.

% /*Authors: R. Gebauer, A. C. Hearn, M. Moeller.

fluid '(!*groebopt !*groebfac !*hopt !*trgroeb !*trgroebs !*trgroeb0
        !*trgroeb1 dipvars!* dipzero);

switch groebopt,groebfac,hopt,trgroeb,trgroebs,trgroeb0,trgroeb1;

% /*   option ' groebopt'    "optimizes" the given input     */
% /*                         polynomial set ( variable       */
% /*                         ordering )                      */
% /*   option ' trgroeb'     prints intermediate             */
% /*                         results on the output file      */
% /*   option ' trgroeb1'    prints internal representation  */
% /*                         of critical pair list d         */
% /*   option ' trgroeb0'    factorizes the S - polynom      */
% /*                         the S - polynom will not be     */
% /*                         replaced by a factor            */
% /*   option ' trgroebs '   prints S - polynomials          */
% /*                         on the output file              */
% /*   option ' hopt '       the H- polynomials are          */
% /*                         optimised using resultant       */
% /*                         and factorisation method        */
% /*   option ' groebfac '   the H - polynomials are         */
% /*                         factorized. If a H - polynom    */
% /*                         could be factorized, new sub-   */
% /*                         problems are generated and      */
% /*                         option ' fac ' is set to off    */
% /*                         NOTE: this option is not complete     */
% /*                         at the moment and has been suppressed */

% expr procedure bas p; diplprint car groebner(p,dipvars!*);


expr procedure groebner(u,v);
% /* Buchberger algorithm system driver. u is a list of expressions
%    and v a list of variables or NIL in which case the variables in u
%    are used.  Groebner(p) calculates the Groebner basis of the
%     expressions wrt the variables. */
   begin scalar dipvars!*,w;
      w := for each j in getrlist u
              collect if eqexpr j then !*eqn2a j else j;
      if null w then rederr "Empty list in Groebner"
       else if null cdr w then return 'list . w;
      if null v then v := gvarlis w else v := getrlist v;
      dipvars!* := for each j in v collect !*a2k j;
      w := groebner2 for each j in w collect a2dip j;
      if cdr w then errach list("Groebner",u,dipvars!*);
      return 'list . for each j in car w collect dip2a j
   end;


expr procedure gvarlis u;
   % Finds variables (kernels) in the list of expressions u.
   gvarlis1(u,nil);


expr procedure gvarlis1(u,v);
   if null u then v
    else union(gvar1(car u,v),gvarlis1(cdr u,v));


expr procedure gvar1(u,v);
   if null u or numberp u then v
    else if atom u then if u member v then v else u . v
    else if car u memq '(plus times expt difference minus)
     then gvarlis1(cdr u,v)
    else if car u eq 'quotient then gvar1(cadr u,v)
    else if u member v then v
    else u . v;


expr procedure groebner2 p;
 begin scalar tim,spac,spac1,p1;
       tim   := time(); % terprit 3;
       spac := gctime(); p1:= dipgbase p;
       spac1 := gctime() - spac;
%      prin2 " garbage collection time for test     ";
%      prin2 spac1;
%      prin2 "( not yet available )";
       if !*trgroeb then
        <<prin2 "Computing time for test ";
          prin2(time() - tim - spac1);
%      prin2(time() - tim );
          prin2t " milliseconds  ">>;
       return p1
 end;


expr procedure  dipindexpol(pl,n);
% Distributive polynomial index list. pl is a list of distributive
% polynomials; n is an index, an integer. dipindexpol(pl,n)
% returns a list of distributive polynomials in the form
% ( (n,p1) (n+1,p2) ..... (n+k,pk) ).
  if null pl then pl else
             list(n,car pl) . dipindexpol(cdr pl, n + 1);


expr procedure  dipindexpolspec pl;
% Distributive polynomial special list. pl is a list produced
% by dipindexpol. dipindexpolspec pl constructs a list of lists
% of polynomials in the form ( (p1,.....,pl) (p2,.....,pl)....
% ..(pl-1,,pl) (pl) ).
  for each pl0 on pl collect
                   ( for each pl1 in pl0 collect pl1 );


expr procedure  dipcpairlistopt pl;
% Distributive critical pair list optimise. pl is a special list
% ( constructed by dipcpairlist ) of elements used in the
% Groebner calculation. dipcpairlistopt(pl) returns a list which
% is optimised using Buchberger criterion 4.
 if pl then ( if buchcrit4(caddr x, cadddr x, cadr x)
        then x . dipcpairlistopt cdr pl
        else dipcpairlistopt cdr pl
             ) where x = car pl  else nil;


expr procedure dipcpairlistop(d,d0);
% Distributive polynomial critical pair list optimise.
% dipcpairlistop(d,d0) returns an optimised critical pair
% starting list using the new criteria's.
   begin scalar x;
  while d do << x:= dipcpairlistopt1(cadar d,d0,d0);
                                        d0:= x; d:= cdr d>>;
   return x
   end;


expr procedure dipcpairlistopt1(h,d,d0);
% Distributive polynomial critical pair list optimise version 1.
% dipcpairlistopt1(h,d,d0) returns an optimised critical pair
% list.
  if null d then d0 else ( if evmtest!?(cadar d,ev1) then
            dipcpairlistopt1(h, cdr d,x) else
            dipcpairlistopt1(h,cdr d,d0)
                     ) where x= dipcpairlistopt1in(ev1,cadar d,car d,d0)
                    where  ev1 = dipevlmon h;


expr procedure dipcpairlistopt1in(ev1,ev2,id1,d);
% Distributive polynomial critical pair list optimise version 1.
% internall. dipcpairlistopt1in is used in dipcpairlistopt1.
  if ev2 neq evlcm(ev1,dipevlmon caddr id1) and
     ev2 neq evlcm(ev1,dipevlmon cadddr id1) then
         dipcpairlistopt1in1(id1,d) else d;


expr procedure dipcpairlistopt1in1(d1,d);
% Distributive polynomial critical pair list optimise version 1
% internall version 1. dipcpairlistopt1in1 is used in
% dipcpairlistopt1in.
  if null d then nil else if d1 eq car d then
            dipcpairlistopt1in1(d1,cdr d) else
            car d . dipcpairlistopt1in1(d1,cdr d);


expr procedure dipindexpolrec pl;
% Distributive index polynom list reconstruct. pl is a list of
% polynomials used in the Groebner calculation. dipindexpolrec(pl)
% returns a list of distributive polynomials.
  for each p in pl collect cadr p;


 expr procedure  dipcplist pl;
% Distributive polynomial critical pair list construct.
% dipcplist returns a list of elements where an element has the
% structure ( (ipi,ipj) lcm(epi,epj) pi pj ).
% where ipi is the index of polynomial i, epi is the headterm of
% the polynomial pi.
 for each p in pl
     conc ( dipcplistopt2(nil, dipcplistin(ep, pi1, reverse cdr p))
          ) where ep = dipevlmon cadr pi1 where pi1 = car p;


expr procedure  dipcplistin(ep,p1,pl);
% Distributive polynomial critical pair list construct internall.
% dipcplistin is used in dipcplist.
  if null pl then pl else
          ( list(list(car p1,car p2), evlcm(ep,dipevlmon cadr p2),
            cadr p1, cadr p2) . dipcplistin(ep, p1, cdr pl)
          ) where p2 = car pl;


expr procedure dipcplistadd(ind,p,pl);
% Distributive polynomial critical pair list add.
% dipcplistadd returns a new critical pair list where all
% combinations of p with pl are added.
  if null pl then pl else
     ( list(list(car ps,ind),evlcm(dipevlmon p1,
     dipevlmon p),p1,p) . dipcplistadd(ind,p,cdr pl)
     ) where p1 = cadr ps where ps = car pl;


expr procedure dipcplistopt2in(p1,pl);
% Distributive polynomial critical pair list optimise version 2
% internall use. dipcplistopt2in(pl1,pl) is used in
% dipcplistopt2.
  if null pl then dipzero else
       ( if evmtest!?(cadr p1, cadr p) then
            dipcplistopt2in1(p1,p)
         else dipcplistopt2in(p1,cdr pl)
       ) where p = car pl;


expr procedure dipcplistopt2in1(p1,p2);
% Distributive polynomial critical pair list optimise version 2
% internall use version 1. dipcplistopt2in1(pl1,pl) is used in
% dipcplistopt2in.
  if cadr p1 = cadr p2 then
     ( if evilcompless!?(reverse car p1, reverse car p2) then
       p1 else p2 )
       else p2;


expr procedure dipindexpoloptin(p1,pl);
% Distributive index polynomial list optimise internall use.
% dipindexpoloptin is used in dipindexpolopt.
if null pl then dipzero else
     ( if evmtest!?(dipevlmon cadr p1, dipevlmon cadr p) then
      dipindexpoloptin1(p1,p)
        else dipindexpoloptin(p1,cdr pl)
     ) where p = car pl;


expr procedure dipindexpoloptin1(p1,p2);
% Distributive index polynomial list optimise internall version 1.
% dipindexpoloptin1 is used in dipindexpoloptin.
  if dipevlmon cadr p1 = dipevlmon cadr p2
     then ( if car p1 < car p2 then p1 else p2 )
          else p2;


expr procedure dipcplistopt2(pl1,pl2);
% Distributive polynomial critical pair list optimise version 2.
% dipcplistopt2(pl1,pl2) returns the optimised critical pair list.
  if null pl2 then pl1 else
     ( if dipzero!? dipcplistopt2in(p,pl1)
       and dipzero!? dipcplistopt2in(p,pl0)
       then dipcplistopt2(cons(p,pl1),pl0)
       else dipcplistopt2(pl1,pl0)
     ) where p = car pl2, pl0 = cdr pl2;


expr procedure dipindexpolopt(pl1,pl2);
% Distributive index polynomial list optimise. pl1 and pl2
% are lists of polynomials used in the Groebner calculation.
% dipindexpolopt(pl1,pl2) returns an optimised list of polynomials.
  if null pl2 then pl1 else
   ( if dipzero!? dipindexpoloptin(p,pl1) and
        dipzero!? dipindexpoloptin(p,pl0)
        then dipindexpolopt(cons(p,pl1),pl0)
        else dipindexpolopt(pl1,pl0)
   ) where p = car pl2, pl0 = cdr pl2;


expr procedure dipcplistsort pl;
% Distributive polynomial critical pair list sort. pl is a
% special list for Groebner calculation. dipcplistsort(pl)
% returns the sorted list pl;
  begin scalar tree;
    if null pl then return nil;
    tree :=  list(car pl,nil);
    while pairp(pl:= cdr pl) do dipcplistsortadd(car pl,tree);
    return tree2list(tree,nil)
  end;


smacro procedure dipcplistevlcomp(p1,p2);
% Distributive polynomial critical pair list exponent vector
% compare. p1 and p2 are elements of the critical pair list.
% dipcplistevlcomp(p1,p2) returns a boolean expression, true
% if exponent vector of p1 is smaller or equal exponent vector
% of p2 else false.
  evcompless!?(cadr p1, cadr p2);


expr procedure dipcplistsortadd(item,node);
% Distributive polynomial critical pair list sort addition.
% add item to a node, using dipcplistevlcomp as an order
% predicate.
  if dipcplistevlcomp(item, car node) then if cadr node then
  dipcplistsortadd(item, cadr node) else
       rplaca(cdr node,list(item,nil))  else
       if cddr node then dipcplistsortadd(item,cddr node) else
       rplacd(cdr node,list(item,nil));


expr procedure dipcplistmerge(pl1,pl2);
% Distributive polynomial critical pair list merge. pl1 and pl2
% are critical pair lists used in the Groebner calculation.
% dipcplistmerge(pl1,pl2) returns the merged list.
  if null pl1 then pl2 else if null pl2 then pl1
  else ( if sl then cpl1 . dipcplistmerge(cdr pl1,pl2)
  else cpl2 . dipcplistmerge(pl1,cdr pl2)
       ) where sl = evcompless!?(cadr cpl1, cadr cpl2)
        where cpl1 = car pl1, cpl2 = car pl2;

expr procedure buchcrit4(p1,p2,e);
% Buchberger criterion 4. p1 and p2 are distributive
% polynomials. e is the least common multiple of
% the leading exponent vectors of the distributive
% polynomials p1 and p2. buchcrit4(p1,p2,e) returns a
% boolean expression. True if the reduction of the
% distributive polynomials p1 and p2 is necessary
% else false.
 e neq evsum( dipevlmon p1, dipevlmon p2);


expr procedure   dipgbase pl;
%  /* Distributive polynomial Groebner base. pl is a list of distributiv
%    polynomials. dipgbase(pl) calculates the Groebner base of the list
%    of distributive polynomials pl and returns a list of distributive
%    polynomials. */
    if null pl then nil
     else if null cdr pl then list pl
     else if !*groebopt then dipgbasein dipvordopt pl
     else dipgbasein pl;


expr procedure   gbprint pl;
% Groebner basis list of distributive polynomials print.
for each p in pl do dipprint dipmonic p;


expr procedure rescheck!?(a,h1,vl);
  length h1 = a and car h1 = vl - 1;


expr procedure rescheck1!?(a,h1,vl);
  length h1 = a and car h1 = vl - 2 and cadr h1 = vl - 1;


expr procedure newhpol(p1,p2,x);
begin scalar q1,q2,q;
q1:=dip2a diprectoint(p1,diplcm p1);
q2:=dip2a diprectoint(p2,diplcm p2);
q:=a2dip prepsq simpresultant list(q1,q2,x);
return q;
end;


expr procedure sqpol p1;
begin scalar q1,q;
q1:=dip2a diprectoint(p1,diplcm p1);
q:=a2dip caar sqfrf q1;
return q;
end;


expr procedure   dipnorfor (pl,p);
%  /* Distributive polynom normalform. pl is a list of distributive
%    polynomials, p is a distributive polynomial. dipnorfor(pl,p)
%    calculates a distributive polynomial such that the powerproduct
%    of the distributive
%    polynomial p is reducible to this modulo the distributive
%    polynomial list pl and is in normalform with respect to the
%    distributive polynomial p and returns a distributive polynomial. */
     if dipzero!? p or null pl then p
        else ( if dipzero!? q then p
             else (
                if dipzero!? rq then  dipnorfor(pl,dipmred p)
                      else dipnorfor(pl,
                              dipdif(dipmred p,
                                 dipprod(rq,
                                    dipfmon(bcquot(diplbc p,
                                                   diplbc q),
                                            evdif(ep,
                                                  dipevlmon q) ) ) ) )
             ) where rq = dipmred q
             ) where q = dipnorformsel(ep, pl)
                  where ep = dipevlmon p;


expr procedure dipmingbase pl;
% Distributive polynomial minimal ordered Groebner base. pl is a
% list of distributive polynomials. dipmingbase(pl) calculates
% the minimal normed and ordered Groebner base of the distributive
% polyomials pl and returns a list of distributive polyomials.
  if null cdr pl then pl
            else dipmingbasein2(nil,dipmingbasein1(nil,pl) );



expr procedure   dipgbasein ql;
%  /* Distributive polynomial Groebner base. pl is a list of distributiv
%    polynomials. dipgbase(pl) calculates the Groebner base of the list
%    of distributive polynomials pl and returns a list of distributive
%    polynomials. */
begin scalar ql0,u,ql1,w,d,ql22,lql1,ql11,lv,h1h0,d1,d0,p1,
    sp0,n,dl,p2,ct1,sp,h,ct11,h1,h10,hs1,h1h1,h0,hs2;
       u := 1; w := 1; n := 1; ql0 := nil;
       ql1:= dipindexpol(ql,1);
       d:= dipcplistsort dipcpairlistopt dipcplist dipindexpolspec ql1;
           ql22 := ql;
           lql1:= length ql1;  ql11:=dipindexpolopt(nil, ql1);
           d:=dipcpairlistop(ql11,d);
       if !*hopt then << lv:=length dipvars!*; h1h0:=nil>>;
           d1:=list list(lql1,ql1,ql11,ql22,d);
        if !*trgroeb1 then <<
           prin2 " list d1 =   ";
           prin2 d1; terpri();
           prin2 length d1; terpri() >>;
           while not null d1 do <<
              d0:= car d1; d1:= cdr d1; lql1:= car d0;
              ql1:= cadr d0; ql11:= caddr d0;
              ql22:= cadddr d0; d:= cadddr cdr d0;
           while not null d do   <<
                     dl:= car d;
                     d := cdr d;
                     p1:= caddr dl;
                     p2:= cadddr dl;
                       if !*trgroeb then << ct1 := time() >>;
                       sp := dipspolynom(p1,p2);
                                  if !*trgroebs then <<
                                     prin2t "S-polynom:";
                                     dipprint sp; terpri() >>;
          if !*trgroeb0 then << sp0:= dip2a diprectoint(sp,diplcm sp);
                         sp0:= factorf !*q2f simp sp0;
                         dfcprin sp0; terprit 2 >>;
                   h := dipnorform(ql22, sp);
                       if !*trgroeb then << ct11 := time() - ct1 >>;
                       if dipzero!? h then <<
      if !*trgroeb then <<  terprit 2; printb 57; terpri();
                       prin2 " / reduction of polynom "; prin2 caar dl;
                       prin2 " and "; prin2 cadar dl;
                       prin2 " leads to 0  "; prin2 " ( ";
                       prin2 ct11; prin2 "  ms )";
                       terpri(); printb 57; terprit 2 >> >>;
                       if not dipzero!? h then
                           if dipconst!? h
                             then  <<
                                  ql11:= list list(lql1,dipmonic h);
                                                          d:=nil >>
                     else  << h1 := dipmonic h; lql1:= lql1 + 1;
                                  if !*trgroeb then <<
                                     prin2 "h-polynom ";
                                     prin2 lql1; prin2 "     pair";
                       prin2 " ( "; prin2 caar dl;
                       prin2 ","; prin2 cadar dl; prin2t " ) :";
                                     dipprint h1; terpri();
                       prin2 " computing time for h-polynom ";
                       prin2 ct11;
                            terprit 3 >>;
     % The following option has been suppressed since it is not
     % complete.
     if nil and !*groebfac and u = 1 then << h10:= h1;
                          h1:= dip2a diprectoint(h1,diplcm h1);
                          h1:= factorf !*q2f simp h1;
                             hs1:= reverse diplsort makdiplist cdr h1;
                                  if !*trgroeb then <<
                                     prin2 "h-polynom factorized:  ";
                                     terpri();
                                     dfcprin h1; terpri()  >>;
                         h1:= dipmonic car hs1; hs1:= reverse cdr hs1;
                         if  not dipzero!? (dipdif(h1,h10)) then
                         << u:= 0 >>;
                        if !*trgroeb  then <<   prin2 " new h-polynom ";
                          terprit 3;  dipprint h1; terprit 2 >> >>;
   if !*hopt and w = 1 then <<
                     h1h1:= indexcpl(evsum0(lv,h1),1);
   if !*trgroeb then <<  prin2 " index: "; prin2 h1h1; terpri();
                       prin2 " index: "; prin2 h1h0; terprit 3 >>;
                     if  h1h1 = h1h0
                     and rescheck!?(2,h1h0,lv)
                       then <<
                    hs2:= reverse diplsort
                          newhpo(h1,h0,cadr reverse dipvars!*); w:= 0>>;
                     if  h1h1 = h1h0
                     and rescheck1!?(2,h1h0,lv)
                       then <<
                hs2:= reverse diplsort
                      newhpo(h1,h0,caddr reverse dipvars!*); w:= 0  >>;
       if null hs2 then << w:= 1 >>
                     >>;
   if u = 0 and not null hs1 then <<
                     d0:= maklistd1(hs1,lql1,ql1,ql11,ql22,d);
                     u:= 2; d1:=nconc(d0,d1)  >>;
%%%%%%%              u:= 1; d1:=nconc(d0,d1)  >>;
                     d:= dipcpairlistopt1(h1,d,d);
   if !*trgroeb then  << terpri(); prin2 "Restpairs: ";
                       prin2t length d; terpri() >>;
                  d:=  dipcplistmerge(dipcplistsort
   dipcpairlistopt dipcplistopt2(nil,dipcplistadd(lql1,h1,ql11)),d);
if !*hopt and w = 1 then << h1h0:=indexcpl(evsum0(lv,h1),1); h0:= h1 >>;
                   ql11:= nconc(list list(lql1,h1),ql11);
                   ql22:= nconc(list(h1),ql22);
                   ql11:= dipindexpolopt(nil,ql11);
if !*trgroeb1 then <<  prin2 " *** d =   "; prin2 d; terpri();
                     prin2t " ql11   "; prin2 ql11; terpri() >>;
 if w = 0 then << h1:= dipmonic car hs2; hs2:= reverse cdr hs2;
           lql1:= lql1 + 1; if not null hs2 then <<
           d0:= maklistd1(hs2,lql1,ql1,ql11,ql22,d);
           w:= 2; d1:= nconc(d0,d1)     >>;
                     d:= dipcpairlistopt1(h1,d,d);
                     d:=  dipcplistmerge(dipcplistsort
   dipcpairlistopt dipcplistopt2(nil,dipcplistadd(lql1,h1,ql11)),d);
                   ql11:= nconc(list list(lql1,h1),ql11);
                   ql22:= nconc(list(h1),ql22);
                      ql11:= dipindexpolopt(nil,ql11);
if !*trgroeb1 then <<  prin2 " *** d =   "; prin2 d; terpri();
                     prin2t " ql11   "; prin2 ql11; terpri() >>
             >>    >> >>;
           ql11:=dipindexpolrec ql11;
           if !*trgroeb then <<
           prin2t " calculation now in final reduction ";
           terpri(); ct1 := time() >>;
           ql:=dipmingbase diplsort ql11;
           if !*trgroeb then << ct11 := time() - ct1;
              prin2 " computing time for final calculation ";
              prin2 ct11;
              prin2 "    milliseconds "; terprit 3;
           prin2 " Number of Groebner Basis Polynomials :=   ";
           prin2t length ql; terprit 2;
           if n = 1 and null d1 then <<
           prin2t " The Groebner Basis Polynomials "; terpri() >>
           else
           << prin2 " The Groebner Basis Polynomials  ( Factor ";
           prin2 n; prin2t "  )"; terpri(); n:= n + 1 >>;
           gbprint ql;
           if not null d1 then <<
           prin2 " Calculation for Factor  "; prin2t n; terprit 4 >>
                       >>;  ql0:= ql . ql0     >>;
           return ql0
           end;


expr procedure makdiplist pl;
% Make list of distributive polynomials from list of polynomials pl.
  for each p in pl collect a2dip prepf car p;


expr procedure terprit n;
% print blank lines.
   for i:=1:n do << terpri() >>;


expr procedure printb n;
% print special sign ( - ).
   for i:=1:n do << prin2 "-" >>;


expr procedure newhpo(h1,h0,x);
% new h-polynom calculation. newhpo(h1,h2,x) calculates
% the resultant of the two distributive polynomials h1 and h0
% with respect to x.
begin scalar ct00,hh,hh1,hs2;
   if !*trgroeb then << ct00:= time() >>;
              hh:= dipmonic newhpol(h1,h0,x);
   if !*trgroeb  then <<   prin2 " resultant "; terprit 2;
                     dipprint hh; terprit 4 >>; hs2:= nil;
   if not dipzero!? hh then << hh1:= dip2a diprectoint(hh,diplcm hh);
                          hh1:= factorf !*q2f simp hh1;
   if !*trgroeb then << prin2 " resultant factorized:  "; terprit 2;
                      dfcprin hh1; terprit 2;
                      ct00:= time() - ct00;
                     prin2 " special time for h:    "; prin2 ct00;
                     terpri() >>;
                     hs2:= makdiplist cdr hh1 >>;
  return hs2
  end;


expr procedure maklistd1(x1,x2,x3,x4,x5,x6);
% make list d1. save part time problems.
  begin scalar x,h1;
   while x1 do  << h1:= car x1; x1:= cdr x1;
           x:= list(x2,x3,
               (dipindexpolopt(nil,nconc(list list(x2,h1),x4))),
               (nconc(list h1,x5)),
               (dipcplistmerge(dipcplistsort
         dipcpairlistopt dipcplistopt2(nil,dipcplistadd(x2,h1,x4)),
               dipcpairlistopt1(h1,x6,x6)))) . x >>;
   return x
   end;


expr procedure   dipmingbasein1 (pl1,pl2);
%  /* Distributive polynomial minimal ordered Groebner base internal1.
%    pl1 and pl2 are lists of distributive polynomials.
%    dipmingbasein1(pl1,pl2) is used in dipmingbase and returns a list
%    of  distributive polynomials. */
     if null pl2 then pl1
        else ( if dipzero!? dipnorformsel(ep, pl1)
                  and dipzero!? dipnorformsel(ep,cpl2)
                      then dipmingbasein1( cons(p, pl1), cpl2)
                           else dipmingbasein1( pl1, cpl2)
             ) where  ep = dipevlmon p,
                      cpl2 = cdr pl2
              where  p = car pl2;


expr procedure   dipmingbasein2 (pl1,pl2);
%  /* Distributive polynomial minimal ordered Groebner base internal2.
%    pl1 and pl2 are lists of distributive polynomials.
%    dipmingbasein2(pl1,pl2) is used in dipmingbase and returns a list
%    of  distributive polynomials. */
     if null pl2 then pl1
        else ( dipmingbasein2(dipnorform(pl1,dipnorform(rp, p)) . pl1,
                             rp) )
               where p  = car pl2,
                     rp = cdr pl2;



expr procedure   dipnorform (pl,p);
%  /* Distributive polynom normalform. pl is a list of distributive
%    polynomials, p is a distributive polynomial. dipnorform(pl,p)
%    calculates a distributive polynomial such that the distributive
%    polynomial p is reducible to this modulo the distributive
%    polynomial list pl and is in normalform with respect to the
%    distributive polynomial p and returns a distributive polynomial. */
     if dipzero!? p or null pl then p
        else ( if dipzero!? q then dipmoncomp(diplbc p,
                                             ep,
                                             dipnorform(pl,
                                                        dipmred p) )
               else ( if dipzero!? rq then dipnorform(pl, dipmred p)
                      else dipnorform(pl,
                              dipdif(dipmred p,
                                 dipprod(rq,
                                    dipfmon(bcquot(diplbc p,
                                                   diplbc q),
                                            evdif(ep,
                                                  dipevlmon q) ) ) ) )
                    ) where rq = dipmred q
             ) where q = dipnorformsel(ep, pl)
                  where ep = dipevlmon p;

expr procedure   dipnorformsel (ep,pl);
%  /* Distributive polynom normalform select. ep is an exponent vector
%    of a distributive polynomial. pl is a list of distributive
%    polynomials. dipnorformsel(ep,pl) returns a distributive
%    polynomial of pl where ep is a multiple of the leading
%    exponent vector else dipzero. */
     if null pl then dipzero
        else ( if evmtest!?(ep, dipevlmon q) then q
                  else dipnorformsel(ep, cdr pl)
             ) where q = car pl;


expr procedure   dipspolynom (p1,p2);
% /* Distributive polynom S polynom. p1 and p2 are distributive
%   polynomials. dipspolynom(p1,p2) calculates the S polynom of the
%   distributive polynomials p1 and p2 and returns a distributive
%   polynomial. */
    if dipzero!? p1 or dipzero!? p2 then dipzero
       else ( if dipzero!? rp1 and dipzero!? rp2 then rp1
              else ( if dipzero!? rp1 then
                        dipprod(rp2,
                                dipfmon(bcneg diplbc p1,
                                       evdif(ep, ep2) ) )
                     else if dipzero!? rp2 then
                             dipprod(rp1,
                                     dipfmon(diplbc p2,
                                            evdif(ep, ep1) ) )
                          else dipdif(
                                      dipprod(rp2,
                                              dipfmon(diplbc p1,
                                                     evdif(ep, ep2) ) ),
                                      dipprod(rp1,
                                              dipfmon(diplbc p2,
                                                     evdif(ep, ep1) ) )
                                     )
                   ) where ep = evlcm(ep1, ep2)
                        where ep1 = dipevlmon p1,
                              ep2 = dipevlmon p2
            ) where rp1 = dipmred p1,
                    rp2 = dipmred p2;



expr procedure delqip1(u,v);
   if pairp cdr v
     then if u eq cadr v then rplacd(v,cddr v) else delqip1(u,cdr v);


expr procedure delqip(u,v);
%  /*Destructive delete of first occurrence of u in v*/
   if not pairp v then v
    else if u eq car v then cdr v
    else <<delqip1(u,v); v>>;


endmodule;


module dipopt;

%  /* Authors: R. Gebauer, A. C. Hearn, H. Kredel */

fluid '(!*trbas dipvars!*);

%define ezero = 'nil;

fluid '(dipzero ezero);
     %/*Until we understand how to define something to nil*/

expr procedure dipoptmat1 (el,dpl);
%  /* Distributive optimisation matrix subfunction 1. el is an
%    exponent vector, dpl is a degree matix. dipoptmat1(el,dpl)
%    returns the addition of el to dpl. */
     if null el then dpl
        else dipsum ( dipfmon (bcfi 1,
                               evcons(evfirst el, ezero)), car dpl)
             . dipoptmat1(evred el, cdr dpl);


expr procedure dipoptmat2 (p,pl);
%  /* Distributive optimisation matrix subfunction 2. p is a
%    distributive polynomial, pl is a list of distributive
%    polynomials. dipoptmat1 is used. */
     if dipzero!? p then pl
        else dipoptmat2(dipmred p, dipoptmat1(dipevlmon p, pl));


expr procedure dipoptmat3 (p,pl);
%  /* Distributive optimisation matrix subfunction 3. p is a
%    distributive polynomial, pl is a list of distributive
%    polynomials. dipoptmat2 is used. */
     if null p then pl
        else dipoptmat3(cdr p, dipoptmat2(car p, pl));


expr procedure dipoptmat pl;
%  /* Distributive optimisation matrix. pl is a list of distributive
%    polynomials. dipoptmat(pl) returns the optimisation matrix
%    ( a degree matrix ) of pl, a list of univariate distributive
%    polynomials. */
     if null pl then nil
        else dipoptmat3(pl, for each x in dipvars!* collect dipzero);


expr procedure dipless!? (p1,p2);
%  /* Distributive polynomial less. p1 and p2 are distributive
%    polynomials. dipless!?(p1,p2) returns a boolean expression,
%    true if p1 is less than p2 else false. */
     if dipzero!? p1 and dipzero!? p2 then nil
        else if not dipzero!? p1 then
                if not dipzero!? p2 then
                 ( if sl < 0 then t
                      else if sl > 0 then nil
                      else ( if bl < 0 then t
                              else if bl > 0 then nil
                              else dipless!?(dipmred p1, dipmred p2)
                           )  where bl = bccomp(diplbc p1, diplbc p2)
                 ) where sl = evcomp(dipevlmon p1, dipevlmon p2)
                else t
             else nil;


expr procedure pvdema pl;
%  /* Permutation vector degree matrix. pl is a list of univariate
%    polynomials in distributive representation. pvdema(pl) returns
%    a list ( indexlist ) where the elements are digits.*/
     pvdema2 sort(pvdema1(pl, 1), 'pvdema3);


expr procedure pvdema1(pl,n);
%  /* Permutation vector degree matrix subfunction 1. pl is a list
%    of univariate distributive polynomials, n is a digit.
%    pvdema1 changes the internal structure ( add index for each
%    polynomial ) and is used in pvdema. */
     if null pl then pl
        else list(car pl, n) . pvdema1(cdr pl, n + 1);


expr procedure pvdema2(pl);
%  /* Permutation vector degree matrix subfunction 2. pl is a list of
%    univariate distributive polynomials. pvdema2(pl) changes the
%    internal structure ( delete index for each polynomial ) and
%    is used in pvdema. */
     if null pl then pl
        else nconc(cdar pl, pvdema2(cdr pl));


expr procedure pvdema3 (p1,p2);
%  /* Permutation vector degree matrix subfunction 3. p1 and p2 are
%    distributive univariate polynomials. pvdema3(p1,p2) returns
%    a boolean expression, true if the distributive polynomial p1
%    is less than the distributive polynomial p2 else false. */
     dipless!?(car p1, car p2);


expr procedure listperm (v,n);
%  /* List permutation. v is a list ( any kind ) and n is an indexlist.
%    listperm(v,n) permutates v in respect to n and returns a
%    permutated list v. */
     if null n then nil
        else nth(v, car n) . listperm(v, cdr n);


expr procedure dipreorder (p,n);
%  /* Distributive polynomial reorder. p is a distributive polynomial,
%    n is an indexlist. dipreorder(p,n) reorders the exponent vectors
%    of each term of p in respect to the indexlist n and returns a
%    distributive polynomial. */
     if dipzero!? p then nil
        else dipsum(dipfmon(diplbc p, evperm(dipevlmon p, n)),
                    dipreorder(dipmred p, n));


expr procedure diplreorder (pl,n);
%  /* Distributive polynomial list reorder. pl is a list of distributive
%    polynomials and n is an indexlist. diplreorder(pl,n) reorders the
%    exponent vectors of each term of each polynomial in the list pl in
%    respect to the indexlist n and returns a list of distributive
%    polynomials.*/
     for each x in pl collect dipreorder(x, n);


expr procedure dipvordopt pl;
%  /* Distributive polynomial variable ordering optimisation.
%    pl is a list of distributive polynomials. dipvordopt(pl)
%    calculates the " optimal representation " and returns a list
%    of distributive polynomials.
%    NOTE: dipvordopt can change the global variable list dipvars!* */
     begin scalar n,olddipvars,pl1;
        n := pvdema diopmatin pl;
        if !*trbas then <<  prin2t " The new index list :";
         terprit 2; prin2t n; terprit 2  >>;
         olddipvars := dipvars!*;
         dipvars!* := listperm(dipvars!*, n);
        if !*trbas then <<  prin2t " The new variable list :";
         terprit 2; prin2t dipvars!*; terprit 2 >>;
         pl1 := diplreorder(pl, n);
        if !*trbas then <<  prin2t " The new polynomial list :";
         terprit 2; diplprint pl1; terprit 2 >>;
%       dipvars!* := olddipvars;
        return pl1
     end;


expr procedure diopmatin pl;
% print univariate polynomials.
   begin scalar n1;
        << if !*trbas then << prin2t " The variable list :";
           terprit 2; prin2t dipvars!*; terprit 2;
           prin2t " The univariate polynomials in each variable :";
           terprit 2 >>; n1:=dipoptmat pl;
           if !*trbas then << dioprin(n1,dipvars!*) >> >>;
     return n1
     end;


expr procedure dioprin(pl,d);
% print variables.
     begin scalar dipvars!*;
       for each x in pair(pl,d)
                  do << dipvars!* := list cdr x; dipprint car x >>
     end;


endmodule;


end;

Added r33/hephys.red version [f907b260f5].

































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
module hephys;   % Support for high energy physics calculations.

% Author: Anthony C. Hearn.

% Generalizations for n dimensional vector and gamma algebra by
% Gastmans, Van Proeyen and Verbaeten, University of Leuven, Belgium.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

fluid '(!*sub2 ndims!*);

global '(defindices!* indices!* mul!* ncmp!* ndim!*);

defindices!* := nil; % Deferred indices in N dim calculations.

indices!* := nil; % List of indices in High Energy Physics
                  % tensor expressions.
ndim!* := 4;      % Number of dimensions in gamma algebra.

% *********************** SOME DECLARATIONS *************************

deflist ('((cons simpdot)),'simpfn);

put('vector,'stat,'rlis);

% put('vector,'formfn,'formvector);

%symbolic procedure formvector(u,vars,mode);
%   if mode eq 'algebraic
%     then list('vector1,'list . formlis(cdr u,vars,'algebraic))
%    else u;

symbolic procedure vector u; vector1 u;

symbolic procedure vector1 u;
   for each x in u do
      begin scalar y;
         if not idp x or (y := getrtype x) and y neq 'vector
           then typerr(list(y,x),"high energy vector")
          else put(x,'rtype,'vector)
      end;

put('vector,'fn,'vecfn);

put('vector,'evfn,'veval);

put('g,'simpfn,'simpgamma);

flagop nospur;

flag ('(g),'noncom);

symbolic procedure index u;
   begin vector1 u; rmsubs(); indices!* := union(indices!*,u) end;

symbolic procedure remind u;
   begin indices!* := setdiff(indices!*,u) end;

symbolic procedure mass u;
   if null car u then rederr "No arguments to MASS"
    else <<for each x in u do put(cadr x,'rtype,'vector);
           for each x in u do put(cadr x,'mass,caddr x)>>;

symbolic procedure getmas u;
   (lambda x; if x then x else rederr list(u,"has no mass"))
      get!*(u,'mass);

symbolic procedure vecdim u;
   begin ndim!* := car u end;

symbolic procedure mshell u;
   begin scalar x,z;
    a:  if null u then return let0 z;
        x := getmas car u;
        z := list('equal,list('cons,car u,car u),list('expt,x,2)) . z;
        u := cdr u;
        go to a
   end;

rlistat '(vecdim index mass mshell remind vector);


% ******** FUNCTIONS FOR SIMPLIFYING HIGH ENERGY EXPRESSIONS *********

symbolic procedure veval(u,v);
   begin scalar z;
        u := nssimp(u,'vector);
    a:  if null u then return replus z
         else if null cdar u then rederr "Missing vector"
         else if cddar u
          then msgpri("Redundant vector in",cdar u,nil,nil,t);
        z := aconc!*(z,retimes(prepsq caar u . cdar u));
        u := cdr u;
        go to a
   end;

symbolic procedure vmult u;
   begin scalar z;
        z := list list(1 . 1);
    a:  if null u then return z;
        z := vmult1(nssimp(car u,'vector),z);
        if null z then return;
        u := cdr u;
        go to a
   end;

symbolic procedure vmult1(u,v);
   begin scalar z;
        if null v then return;
    a:  if null u then return z
         else if cddar u
          then msgpri("Redundant vector in",cdar u,nil,nil,t);
        z := nconc!*(z,mapcar(v,function (lambda j;
              multsq(car j,caar u) . append(cdr j,cdar u))));
        u := cdr u;
        go to a
   end;

symbolic procedure simpdot u;
   mkvarg(u,function dotord);

symbolic procedure dotord u;
   <<if xnp(u,indices!*) and not ('isimpq memq mul!*)
           then mul!* := aconc!*(mul!*,'isimpq) else nil;
        if 'a memq u
          then rederr "A represents only gamma5 in vector expressions"
         else mksq('cons . ord2(car u,carx(cdr u,'dot)),1)>>;

symbolic procedure mkvarg(u,v);
   begin scalar z;
        u := vmult u;
        z := nil ./ 1;
    a:  if null u then return z;
        z := addsq(multsq(apply1(v,cdar u),caar u),z);
        u := cdr u;
        go to a
   end;

symbolic procedure spur u;
   <<rmsubs();
         map(u,function (lambda j;
                   <<remflag(list car j,'nospur);
                         remflag(list car j,'reduce)>>))>>;

rlistat '(spur);

symbolic procedure simpgamma u;
   if null u or null cdr u
       then rederr "Missing arguments for G operator"
    else begin scalar z;
        if not ('isimpq memq mul!*) then mul!*:= aconc!*(mul!*,'isimpq);
        ncmp!* := t;
        z := nil ./ 1;
        for each j in vmult cdr u do
           z := addsq(multsq(!*k2q('g . car u . cdr j),car j),z);
        return z
   end;

symbolic procedure simpeps u;
   mkvarg(u,function epsord);

symbolic procedure epsord u;
   if repeats u then nil ./ 1 else mkepsq u;

symbolic procedure mkepsk u;
   % U is of the form (v1 v2 v3 v4).
   % Value is <sign flag> . <kernel for EPS(v1,v2,v3,v4)>.
   begin scalar x;
        if xnp(u,indices!*) and not 'isimpq memq mul!*
          then mul!* := aconc!*(mul!*,'isimpq);
        x := ordn u;
        u := permp(x,u);
        return u . ('eps . x)
   end;

symbolic procedure mkepsq u;
   (lambda x; (lambda y; if null car x then negsq y else y)
                 mksq(cdr x,1))
        mkepsk u;


% ** FUNCTIONS FOR SIMPLIFYING VECTOR AND GAMMA MATRIX EXPRESSIONS **

symbolic smacro procedure mkg(u,l);
   % Value is the standard form for G(L,U).
   !*p2f('g . l . u to 1);

symbolic smacro procedure mka l;
   % Value is the standard form for G(L,A).
   !*p2f(list('g,l,'a) to 1);

symbolic smacro procedure mkgamf(u,l);
   mksf('g . (l . u));

symbolic procedure mkg1(u,l);
   if not flagp(l,'nospur) then mkg(u,l) else mkgamf(u,l);

symbolic smacro procedure mkpf(u,v);
   multpf(u,v);

symbolic procedure mkf(u,v);
   multf(u,v);

symbolic procedure multd!*(u,v);
   if u=1 then v else multd(u,v);     % onep

symbolic smacro procedure addfs(u,v);
   addf(u,v);

symbolic smacro procedure multfs(u,v);
   % U and V are pseudo standard forms.
   % Value is pseudo standard form for U*V.
   multf(u,v);

symbolic procedure isimpq u;
   begin scalar ndims!*;
      ndims!* := simp ndim!*;
      if denr ndims!* neq 1
        then <<!*sub2 := t;
               ndims!* := multpf(mksp(list('recip,denr ndims!*),1),
                                 numr ndims!*)>>
       else ndims!* := numr ndims!*;
   a: u := isimp1(numr u,indices!*,nil,nil,nil) ./ denr u;
      if defindices!*
        then <<indices!* := union(defindices!*,indices!*);
               defindices!* := nil;
               go to a>>
       else if null !*sub2 then return u
       else return resimp u
   end;

symbolic procedure isimp1(u,i,v,w,x);
   if null u then nil
    else if domainp u
       then if x then multd(u,spur0(car x,i,v,w,cdr x))
             else if v then rederr("Unmatched index" . i)
             else if w then multfs(emult w,isimp1(u,i,v,nil,x))
             else u
    else addfs(isimp2(car u,i,v,w,x),isimp1(cdr u,i,v,w,x));

symbolic procedure isimp2(u,i,v,w,x);
   begin scalar z;
        if atom (z := caar u) then go to a
         else if car z eq 'cons and xnp(cdr z,i)
            then return dotsum(u,i,v,w,x)
         else if car z eq 'g
          then go to b
         else if car z eq 'eps then return esum(u,i,v,w,x);
    a:  return mkpf(car u,isimp1(cdr u,i,v,w,x));
    b:  z := gadd(appn(cddr z,cdar u),x,cadr z);
        return isimp1(multd!*(nb car z,cdr u),i,v,w,cdr z)
   end;

symbolic procedure nb u;
   if u then 1 else -1;

symbolic smacro procedure mkdot(u,v);
   % Returns a standard form for U . V.
   mksf('cons . ord2(u,v));

symbolic procedure dotsum(u,i,v,w,x);
   begin scalar i1,n,u1,u2,v1,y,z,z1;
        n := cdar u;
        if not (car (u1 := cdaar u) member i) then u1 := reverse u1;
        u2 := cadr u1;
        u1 := car u1;
        v1 := cdr u;
        if n=2 then go to h
         else if n neq 1 then typerr(n,"index power");
    a:  if u1 member i then go to a1
         else if null (z := mkdot(u1,u2)) then return nil
         else return mkf(z,isimp1(v1,i1,v,w,x));
    a1: i1 := delete(u1,i);
        if u1 eq u2 then return multf(ndims!*,isimp1(v1,i1,v,w,x))
         else if not (z := bassoc(u1,v)) then go to c
         else if u2 member i then go to d;
        if u1 eq car z then u1 := cdr z else u1 := car z;
        go to e;
    c:  if z := memlis(u1,x)
            then return isimp1(v1,
                              i1,
                              v,
                              w,
                              subst(u2,u1,z) . delete(z,x))
         else if z := memlis(u1,w)
            then return esum((('eps . subst(u2,u1,z)) . 1) . v1,
                             i1,
                             v,
                             delete(z,w),
                             x)
         else if u2 member i and null y then go to g;
        return isimp1(v1,i,(u1 . u2) . v,w,x);
    d:  z1 := u1;
        u1 := u2;
        if  z1 eq car z then u2 := cdr z else u2 := car z;
    e:  i := i1;
        v := delete(z,v);
        go to a;
    g:  y := t;
        z := u1;
        u1 := u2;
        u2 := z;
        go to a1;
    h:  if u1 eq u2 then rederr "2 invalid as repeated index power";
        i := i1 := delete(u1,i);
        u1 := u2;
        go to a
   end;

symbolic procedure mksf u;
   % U is a kernel.
   % Value is a (possibly substituted) standard form for U.
   begin scalar x;
        x := mksq(u,1);
        if cdr x=1 then return car x;
        !*sub2 := t;
        return !*p2f(u to 1)
   end;


% ********* FUNCTIONS FOR SIMPLIFYING DIRAC GAMMA MATRICES **********

symbolic procedure gadd(u,v,l);
   begin scalar w,x; integer n;
        n := 0;                 % Number of gamma5 interchanges.
        if not (x := atsoc(l,v)) then go to a;
        v := delete(x,v);
        w := cddr x;            % List being built.
        x := cadr x;            % True if gamma5 remains.
    a:  if null u then return (evenp n . (l . x . w) . v)
         else if car u eq 'a then go to c
         else w := car u . w;
    b:  u := cdr u;
        go to a;
    c: if ndims!* neq 4
         then rederr "Gamma5 not allowed unless vecdim is 4";
       x := not x;
        n := length w + n;
        go to b
   end;


% ***** FUNCTIONS FOR COMPUTING TRACES OF DIRAC GAMMA MATRICES *******

symbolic procedure spur0(u,i,v1,v2,v3); 
   begin scalar l,w,i1,kahp,n,z; 
      l := car u; 
      n := 1; 
      z := cadr u; 
      u := reverse cddr u; 
      if z then u := 'a . u; % Gamma5 remains.
      if null u then go to end1
       else if null flagp(l,'nospur)
        then if car u eq 'a and (length u<5 or hevenp u)
                  or not car u eq 'a and not hevenp u
               then return nil
              else if null i then <<w := reverse u; go to end1>>; 
    a: 
      if null u then go to end1
       else if car u member i
        then if car u member cdr u
               then <<if car u eq cadr u
                        then <<i := delete(car u,i); 
                               u := cddr u; 
                               n := multf(n,ndims!*); 
                               go to a>>; 
                      kahp := t; 
                      i1 := car u . i1; 
                      go to a1>>
              else if car u member i1 then go to a1
              else if z := bassoc(car u,v1)
               then <<v1 := delete(z,v1); 
                      i := delete(car w,i); 
                      u := other(car u,z) . cdr u; 
                      go to a>>
              else if z := memlis(car u,v2)
               then return if flagp(l,'nospur)
                                and null v1
                                and null v3
                                and null cdr v2
                             then mkf(mkgamf(append(reverse w,u),l),
                                      multfs(n,mkepsf z))
                            else multd!*(n,
                                         isimp1(spur0(
           l . (nil . append(reverse u,w)),nil,nil,delete(z,v2),v3),
                                                i,v1,list z,nil))
              else if z := memlis(car u,v3)
               then if ndims!*=4
                      then return spur0i(u,delete(car u,i),v1,v2,
                                         delete(z,v3),l,n,w,z)
                     else <<indices!* := delete(car u,indices!*); 
                            i := delete(car u,i); 
                            if not car u memq defindices!*
                              then defindices!* := 
                                    car u . defindices!*; 
                            go to a1>>
              else rederr list("Unmatched index",car u);
    a1: 
      w := car u . w; 
      u := cdr u; 
      go to a; 
    end1: 
      if kahp
        then if ndims!*=4
               then <<z := multfs(n,kahane(reverse w,i1,l)); 
                      return isimp1(z,setdiff(i,i1),v1,v2,v3)>>
              else z := spurdim(w,i,l,nil,1)
       else z := spurr(w,l,nil,1); 
      return if null z then nil
              else if get('eps,'klist) and not flagp(l,'nospur)
               then isimp1(multfs(n,z),i,v1,v2,v3)
              else multfs(z,isimp1(n,i,v1,v2,v3))
   end;

symbolic procedure spur0i(u,i,v1,v2,v3,l,n,w,z); 
   begin scalar kahp,i1; 
      if flagp(l,'nospur) and flagp(car z,'nospur)
        then rederr "NOSPUR on more than one line not implemented"
       else if flagp(car z,'nospur) then kahp := car z; 
      z := cdr z; 
      i1 := car z; 
      z := reverse cdr z; 
      if i1 then z := 'a . z; 
      i1 := nil; 
      <<while null (car u eq car z) do 
           <<i1 := car z . i1; z := cdr z>>; 
        z := cdr z; 
        u := cdr u; 
        if flagp(l,'nospur)
          then <<w := w . (u . (i1 . z)); 
                 i1 := car w; 
                 z := cadr w; 
                 u := caddr w; 
                 w := cdddr w>>; 
        w := reverse w; 
        if null ((null u or not eqcar(w,'a)) and (u := append(u,w)))
          then <<if not hevenp u then n :=  - n; 
                 u := 'a . append(u,cdr w)>>; 
        if kahp then l := kahp; 
        z := 
         mkf(mkg(reverse i1,l),
             multf(brace(u,l,i),multfs(n,mkg1(z,l)))); 
        z := isimp1(z,i,v1,v2,v3); 
        if null z or (z := quotf(z,2)) then return z
         else errach list('spur0,n,i,v1,v2,v3)>>
   end;

symbolic procedure spurdim(u,i,l,v,n);
   begin scalar w,x,y,z,z1; integer m;
    a:  if null u
          then return if null v then n
                else if flagp(l,'nospur) then multfs(n,mkgamf(v,l))
                else multfs(n,sprgen v)
         else if not(car u memq cdr u)
          then <<v := car u . v; u := cdr u; go to a>>;
        x := car u;
        y := cdr u;
        w := y;
        m := 1;
    b:  if x memq i then go to d
         else if not x eq car w then go to c
         else if null(w := mkdot(x,x)) then return z;
        if x memq i then w := ndims!*;
        return addfs(mkf(w,spurdim(delete(x,y),i,l,v,n)),z);
    c:  z1 := mkdot(x,car w);
        if car w memq i
          then z := addfs(spurdim(subst(x,car w,remove(y,m)),
                                  i,l,v,2*n),z)
         else if z1
          then z := addfs(mkf(z1,spurdim(remove(y,m),i,l,v,2*n)),z);
        w := cdr w;
        n := -n;
        m := m+1;
        go to b;
   d:   while not(x eq car w) do
         <<z:= addfs(spurdim(subst(car w,x,remove(y,m)),i,l,v,2*n),z);
           w := cdr w;
           n := -n;
           m := m+1>>;
        return addfs(mkf(ndims!*,spurdim(delete(x,y),i,l,v,n)),z)
   end;

symbolic procedure appn(u,n);
   if n=1 then u else append(u,appn(u,n-1));

symbolic procedure other(u,v);
   if u eq car v then cdr v else car v;

symbolic procedure kahane(u,i,l);
   % The Kahane algorithm for Dirac matrix string reduction.
   % Ref: Kahane, J., Journ. Math. Phys. 9 (1968) 1732-1738.
   begin scalar p,r,v,w,x,y,z; integer k,m;
        k := 0;
    mark:
        if eqcar(u,'a) then go to a1;
    a:  p := not p;             % Vector parity.
        if null u then go to d else if car u member i then go to c;
    a1: w := aconc!*(w,car u);
    b:  u := cdr u;
        go to a;
    c:  y := car u . p;
        z := (x . (y . w)) . z;
        x := y;
        w := nil;
        k := k+1;
        go to b;
    d:  z := (nil . (x . w)) . z;
        % Beware ... end of string has opposite convention.
    pass2:
        m := 1;
    l1: if null z then go to l9;
        u := caar z;
        x := cadar z;
        w := cddar z;
        z := cdr z;
        m := m+1;
        if null u then go to l2
         else if (car u eq car x) and exc(x,cdr u) then go to l7;
        w := reverse w;
        r := t;
    l2: p := not exc(x,r);
        x := car x;
        y := nil;
    l3: if null z
          then rederr("Unmatched index" .
                 if y then if not atom cadar y then cadar y
                            else if not atom caar y then caar y
                  else nil
                else nil)
          else if (x eq car (i := cadar z)) and not exc(i,p)
           then go to l5
          else if (x eq car (i := caar z)) and exc(i,p) then go to l4;
        y := car z . y;
        z := cdr z;
        go to l3;
    l4: x := cadar z;
        w := appr(cddar z,w);
        r := t;
        go to l6;
    l5: x := caar z;
        w := append(cddar z,w);
        r := nil;
    l6: z := appr(y,cdr z);
        if null x then go to l8
         else if not eqcar(u,car x) then go to l2;
    l7: if w and cdr u then w := aconc!*(cdr w,car w);
        v := multfs(brace(w,l,nil),v);  % v := ('brace . l . w) . v;
        go to l1;
    l8: v := mkg(w,l);                  % v := list('g . l . w);
        z := reverse z;
        k := k/2;
        go to l1;
    l9: u := 2**k;
        if not evenp(k-m) then u := - u;
        return multd!*(u,v)             % return 'times . u . v;
   end;

symbolic procedure appr(u,v);
   if null u then v else appr(cdr u,car u . v);

symbolic procedure exc(u,v);
   if null cdr u then v else not v;

symbolic procedure brace(u,l,i);
   if null u then 2
    else if xnp(i,u) or flagp(l,'nospur)
     then addf(mkg1(u,l),mkg1(reverse u,l))
    else if car u eq 'a
       then if hevenp u then addfs(mkg(u,l),
                                 negf mkg('a . reverse cdr u,l))
             else mkf(mka l,spr2(cdr u,l,2,nil))
    else if hevenp u then spr2(u,l,2,nil)
    else spr1(u,l,2,nil);

symbolic procedure spr1(u,l,n,b);
   if null u then nil
    else if null cdr u then multd!*(n,mkg1(u,l))
    else begin scalar m,x,z;
               x := u;
               m := 1;
          a:   if null x then return z;
               z:= addfs(mkf(mkg1(list car x,l),
                              if null b then spurr(remove(u,m),l,nil,n)
                               else spr1(remove(u,m),l,n,nil)),
                         z);
               x := cdr x;
               n :=  - n;
               m := m+1;
               go to a
    end;

symbolic procedure spr2(u,l,n,b);
   if null cddr u and null b then multd!*(n,mkdot(car u,cadr u))
    else (lambda x; if b then addfs(spr1(u,l,n,b),x) else x)
       addfs(spurr(u,l,nil,n),
             mkf(mka l,spurr(append(u,list 'a),l,nil,n)));

symbolic procedure hevenp u;
   null u or not hevenp cdr u;

symbolic procedure bassoc(u,v);
   if null v then nil
    else if u eq caar v or u eq cdar v then car v
    else bassoc(u,cdr v);

symbolic procedure memlis(u,v);
   if null v then nil
    else if u member car v then car v
    else memlis(u,cdr v);

symbolic procedure spurr(u,l,v,n);
   begin scalar w,x,y,z,z1; integer m;
    a:  if null u then go to b
         else if car u member cdr u then go to g;
        v := car u . v;
        u := cdr u;
        go to a;
    b:  return if null v then n
         else if flagp(l,'nospur) then multd!*(n,mkgamf(v,l))
         else multd!*(n,sprgen v);
    g:  x := car u;
        y := cdr u;
        w := y;
        m := 1;
    h:  if not x eq car w then go to h1
         else if null(w:= mkdot(x,x)) then return z
         else return addfs(mkf(w,spurr(delete(x,y),l,v,n)),z);
    h1: z1 := mkdot(x,car w);
        if z1 then z:= addfs(mkf(z1,spurr(remove(y,m),l,v,2*n)),z);
        w := cdr w;
        n :=  - n;
        m := m+1;
        go to h
   end;

symbolic procedure sprgen v;
   begin scalar x,y,z;
        if not (car v eq 'a) then return sprgen1(v,t)
         else if null (x := comb(v := cdr v,4)) then return nil
         else if null cdr x then go to e;
    c:  if null x then return multpf('i to 1,z);
        y := mkepsf car x;
        if asign(car x,v,1)=-1 then y := negf y;
        z := addf(multf(y,sprgen1(setdiff(v,car x),t)),z);
    d:  x := cdr x;
        go to c;
    e:  z := mkepsf car x;
        go to d
   end;

symbolic procedure asign(u,v,n);
   if null u then n else asign(cdr u,v,asign1(car u,v,-1)*n);

symbolic procedure asign1(u,v,n);
   if u eq car v then n else asign1(u,cdr v,-n);

symbolic procedure sprgen1(u,b);
   if null u then nil
    else if null cddr u then (lambda x; if b then x else negf x)
                                mkdot(car u,cadr u)
    else begin scalar w,x,y,z;
               x := car u;
               u := cdr u;
               y := u;
          a:   if null u then return z
                else if null(w:= mkdot(x,car u)) then go to c;
               z := addf(multf(w,sprgen1(delete(car u,y),b)),z);
          c:   b := not b;
               u := cdr u;
               go to a
    end;

% ****************** FUNCTIONS FOR EPSILON ALGEBRA ******************


put('eps,'simpfn,'simpeps);

symbolic procedure mkepsf u;
   (lambda x; (lambda y; if null car x then negf y else y) mksf cdr x)
        mkepsk u;

symbolic procedure esum(u,i,v,w,x);
   begin scalar y,z,z1;
        z := car u;
        u := cdr u;
        if cdr z neq 1
         then u := multf(exptf(mkepsf cdar z,cdr z-1),u);
        z := cdar z;
    a:  if repeats z then return;
    b:  if null z then return isimp1(u,i,v,reverse y . w,x)
         else if not (car z member i) then go to d
         else if not (z1 := bassoc(car z,v)) then go to c;
        v := delete(z1,v);
        i := delete(car z,i);
        z := append(reverse y,other(car z,z1) . cdr z);
        y := nil;
        go to a;
    c:  if z1 := memlis(car z,w) then go to c1
         else return isimp1(u,i,v,append(reverse y,z) . w,x);
    c1: z := append(reverse y,z);
        y := xn(i,xn(z,z1));
        return isimp1(multfs(emult1(z1,z,y),u),
                      setdiff(i,y),
                      v,
                      delete(z1,w),
                      x);
    d:  y := car z . y;
        z := cdr z;
        go to b
   end;

symbolic procedure emult u;
   if null cdr u then mkepsf car u
    else if null cddr u then emult1(car u,cadr u,nil)
    else multfs(emult1(car u,cadr u,nil),emult cddr u);

symbolic procedure emult1(u,v,i);
   (lambda (x,y);
         (lambda (m,n);
               if m=4 then 24*n
                else if m=3 then multd(6*n,mkdot(car x,car y))
                else multd!*(n*(if m = 0 then 1 else m),
                           car detq maplist(x,
                             function (lambda k;
                               maplist(y,
                                 function (lambda j;
                                   mkdot(car k,car j) . 1))))))
            (length i,
             (lambda j; nb if permp(u,append(i,x)) then not j else j)
                permp(v,append(i,y))))
      (setdiff(u,i),setdiff(v,i));

endmodule;


end;

Added r33/int.red version [f57c141c52].































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
module int!-intro; % General support for REDUCE integrator.

% Authors: A. C. Norman and P. M. A. Moore.
% Modified by: J. Davenport, J. P. Fitch, A. C. Hearn.

% Note that at one point, INT had been flagged SIMP0FN.  However, that
% lead to problems when the arguments of INT contained pattern
% variables.

fluid '(!*conscount !*noextend !*pvar gaussiani);

global '(btrlevel frlis!* gensymcount initl!*);

!*conscount:=10000; % default maximum number of conses in certain
                    % operations.

!*pvar:='!_a;

btrlevel := 5; %default to a reasonably full backtrace.

% The next smacro is needed at this point to define gaussiani.

symbolic smacro procedure !*kk2f u; !*p2f mksp(u,1);

gaussiani := !*kk2f '(sqrt -1);

gensymcount := 0;

initl!* := append('(!*noextend), initl!*);

flag('(interr),'transfer);   %For the compiler;

flag ('(atan dilog erf expint expt log tan),'transcendental);

comment Kludge to define derivative of an integral and integral of
        a derivative;

frlis!* := union('(!=x !=y),frlis!*);

put('df,'opmtch,'(((int !=y !=x) !=x) (nil . t)
                  (evl!* !=y) nil) . get('df,'opmtch));

put('int,'opmtch,'(((df !=y !=x) !=x) (nil . t)
                  (evl!* !=y) nil) . get('int,'opmtch));

put('evl!*,'opmtch,'(((!=x) (nil . t) !=x nil)));

put('evl!*,'simpfn,'simpiden);


%Various functions used throughout the integrator.

smacro procedure !*kk2q a; ((mksp(a,1) .* 1) .+ nil) ./ 1;

symbolic smacro procedure divsf(u,v); sqrt2top(u ./ v);

symbolic procedure flatten u;
   if null u then nil
    else if atom u then list u
    else if atom car u then car u . flatten cdr u
    else nconc(flatten car u,flatten cdr u);

symbolic procedure int!-gensym1 u;
    << gensymcount:=gensymcount+1;
       compress append(explode u,explode gensymcount) >>;

symbolic smacro procedure maninp(u,v,w);
   interr "MANINP called -- not implemented";

symbolic procedure mknill n; if n=0 then nil else nil . mknill(n-1);


% Various selectors written as macros.

smacro procedure argof u;
   % Argument of a unary function.
   cadr u;

smacro procedure firstsubs u;
  % The first substitution in a substitution list.
  car u;

smacro procedure lsubs u; car u;

smacro procedure rsubs u; cdr u;

smacro procedure lfirstsubs u; caar u;

smacro procedure rfirstsubs u; cdar u;

put('nthroot,'simpfn,'simpiden);
% The binary n-th root operator nthroot(x,2)=sqrt(x)
% no simplification is used here.
% Hope is that pbuild introduces it, and simplog removes it.


% Selectors for the taylor series structure.

% Format is:
%function.((first.last computed so far) . assoc list of computed terms).

% ***store-hack-1***:
% remove this macro if more store is available.

smacro procedure tayshorten u;nil;

smacro procedure taylordefn u; car u;

symbolic smacro procedure taylorfunction u; caar u;

smacro procedure taylornumbers u; cadr u;

smacro procedure taylorfirst u; caadr u;

smacro procedure taylorlast u; cdadr u;

smacro procedure taylorlist u; cddr u;

smacro procedure taylormake(fn,nums,alist); fn.(nums.alist);

endmodule;


module contents;

% Authors: Mary Ann Moore and Arthur C. Norman

fluid '(clogflag content indexlist sqfr varlist zlist);

exports contents,contentsmv,dfnumr,difflogs,factorlistlist,multsqfree,
        multup,sqfree,sqmerge;

imports int!-fac,fquotf,gcdf,interr,!*multf,partialdiff,quotf,ordop,
        addf,negf,domainp,difff,mksp,negsq,invsq,addsq,!*multsq,diffsq;


comment we assume no power substitution is necessary in this module;

symbolic procedure contents(p,v);
% Find the contents of the polynomial p wrt variable v;
% Note that v may not be the main variable of p;
    if domainp(p) then p
    else if v=mvar p then contentsmv(p,v,nil)
    else if ordop(v,mvar p) then p
    else contentsmv(makemainvar(p,v),v,nil);

symbolic procedure contentsmv(p,v,sofar);
% Find contents of polynomial P;
% V is main variable of P;
% SOFAR is partial result;
    if sofar=1 then 1
    else if domainp p then gcdf(p,sofar)
    else if not v=mvar p then gcdf(p,sofar)
    else contentsmv(red p,v,gcdf(lc p,sofar));



symbolic procedure makemainvar(p,v);
% Bring v up to be the main variable in polynomial p;
% Note that the reconstructed p must be used with care since;
% it does not conform to the normal reduce ordering rules;
    if domainp p then p
    else if v=mvar p then p
    else mergeadd(mulcoeffsby(makemainvar(lc p,v),lpow p,v),
      makemainvar(red p,v),v);

symbolic procedure mulcoeffsby(p,pow,v);
% Multiply each coefficient in p by the standard power pow;
    if null p then nil
    else if domainp p or not v=mvar p then ((pow .* p) .+ nil)
    else (lpow p .* ((pow .* lc p) .+ nil)) .+ mulcoeffsby(red p,pow,v);

symbolic procedure mergeadd(a,b,v);
% Add polynomials a and b given that they have same main variable v;
    if domainp a or not v=mvar a then
      if domainp b or not v=mvar b then addf(a,b)
      else lt b .+ mergeadd(a,red b,v)
    else if domainp b or not v=mvar b then
      lt a .+ mergeadd(red a,b,v)
    else (lambda xc;
      if xc=0 then (lpow a .* addf(lc a,lc b)) .+
            mergeadd(red a,red b,v)
      else if xc>0 then lt a .+ mergeadd(red a,b,v)
      else lt b .+ mergeadd(a,red b,v))
        (tdeg lt a-tdeg lt b);



symbolic procedure sqfree(p,vl);
    if (null vl) or (domainp p) then
        <<content:=p; nil>>
    else begin    scalar w,v,dp,gg,pg,dpg,p1,w1;
        w:=contents(p,car vl); % content of p ;
        p:=quotf(p,w); % make p primitive;
        w:=sqfree(w,cdr vl); % process content by recursion;
        if p=1 then return w;
        v:=car vl; % pick out variable from list;
        while not (p=1) do <<
            dp:=partialdiff(p,v);
            gg:=gcdf(p,dp);
            pg:=quotf(p,gg);
            dpg:=negf partialdiff(pg,v);
            p1:=gcdf(pg,addf(quotf(dp,gg),dpg));
            w1:=p1.w1;
            p:=gg>>;
        return sqmerge(reverse w1,w,t)
        end;

symbolic procedure sqmerge(w1,w,simplew1);
% w and w1 are lists of factors of each power. if simplew1 is true
% then w1 contains only single factors for each power. ;
    if null w1 then w
    else if null w then if car w1=1 then nil.sqmerge(cdr w1,w,simplew1)
          else (if simplew1 then list car w1 else car w1).
sqmerge(cdr w1,w,simplew1)
    else if car w1=1 then (car w).sqmerge(cdr w1,cdr w,simplew1) else
        append(if simplew1 then list car w1 else car w1,car w).
        sqmerge(cdr w1,cdr w,simplew1);

symbolic procedure multup l;
% l is a list of s.f.'s. result is s.f. for product of elements of l;
   begin         scalar res;
      res:=1;
      while not null l do <<
         res:=multf(res,car l);
         l:=cdr l >>;
      return res
   end;

symbolic procedure diflist(l,cl,x,rl);
% Differentiates l (list of s.f.'s) wrt x to produce the sum of
% terms for the derivative of numr of 1st part of answer.  cl is
% coefficient list (s.f.'s) & rl is list of derivatives we have
% dealt with so far.  Result is s.q.;
   if null l then nil ./ 1
   else begin    scalar temp;
      temp:=!*multf(multup rl,multup cdr l);
      temp:=!*multsq(difff(car l,x),!*f2q temp);
      temp:=!*multsq(temp,(car cl) ./ 1);
      return addsq(temp,diflist(cdr l,cdr cl,x,(car l).rl))
   end;

symbolic procedure multsqfree w;
% W is list of sqfree factors. result is product of each LIST IN W
% to give one polynomial for each sqfree power;
   if null w then nil
   else (multup car w).multsqfree cdr w;

symbolic procedure l2lsf l;
% L is a list of kernels. result is a list of same members as s.f.'s;
   if null l then nil
   else ((mksp(car l,1) .* 1) .+ nil).l2lsf cdr l;

symbolic procedure dfnumr(x,dl);
% Gives the derivative of the numr of the 1st part of answer.
% dl is list of any exponential or 1+tan**2 that occur in integrand
% denr. these are divided out from result before handing it back.
% result is s.q., ready for printing.
   begin         scalar temp1,temp2,coeflist,qlist,count;
      if not null sqfr then <<
      count:=0;
      qlist:=cdr sqfr;
      coeflist:=nil;
      while not null qlist do <<
         count:=count+1;
         coeflist:=count.coeflist;
         qlist:=cdr qlist >>;
      coeflist:=reverse coeflist >>;
      temp1:=!*multsq(diflist(l2lsf zlist,l2lsf indexlist,x,nil),
                      !*f2q multup sqfr);
      if not null sqfr and not null cdr sqfr then <<
          temp2:=!*multsq(diflist(cdr sqfr,coeflist,x,nil),
                          !*f2q multup l2lsf zlist);
      temp2:=!*multsq(temp2,(car sqfr) ./ 1) >>
      else temp2:=nil ./ 1;
      temp1:=addsq(temp1,negsq temp2);
      temp2:=cdr temp1;
      temp1:=car temp1; 
      qlist:=nil;
      while not null dl do <<
         if not car dl member qlist then qlist:=(car dl).qlist;
         dl:=cdr dl >>;
      while not null qlist do <<
         temp1:=quotf(temp1,car qlist);
         qlist:=cdr qlist >>;
      return temp1 ./ temp2
   end;

symbolic procedure difflogs(ll,denm1,x);
% LL is list of log terms (with coeffts), den is common denominator
% over which they are to be put.  Result is s.q. for derivative of all
% these wrt x.
   if null ll then nil ./ 1
   else begin    scalar temp,qu,cvar,logoratan,arg;
      logoratan:=caar ll;
      cvar:=cadar ll;
      arg:=cddar ll;
      temp:=!*multsq(cvar ./ 1,diffsq(arg,x));
      if logoratan='iden then qu:=1 ./ 1
        else if logoratan='log then qu:=arg
        else if logoratan='atan then qu:=addsq(1 ./ 1,!*multsq(arg,arg))
        else interr "Logoratan=? in difflogs";
%Note call to special division routine;
      qu:=fquotf(!*multf(!*multf(denm1,numr temp),
                denr qu),numr qu);
                        %*MUST* GO EXACTLY;
     temp:=!*multsq(!*invsq (denr temp ./ 1),qu);
                 %result of fquotf is a s.q;
      return !*addsq(temp,difflogs(cdr ll,denm1,x))
   end;

symbolic procedure factorlistlist (w,clogflag);
% W is list of lists of sqfree factors in s.f.  result is list of log
% terms required for integral answer. the arguments for each log fn
% are in s.q.;
    begin scalar res,x,y;
        while not null w do <<
            x:=car w;
            while not null x do <<
                y:=facbypp(car x,varlist);
                while not null y do <<
                    res:=append(int!-fac car y,res);
                    y:=cdr y >>;
                x:=cdr x >>;
            w:=cdr w >>;
        return res
    end;

symbolic procedure facbypp(p,vl);
% Use contents/primitive parts to try to factor p.
    if null vl then list p
    else begin scalar princilap!-part,co;
        co:=contents(p,car vl);
        vl:=cdr vl;
        if co=1 then return facbypp(p,vl); %this var no help.
        princilap!-part:=quotf(p,co); %primitive part.
        if princilap!-part=1 then return facbypp(p,vl); %again no help;
        return nconc(facbypp(princilap!-part,vl),facbypp(co,vl))
    end;

endmodule;


module csolve;   % routines to do with the C constants.

% Author: John P. Fitch.

fluid '(ccount cmap cmatrix cval loglist neweqn);

global '(!*trint);

exports backsubst4cs,createcmap,findpivot,printspreadc,printvecsq,
   spreadc,subst4eliminateds;

imports nth,interr,!*multf,printsf,printsq,quotf,putv,negf,invsq,
   negsq,addsq,multsq,mksp,addf,domainp,pnth;

symbolic procedure findpivot cvec;
% Finds first non-zero element in CVEC and returns its cell number.
% If no such element exists, result is nil.
   begin         scalar i,x;
      i:=1;
      x:=getv(cvec,i);
      while i<ccount and null x do
      << i:=i+1;
         x:=getv(cvec,i) >>;
      if null x then return nil;
      return i
   end;

symbolic procedure subst4eliminatedcs(neweqn,substorder,ceqns);
% Substitutes into NEWEQN for all the C's that have been eliminated so
% far. These are given by CEQNS. SUBSTORDER gives the order of
% substitution as well as the constant multipliers. Result is the
% transformed NEWEQN.
   if null substorder then neweqn
   else begin    scalar nxt,row,cvar,temp;
      row:=car ceqns;
      nxt:=car substorder;
      if null (cvar:=getv(neweqn,nxt)) then
         return subst4eliminatedcs(neweqn,cdr substorder,cdr ceqns);
      nxt:=getv(row,nxt);
      for i:=0 : ccount do
      << temp:=!*multf(nxt,getv(neweqn,i));
         temp:=addf(temp,negf !*multf(cvar,getv(row,i)));
         putv(neweqn,i,temp) >>;
      return subst4eliminatedcs(neweqn,cdr substorder,cdr ceqns)
   end;


symbolic procedure backsubst4cs(cs2subst,cs2solve,cmatrix);
% Solves the C-eqns and sets vector CVAL to the C-constant values
% CMATRIX is a list of matrix rows for C-eqns after Gaussian
% elimination has been performed. CS2SOLVE is a list of the remaining
% C's to evaluate and CS2SUBST are the C's we have evaluated already.
   if null cmatrix then nil
   else begin    scalar eqnn,cvar,already,substlist,temp,temp2;
      eqnn:=car cmatrix;
      cvar:=car cs2solve;
      already:=nil ./ 1; % The S.Q. nil.
      substlist:=cs2subst;
% Now substitute for previously evaluated c's:
      while not null substlist do
      << temp:=car substlist;
         if not null getv(eqnn,temp) then
            already:=addsq(already,multsq(getv(eqnn,temp) ./ 1,
                                 getv(cval,temp)));
         substlist:=cdr substlist >>;
% Now solve for the c given by cvar (any remaining c's assumed zero).
      temp:=negsq addsq(getv(eqnn,0) ./ 1,already);
      if not null (temp2:=quotf(numr temp,getv(eqnn,cvar))) then
                                       temp:=temp2 ./ denr temp
      else temp:=multsq(temp,invsq(getv(eqnn,cvar) ./ 1));
      if not null numr temp then putv(cval,cvar,
                resimp rootextractsq subs2q temp);
      backsubst4cs(reversewoc(cvar . reversewoc cs2subst),
            cdr cs2solve,cdr cmatrix)
   end;

%**********************************************************************
% Routines to deal with linear equations for the constants C.
%**********************************************************************

symbolic procedure createcmap;
%Sets LOGLIST to list of things of form (LOG C-constant f), where f is
% function linear in one of the z-variables and C-constant is in S.F.
% When creating these C-constant names, the CMAP is also set up and
% returned as the result.
   begin         scalar i,l,c;
      l:=loglist;
      i:=1;
      while not null l do <<
         c:=(int!-gensym1('c) . i) . c;
         i:=i+1;
         rplacd(car l,((mksp(caar c,1) .* 1) .+ nil) . cdar l);
         l:=cdr l >>;
      if !*trint then printc ("Constants Map" . c);
      return c
   end;


symbolic procedure spreadc(eqnn,cvec1,w);
% Sets a vector 'cvec1' to coefficients of c<i> in eqnn.
    if domainp eqnn then putv(cvec1,0,addf(getv(cvec1,0),
                                !*multf(eqnn,w)))
    else begin    scalar mv,t1,t2;
        spreadc(red eqnn,cvec1,w);
        mv:=mvar eqnn;
        t1:=assoc(mv,cmap); %tests if it is a c var.
        if not null t1 then return <<
            t1:=cdr t1; %loc in vector for this c.
            if not (tdeg lt eqnn=1) then interr "Not linear in c eqn";
            t2:=addf(getv(cvec1,t1),!*multf(w,lc eqnn));
            putv(cvec1,t1,t2) >>;
        t1:=((lpow eqnn) .* 1) .+ nil; %this main var as sf.
        spreadc(lc eqnn,cvec1,!*multf(w,t1))
    end;

symbolic procedure printspreadc cvec1;
    begin
        for i:=0 : ccount do <<
           prin2 i;
           printc ":";
           printsf(getv(cvec1,i)) >>;
        printc "End of printspreadc output"
    end;

%symbolic procedure printvecsq cvec;
%% Print contents of cvec which contains s.q.'s (not s.f.'s).
%% Starts from cell 1 not 0 as above routine (printspreadc).
%   begin
%      for i:=1 : ccount do <<
%        prin2 i;
%        printc ":";
%        if null getv(cvec,i) then printc "0"
%        else printsq(getv(cvec,i)) >>;
%      printc "End of printvecsq output"
%   end;

endmodule;


module cuberoot;  % Cube roots of standard forms.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(cuberootflag);

exports cuberootdf;

imports contentsmv,gcdf,!*multf,nrootn,partialdiff,printdf,quotf,vp2,
   mksp,mk!*sq,domainp;

symbolic procedure cuberootsq a;
    cuberootf numr a ./ cuberootf denr a;

symbolic procedure cuberootf p;
    begin       scalar ip,qp;
        if null p then return nil;
        ip:=cuberootf1 p;
        qp:=cdr ip;
        ip:=car ip; %respectable and nasty parts of the cuberoot.
        if numberp qp and onep qp then return ip; %exact root found.
        qp:=list('expt,prepf qp,'(quotient 1 3));
        cuberootflag:=t; %symbolic cube-root introduced.
        qp:=(mksp(qp,1).* 1) .+ nil;
        return !*multf(ip,qp)
    end;

symbolic procedure cuberootf1 p;
  % Returns a . b with p=a**2*b.
  % Does this need power reduction?
    if domainp p then nrootn(p,3)
    else begin scalar co,ppp,g,pg;
        co:=contentsmv(p,mvar p,nil); %contents of p.
        ppp:=quotf(p,co); %primitive part.
   % now consider ppp=p1*p2**2*p3**3*p4**4*...
        co:=cuberootf1(co); %process contents via recursion.
        g:=gcdf(ppp,partialdiff(ppp,mvar ppp));
    % g=p2*p3**2*p4**3*...
        if not domainp g then <<
            pg:=quotf(ppp,g);
    %pg=p1*p2*p3*p4*...
            g:=gcdf(g,partialdiff(g,mvar g));
    % g=g3*g4**2*g5**3*...
            g:=gcdf(g,pg)>>; %a triple factor of ppp.
        if domainp g then pg:=1 . ppp
        else <<
            pg:=quotf(ppp,!*multf(g,!*multf(g,g))); %what's left.
            pg:=cuberootf1 pg; %split that up.
            rplaca(pg,!*multf(car pg,g))>>;
                 %put in the thing found here.
        rplaca(pg,!*multf(car pg,car co));
        rplacd(pg,!*multf(cdr pg,cdr co));
        return pg
    end;

endmodule;


module idepend;  % Routines for considering dependency among variables.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(taylorvariable);

exports dependspl,dependsp,involvesq,involvsf;

imports taylorp,domainp;

symbolic procedure dependsp(x,v);
   if null v then t
    else if depends(x,v) then x
    else if atom x then if x eq v then x else nil
    else if car x = '!*sq then involvesq(cadr x,v)
    else if taylorp x
     then if v eq taylorvariable then taylorvariable else nil
    else begin scalar w;
       if x=v then return v;
       % Check if a prefix form expression depends on the variable v.
       % Note this assumes the form x is in normal prefix notation;
       w := x; % preserve the dependency;
       x := cdr x; % ready to recursively check arguments;
 scan: if null x then return nil; % no dependency found;
       if dependsp(car x,v) then return w;
       x:=cdr x;
       go to scan
    end;

symbolic procedure involvesq(sq,term);
   involvesf(numr sq,term) or involvesf(denr sq,term);
  
symbolic procedure involvesf(sf,term);
   if domainp sf or null sf then nil
    else dependsp(mvar sf,term)
       or involvesf(lc sf,term)
       or involvesf(red sf,term);

symbolic procedure dependspl(dep!-list,var);
   % True if any member of deplist (a list of prefix forms) depends on
   % var.
   dep!-list
      and (dependsp(car dep!-list,var) or dependspl(cdr dep!-list,var));

symbolic procedure taylorp exxpr;
   % Sees if a random entity is a taylor expression.
   not atom exxpr
       and not atom car exxpr
       and flagp(taylorfunction exxpr,'taylor);

endmodule;


module df2q;   % Conversion from distributive to standard forms.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(indexlist zlist);

exports df2q;

imports addf,gcdf,mksp,!*multf,quotf;

comment We assume that results already have reduced powers, so
        that no power substitution is necessary;

symbolic procedure df2q p;
% Converts distributed form P to standard quotient;
    begin       scalar n,d,gg,w;
        if null p then return nil ./ 1;
        d:=denr lc p;
        w:=red p;
        while not null w do <<
            gg:=gcdf(d,denr lc w); %get denominator of answer...
            d:=!*multf(d,quotf(denr lc w,gg));
                 %..as lcm of denoms in input
            w:=red w >>;
        n:=nil; %place to build numerator of answer
        while not null p do <<
            n:=addf(n,!*multf(xl2f(lpow p,zlist,indexlist),
                !*multf(numr lc p,quotf(d,denr lc p))));
            p:=red p >>;
        return n ./ d
    end;

symbolic procedure xl2f(l,z,il);
% L is an exponent list from a D.F., Z is the Z-list,
% IL is the list of indices.
% Value is L converted to standard form. ;
    if null z then 1
        else if car l=0 then xl2f(cdr l,cdr z,cdr il)
        else if not atom car l then
            begin       scalar temp;
                if caar l=0 then temp:= car il
                else temp:=list('plus,car il,caar l);
                temp:=mksp(list('expt,car z,temp),1);
                return !*multf(((temp .* 1) .+ nil),
                               xl2f(cdr l,cdr z,cdr il))
            end
%       else if minusp car l then                                     ;
%            multsq(invsq (((mksp(car z,-car l) .* 1) .+ nil)),       ;
%                  xl2f(cdr l,cdr z,cdr il))                          ;
        else !*multf((mksp(car z,car l) .* 1) .+ nil,
                    xl2f(cdr l,cdr z,cdr il));

endmodule;


module distrib;  % Routines for manipulating distributed forms.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(indexlist sqrtlist zlist);

exports dfprintform,multbyarbpowers,negdf,quotdfconst,sub1ind,vp1,
   vp2,plusdf,multdf,multdfconst,orddf;

imports interr,addsq,negsq,exptsq,simp,domainp,mk!*sq,addf,
   multsq,invsq,minusp,mksp,sub1;

%***********************************************************************
% NOTE:     The expressions lt,red,lc,lpow have been used on distributed
%           forms as the latter's structure is sufficiently similar to
%           s.f.'s.  However lc df is a s.q. not a s.f. and lpow df is a
%           list of the exponents of the variables.  This also makes
%           lt df different.  Red df is d.f. as expected.
%**********************************************************************;

symbolic procedure plusdf(u,v);
% U and V are D.F.'s. Value is D.F. for U+V;
    if null u then v
        else if null v then u
        else if lpow u=lpow v then
            (lambda(x,y); if null numr x then y else (lpow u .* x) .+ y)
            (!*addsq(lc u,lc v),plusdf(red u,red v))
        else if orddf(lpow u,lpow v) then lt u .+ plusdf(red u,v)
        else (lt v) .+ plusdf(u,red v);

symbolic procedure orddf(u,v);
% U and V are the LPOW of a D.F. - i.e. the list of exponents ;
% Value is true if LPOW U '>' LPOW V and false otherwise ;
    if null u then if null v then interr "Orddf = case"
        else interr "Orddf v longer than u"
        else if null v then interr "Orddf u longer than v"
        else if exptcompare(car u,car v) then t
        else if exptcompare(car v,car u) then nil
        else orddf(cdr u,cdr v);

symbolic procedure exptcompare(x,y);
    if atom x then if atom y then x>y else nil
        else if atom y then t
        else car x > car y;

symbolic procedure negdf u;
    if null u then nil
        else (lpow u .* negsq lc u) .+ negdf red u;

symbolic procedure multdf(u,v);
% U and V are D.F.'s. Value is D.F. for U*V;
% reduces squares of square-roots as it goes;
    if null u or null v then nil
    else begin scalar y;
%use (a+b)*(c+d) = (a*c) + a*(c+d) + b*(c+d);
        y:=multerm(lt u,lt v); %leading terms;
        y:=plusdf(y,multdf(red u,v));
        y:=plusdf(y,multdf((lt u) .+ nil,red v));
        return y
    end;

symbolic procedure multerm(u,v);
%multiply two terms to give a D.F.;
    begin scalar coef;
       coef:=!*multsq(cdr u,cdr v); %coefficient part;
       return multdfconst(coef,mulpower(car u,car v))
    end;

symbolic procedure mulpower(u,v);
% u and v are exponent lists. multiply corresponding forms;
    begin scalar r,s;
       r:=addexptsdf(u,v);
       if not null sqrtlist then s:=reduceroots(r,zlist);
       r:=(r .* (1 ./ 1)) .+ nil;
       if not (s=nil) then r:=multdf(r,s);
       return r
    end;

symbolic procedure reduceroots(r,zl);
    begin scalar s;
       while not null r do <<
          if eqcar(car zl,'sqrt) then
              s:=tryreduction(r,car zl,s);
          r:=cdr r; zl:=cdr zl >>;
       return s
    end;

symbolic procedure tryreduction(r,var,s);
   begin scalar x;
      x:=car r; %current exponent
      if not atom x then << r:=x; x:=car r >>; %numeric part
      if (x=0) or (x=1) then return s; %no reduction possible
      x:=divide(x,2);
      rplaca(r,cdr x); %reduce exponent as redorded
      x:=car x;
      var:=simp cadr var; %sqrt arg as a s q
      var:=!*exptsq(var,x);
      x:=multdfconst(1 ./ denr var,f2df numr var); %distribute
      if s=nil then s:=x
      else s:=multdf(s,x);
      return s
   end;



symbolic procedure addexptsdf(x,y);
% X and Y are LPOW's of D.F. Value is list of sum of exponents;
    if null x then if null y then nil else interr "X too long"
        else if null y then interr "Y too long"
        else exptplus(car x,car y).addexptsdf(cdr x,cdr y);

symbolic procedure exptplus(x,y);
    if atom x then if atom y then x+y else list (x+car y)
        else if atom y then list (car x +y)
        else interr "Bad exponent sum";

symbolic procedure multdfconst(x,u);
% X is S.Q. not involving Z variables of D.F. U. Value is D.F.;
% for X*U;
    if (null u) or (null numr x) then nil
        else lpow u .* !*multsq(x,lc u) .+ multdfconst(x,red u);

%symbolic procedure quotdfconst(x,u);
%    multdfconst(!*invsq x,u);

symbolic procedure f2df p;
% P is standard form. Value is P in D.F.;
    if domainp p then dfconst(p ./ 1)
        else if mvar p member zlist then
             plusdf(multdf(vp2df(mvar p,tdeg lt p,zlist),f2df lc p),
                    f2df red p)
        else plusdf(multdfconst(((lpow p .* 1) .+ nil) ./ 1,f2df lc p),
                    f2df red p);

symbolic procedure vp1(var,degg,z);
% Takes VAR and finds it in Z (=list), raises it to power DEGG and puts
% the result in exponent list form for use in a distributed form.
    if null z then interr "Var not in z-list after all"
        else if var=car z then degg.vp2 cdr z
        else 0 . vp1(var,degg,cdr z);

symbolic procedure vp2 z;
% Makes exponent list of zeroes.
    if null z then nil
        else 0 . vp2 cdr z;

symbolic procedure vp2df(var,exprn,z);
% Makes VAR**EXPRN into exponent list and then converts the resulting
% power into a distributed form.
% Special care with square-roots.
    if eqcar(var,'sqrt) and (exprn>1) then
        mulpower(vp1(var,exprn,z),vp2 z)
    else (vp1(var,exprn,z) .* (1 ./ 1)) .+ nil;

symbolic procedure dfconst q;
% Makes a distributed form from standard quotient constant Q;
    if numr q=nil then nil
        else ((vp2 zlist) .* q) .+ nil;

%df2q moved to a section of its own.

symbolic procedure df2printform p;
%Convert to a standard form good enough for printing.
    if null p then nil
    else begin
        scalar mv,co;
        mv:=xl2q(lpow p,zlist,indexlist);
        if mv=(1 ./ 1) then <<
            co:=lc p;
            if denr co=1 then return addf(numr co,
                df2printform red p);
            co:=mksp(mk!*sq co,1);
            return (co .* 1) .+ df2printform red p >>;
        co:=lc p;
        if not (denr co=1) then mv:=!*multsq(mv,1 ./ denr co);
        mv:=mksp(mk!*sq mv,1) .* numr co;
        return mv .+ df2printform red p
    end;


symbolic procedure xl2q(l,z,il);
% L is an exponent list from a D.F.,Z is the Z-list, IL is the list of
% indices.  Value is L converted to standard quotient. ;
    if null z then 1 ./ 1
        else if car l=0 then xl2q(cdr l,cdr z,cdr il)
        else if not atom car l then
            begin    scalar temp;
                if caar l=0 then temp:= car il
                else temp:=list('plus,car il,caar l);
                temp:=mksp(list('expt,car z,temp),1);
                return !*multsq(((temp .* 1) .+ nil) ./ 1,
                               xl2q(cdr l,cdr z,cdr il))
            end
        else if minusp car l then
             !*multsq(!*invsq(((mksp(car z,-car l) .* 1) .+ nil) ./ 1),
                         xl2q(cdr l,cdr z,cdr il))
        else !*multsq(((mksp(car z,car l) .* 1) .+ nil) ./ 1,
                    xl2q(cdr l,cdr z,cdr il));


%symbolic procedure sub1ind power;
%     if atom power then power-1
%     else list sub1 car power;

symbolic procedure multbyarbpowers u;
% Multiplies the ordinary D.F., U, by arbitrary powers
% of the z-variables;
%       i-1  j-1  k-1
% i.e. x    z    z    ... so result is D.F. with the exponent list
%            1    2
%appropriately altered to contain list elements instead of numeric ones.
   if null u then nil
   else ((addarbexptsdf lpow u) .* lc u) .+ multbyarbpowers red u;

symbolic procedure addarbexptsdf x;
% Adds the arbitrary powers to powers in exponent list, X, to produce
% new exponent list.  e.g. 3 -> (2) to represent x**3 now becoming :
%          3    i-1    i+2                                       ;
%         x  * x    = x      . ;
   if null x then nil
   else list exptplus(car x,-1) . addarbexptsdf cdr x;

endmodule;


module divide;  % Exact division of standard forms to give a S Q.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(residue sqrtlist zlist);

global '(!*trdiv !*trint);

exports fquotf,testdivdf,dfquotdf;

imports df2q,f2df,gcdf,interr,multdf,negdf,plusdf,printdf,printsf,
   quotf,multsq,invsq,negsq;

% Intended for dividing out known factors as produced by the
% integration program. horrible and slow, i expect!!

symbolic procedure dfquotdf(a,b);
    begin       scalar residue;
        if (!*trint or !*trdiv) then <<
            printc "Dfquotdf called on ";
            printdf a; printdf b>>;
        a:=dfquotdf1(a,b);
        if (!*trint or !*trdiv) then << printc "Quotient given as ";
            printdf a >>;
        if not null residue then begin
            scalar gres,w;
            if !*trint or !*trdiv then <<
            printc "Residue in dfquotdf =";
            printdf residue;
            printc "Which should be zero";
            w:=residue;
            gres:=numr lc w; w:=red w;
            while not null w do <<
                gres:=gcdf(gres,numr lc w);
                w:=red w >>;
            printc "I.e. the following vanishes";
            printsf gres>>;
            interr "Non-exact division due to a log term"
            end;
        return a
   end;

symbolic procedure fquotf(a,b);
% Input: a and b standard quotients with (a/b) an exact
% division with respect to the variables in zlist,
% but not necessarily obviously so. the 'non-obvious' problems
% will be because of (e.g.) square-root symbols in b
% output: standard quotient for (a/b)
% (prints message if remainder is not 'clearly' zero.
% A must not be zero.
    begin         scalar t1;
        if null a then interr "A=0 in fquotf";
        t1:=quotf(a,b); %try it the easy way
        if not null t1 then return t1 ./ 1; %ok
        return df2q dfquotdf(f2df a,f2df b)
    end;

symbolic procedure dfquotdf1(a,b);
    begin       scalar q;
        if null b then interr "Attempt to divide by zero";
        q:=sqrtlist; %remove sqrts from denominator, maybe.
        while not null q do begin 
            scalar conj; 
            conj:=conjsqrt(b,car q); %conjugate wrt given sqrt
            if not (b=conj) then << 
                a:=multdf(a,conj); 
                b:=multdf(b,conj) >>; 
            q:=cdr q end; 
        q:=dfquotdf2(a,b);
        residue:=reversewoc residue;
        return q
    end;

symbolic procedure dfquotdf2(a,b);
% As above but a and b are distributed forms, as is the result.
    if null a then nil
    else begin scalar xd,lcd;
        xd:=xpdiff(lpow a,lpow b);
        if xd='failed then <<
            xd:=lt a; a:=red a;
            residue:=xd .+ residue;
            return dfquotdf2(a,b) >>;
        lcd:= !*multsq(lc a,!*invsq lc b);
        if null numr lcd then return dfquotdf2(red a,b);
           % Should not be necessary;
        lcd := xd .* lcd;
        xd:=plusdf(a,multdf(negdf (lcd .+ nil),b));
        if xd and (lpow xd = lpow a % Again, should not be necessary;
                   or xpdiff(lpow xd,lpow b) = 'failed)
          then <<if !*trint or !*trdiv
                   then <<printc "Dfquotdf trouble:"; printdf xd>>;
                 xd := rootextractdf xd;
                 if !*trint or !*trdiv then printdf xd>>;
        return lcd .+ dfquotdf2(xd,b)
    end;

symbolic procedure rootextractdf u;
   if null u then nil
    else begin scalar v;
      v := resimp rootextractsq lc u;
      return if null numr v then rootextractdf red u
              else (lpow u .* v) .+ rootextractdf red u
    end;

symbolic procedure rootextractsq u;
   if null numr u then u
    else rootextractf numr u ./ rootextractf denr u;

symbolic procedure rootextractf v;
   if domainp v then v
    else begin scalar u,r,c,x,p;
      u := mvar v;  p := ldeg v;
      r := rootextractf red v;
      c := rootextractf lc v;
      if null c then return r
       else if atom u then return (lpow v .* c) .+ r
       else if car u eq 'sqrt
        or car u eq 'expt and eqcar(caddr u,'quotient)
           and car cdaddr u = 1 and numberp cadr cdaddr u
        then <<p := divide(p,if car u eq 'sqrt then 2
                              else cadr cdaddr u);
      if car p = 0 
        then return if null c then r else (lpow v .* c) .+ r
       else if numberp cadr u
        then <<c := multd(cadr u ** car p,c); p := cdr p>>
       else <<x := simpexpt list(cadr u,car p);
              if denr x = 1
                then <<c := multf(numr x,c); p := cdr p>>>>>>;
      return if p=0 then addf(c,r)
              else if null c then r
              else ((u to p) .* c) .+ r
   end;

% The following hack makes sure that the results of differentiation
% gets passed through ROOTEXTRACT
% a) This should not be done this way, since the effect is global
% b) Should this be done via TIDYSQRT?

put('df,'simpfn,'simpdf!*);

symbolic procedure simpdf!* u;
  begin scalar v,v1;
        v:=simpdf u;
        v1:=rootextractsq v;
        if not(v1=v) then return resimp v1
        else return v
end;

symbolic procedure xpdiff(a,b);
%Result is list a-b, or 'failed' if a member of this would be negative.
    if null a then if null b then nil
        else interr "B too long in xpdiff"
    else if null b then interr "A too long in xpdiff"
    else if car b>car a then 'failed
    else (lambda r;
        if r='failed then 'failed
        else (car a-car b) . r) (xpdiff(cdr a,cdr b));


symbolic procedure conjsqrt(b,var); 
% Subst(var=-var,b).
    if null b then nil 
    else conjterm(lpow b,lc b,var) .+ conjsqrt(red b,var); 
 
symbolic procedure conjterm(xl,coef,var); 
% Ditto but working on a term.
    if involvesp(xl,var,zlist) then xl .* negsq coef 
    else xl .* coef; 
 
symbolic procedure involvesp(xl,var,zl); 
% Check if exponent list has non-zero power for variable.
    if null xl then interr "Var not found in involvesp"
    else if car zl=var then (not zerop car xl) 
    else involvesp(cdr xl,var,cdr zl); 

endmodule;


module driver;  % Driving routines for integration program.

% Author: Mary Ann Moore and Arthur C. Norman.
% Modifications by: John P. Fitch.

fluid '(!*backtrace
        !*exp
        !*gcd
        !*keepsqrts
        !*mcd
        !*nolnr
        !*purerisch
        !*rationalize
        !*sqrt
        !*structure
        !*uncached
        basic!-listofnewsqrts
        basic!-listofallsqrts
        expression
        gaussiani
        intvar
        listofnewsqrts
        listofallsqrts
        loglist
        sqrt!-intvar
        sqrt!-places!-alist
        variable
        varlist
        xlogs
        zlist);

global '(!*algint !*failhard !*trint);

exports integratesq,simpint,purge,simpint1;

imports algebraiccase,algfnpl,findzvars,getvariables,interr,printsq,
  transcendentalcase,varsinlist,kernp,simpcar,prepsq,mksq,simp,
   opmtch,formlnr;

switch algint,nolnr,trint;

% Form is   int(expr,var,x1,x2,...);
% meaning is integrate expr wrt var, given that the result may
% contain logs of x1,x2,...
% x1, etc are intended for use when the system has to be helped
% in the case that expr is algebraic.
% Extended arguments x1, x2, etc., are not currently supported.

symbolic procedure simpint u;
% Simplifies an integral. First two components of U are the integrand
% and integration variable respectively. Optional succeeding components
% are log forms for the final integral;
    begin scalar ans,expression,variable,loglist,w,
                 !*purerisch,intvar,listofnewsqrts,listofallsqrts,
                 sqrtfn,sqrt!-intvar,sqrt!-places!-alist,
                 basic!-listofallsqrts,basic!-listofnewsqrts;
    if atom u or null cdr u then rederr "Not enough arguments for INT";
    variable := !*a2k cadr u;
    w := cddr u;
    if w then rederr "Too many arguments to INT";
    listofnewsqrts:= list mvar gaussiani; % Initialize for SIMPSQRT.
    listofallsqrts:= list (argof mvar gaussiani . gaussiani);
    sqrtfn := get('sqrt,'simpfn);
    put('sqrt,'simpfn,'proper!-simpsqrt);
    % We need explicit settings of several switches during integral
    % evaluation.  In addition, the current code cannot handle domains
    % like floating point, so we suppress it while the integral is
    % calculated.  UNCACHED is turned on since integrator does its own
    % caching.
    begin scalar dmode!*,!*exp,!*gcd,!*keepsqrts,!*mcd,!*sqrt,
                 !*rationalize,!*structure,!*uncached;
       !*keepsqrts := !*sqrt := t;
       !*exp := !*gcd := !*mcd := !*structure := !*uncached := t;
       dmode!* := nil;
       if !*algint
         then <<intvar:=variable;           % until fix JHD code
            % Start a clean slate (in terms of SQRTSAVE) for this integral
            sqrt!-intvar:=!*q2f simpsqrti variable;
            if (red sqrt!-intvar) or (lc sqrt!-intvar neq 1)
                or (ldeg sqrt!-intvar neq 1)
              then interr "Sqrt(x) not properly formed"
              else sqrt!-intvar:=mvar sqrt!-intvar;
            basic!-listofallsqrts:=listofallsqrts;
            basic!-listofnewsqrts:=listofnewsqrts;
            sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts,
                         list(variable . variable))>>;
       expression := int!-simp car u;
   %   loglist := for each x in w collect int!-simp x;
       ans := errorset('(integratesq expression variable loglist),
                       !*backtrace,!*backtrace);
    end;
    if errorp ans
      then return <<put('sqrt,'simpfn,sqrtfn);
                    if !*failhard then error1();
                    simpint1(expression . variable . w)>>
     else ans := car ans;
    expression := sqrtchk numr ans ./ sqrtchk denr ans;
    % We now need to check that all simplifications have been done
    % but we have to make sure INT is not resimplified.
    put('int,'simpfn,'simpiden);
    ans := errorset('(resimp expression),t,!*backtrace);
    put('int,'simpfn,'simpint);
    put('sqrt,'simpfn,sqrtfn);
    return if errorp ans then error1() else car ans
   end;

symbolic procedure sqrtchk u;
   % U is a standard form. Result is another standard form with square
   % roots replaced by half powers.
   if domainp u then u
    else if not eqcar(mvar u,'sqrt)
     then addf(multpf(lpow u,sqrtchk lc u),sqrtchk red u)
    else addf(multpf(mksp(list('expt,cadr mvar u,'(quotient 1 2)),
                          ldeg u),
                     sqrtchk lc u),
              sqrtchk red u);

symbolic procedure int!-simp u;
   %converts U to canonical form, including the resimplification of
   % *sq forms;
   subs2 resimp simp!* u;

put('int,'simpfn,'simpint);


symbolic procedure integratesq(integrand,var,xlogs);
 begin scalar varlist,zlist;
    if !*trint then <<
        printc "Integrand is...";
        printsq integrand >>;
    varlist:=getvariables integrand;
    varlist:=varsinlist(xlogs,varlist); %in case more exist in xlogs
    zlist:=findzvars(varlist,list var,var,nil); %important kernels
%the next section causes problems with nested exponentials or logs;
    begin scalar oldzlist;
        while oldzlist neq zlist do <<
            oldzlist:=zlist;
            foreach zz in oldzlist do
             zlist:=findzvars(distexp(pseudodiff(zz,var)),zlist,var,t)>>
    end;
    if !*trint  then <<
      printc "with 'new' functions :";
      print zlist >>;
    if !*purerisch and not allowedfns zlist
      then return simpint1 (integrand . var.nil);
      % If it is not suitable for Risch;
    varlist:=purge(zlist,varlist);
% Now zlist is list of things that depend on x, and varlist is list
% of constant kernels in integrand;
    if !*algint and cdr zlist and algfnpl(zlist,var)
      then return algebraiccase(integrand,zlist,varlist)
     else return transcendentalcase(integrand,var,xlogs,zlist,varlist)
 end;

symbolic procedure distexp(l);
    if null l then nil
    else if atom car l then car l . distexp cdr l
    else if (caar l = 'expt) and (cadar l = 'e) then 
        begin scalar ll;
            ll:=caddr car l;
            if eqcar(ll,'plus) then <<
                ll:=foreach x in cdr ll collect list('expt,'e,x);
                return ('times . ll) . distexp cdr l >>
            else return car l . distexp cdr l
        end
    else distexp car l . distexp cdr l;

symbolic procedure pseudodiff(a,var);
    if atom a then nil
    else if car a memq '(atan equal log plus quotient sqrt times)
        then begin scalar aa,bb;
            foreach zz in cdr a do <<
                bb:=pseudodiff(zz,var);
                if aa then aa:=bb . aa else bb >>;
            return aa
        end
      else if car a eq 'expt
        then if depends(cadr a,var) then
            prepsq simp list('log,cadr a) .
            cadr a .
            caddr a .
            append(pseudodiff(cadr a,var),pseudodiff(caddr a,var))
        else caddr a . pseudodiff(caddr a,var)
    else list prepsq simpdf(list(a,var));

symbolic procedure simpint1 u;
   begin scalar v,!*sqrt;
      u := 'int . prepsq car u . cdr u;
      if (v := formlnr u) neq u
        then if !*nolnr
               then <<v:= simp subst('int!*,'int,v);
                      return remakesf numr v ./ remakesf denr v>>
              else <<!*nolnr:= nil . !*nolnr;
                     u:=errorset(list('simp,mkquote v),
                                 !*backtrace,!*backtrace);
                     if pairp u then v:=car u;
                     !*nolnr:= cdr !*nolnr;
                     return v>>;
      return if (v := opmtch u) then simp v
              else if !*failhard then rederr "FAILHARD switch set"
              else mksq(u,1)
   end;

mkop 'int!*;

put('int!*,'simpfn,'simpint!*);

symbolic procedure simpint!* u;
   begin scalar x;
      return if (x := opmtch('int . u)) then simp x
              else simpiden('int!* . u)
   end;

symbolic procedure remakesf u;
   %remakes standard form U, substituting operator INT for INT!*;
   if domainp u then u
    else addf(multpf(if eqcar(mvar u,'int!*)
                       then mksp('int . cdr mvar u,ldeg u)
                      else lpow u,remakesf lc u),
               remakesf red u);

symbolic procedure allowedfns u;
if null u
  then t
  else if atom car u or
      flagp(caar u,'transcendental)
    then allowedfns cdr u
    else nil;


symbolic procedure purge(a,b);
    if null a then b
    else if null b then nil
    else purge(cdr a,delete(car a,b));

endmodule;


module d3d4;   % Splitting of cubics and quartics.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(knowndiscrimsign zlist);

global '(!*trint);

exports cubic,quartic;

imports covecdf,cuberootf,nth,forceazero,makepolydf,multdf,multdfconst,
   !*multf,negdf,plusdf,printdf,printsf,quadratic,sqrtf,vp1,vp2,addf,
   negf;

symbolic procedure cubic(pol,var,res);
%Split the univariate (wrt z-vars) cubic pol, at least if a
%change of origin puts it in the form (x-a)**3-b=0;
    begin       scalar a,b,c,d,v,shift,p;
        v:=covecdf(pol,var,3);
        shift:=forceazero(v,3); %make coeff x**2 vanish.
                                %also checks univariate.
%       if shift='failed then go to prime;
        a:=getv(v,3); b:=getv(v,2); %=0, I hope!;
        c:=getv(v,1); d:=getv(v,0);
        if !*trint then << printc "Cubic has coefficients";
            printsf a; printsf b;
            printsf c; printsf d >>;
        if not null c then <<
            if !*trint then printc "Cubic too hard to split";
            go to exit >>;
        a:=cuberootf(a); %can't ever fail;
        d:=cuberootf(d);
        if !*trint then << printc "Cube roots of a and d are";
            printsf a; printsf d>>;
        %now a*(x+shift)+d is a factor of pol;
        %create x+shift in p;
        p:=(vp2 zlist .* shift) .+ nil;
        p:=(vp1(var,1,zlist) .* (1 ./ 1)) .+ p; %(x+shift);
        b:=nil;
        b:=(vp2 zlist .* (d ./ 1)) .+ b;
        b:=plusdf(b,multdfconst(a ./ 1,p));
        b:=makepolydf b; %get rid of denominator.
        if !*trint then << printc "One factor of the cubic is";
            printdf b >>;
        res:=('log . b) . res;
        %now form the (quadratic) cofactor;
        b:=(vp2 zlist .* (!*multf(d,d) ./ 1)) .+ nil;
        b:=plusdf(b,multdfconst(negf !*multf(a,d) ./ 1,p));
        b:=plusdf(b,multdfconst(!*multf(a,a) ./ 1,
                                multdf(p,p)));
        return quadratic(makepolydf b,var,res); %deal with what is left;
   prime:
        if !*trint then printc "The following cubic does not split";
  exit:
        if !*trint then printdf pol;
        return ('log . pol) . res
    end;

symbolic procedure quartic(pol,var,res);
%Splits univariate (wrt z-vars) quartics that can be written
%in the form (x-a)**4+b*(x-a)**2+c;
    begin       scalar a,b,c,d,ee,v,shift,p,q,p1,p2,dsc;
        v:=covecdf(pol,var,4);
        shift:=forceazero(v,4); %make coeff x**3 vanish;
%       if shift='failed then go to prime;
        a:=getv(v,4); b:=getv(v,3); %=0, I hope.
        c:=getv(v,2); d:=getv(v,1);
        ee:=getv(v,0);
        if !*trint then << printc "Quartic has coefficients";
            printsf a; printsf b;
            printsf c; printsf d;
            printsf ee >>;
        if d
          then <<if !*trint then printc "Quartic too hard to split";
                 go to exit >>;
        b:=c; c:=ee; %squash up the notation;
        if knowndiscrimsign eq 'negative then go to complex;
        dsc := addf(!*multf(b,b),multf(-4,!*multf(a,c)));
        p2 := minusf c;
        if not p2 and minusf dsc then go to complex;
        p1 := null b or minusf b;
        if not p1 then if p2 then p1 := t else p2 := t;
        p1 := if p1 then 'positive else 'negative;
        p2 := if p2 then 'negative else 'positive;
        a := sqrtf a;
        dsc := sqrtf dsc;
        if a eq 'failed or dsc eq 'failed then go to prime;
        ee := invsq(addf(a,a) ./ 1);
        d := multsq(addf(b,negf dsc) ./ 1,ee);
        ee := multsq(addf(b,dsc) ./ 1,ee);
        if !*trint
          then <<printc "Quadratic factors will have coefficients";
                 printsf a; print 0; printsq d;
                 printc "or"; printsq ee>>;
        p := (vp2 zlist .* shift) .+ nil;
        p := (vp1(var,1,zlist) .* (1 ./ 1)) .+ p; %(x+shift);
        q := multdf(p,p);   %square of same;
        q := multdfconst(a ./ 1,q);
        p := plusdf(q,(vp2 zlist .* d) .+ nil);
        q := plusdf(q,(vp2 zlist .* ee) .+ nil);
        if !*trint
          then <<printc "Allowing for change of origin:";
                 printdf p; printdf q>>;
        knowndiscrimsign := p1;
        res := quadratic(p,var,res);
        knowndiscrimsign := p2;
        res := quadratic(q,var,res);
        go to quarticdone;
 complex:
        a:=sqrtf(a);
        c:=sqrtf(c);
        if a eq 'failed or c eq 'failed then go to prime;
        b:=addf(!*multf(2,!*multf(a,c)),negf b);
        b:=sqrtf b;
        if b eq 'failed then go to prime;
%now a*(x+shift)**2 (+/-) b*(x+shift) + c is a factor.
        if !*trint
          then << printc "Quadratic factors will have coefficients";
            printsf a; printsf b; printsf c>>;
        p:=(vp2 zlist .* shift) .+ nil;
        p:=(vp1(var,1,zlist) .* (1 ./ 1)) .+ p; %(x+shift);
        q:=multdf(p,p); %square of same;
        p:=multdfconst(b ./ 1,p);
        q:=multdfconst(a ./ 1,q);
        q:=plusdf(q,(vp2 zlist .* (c ./ 1)) .+ nil);
        if !*trint then <<
            printc "Allowing for change of origin, p (+/-) q with p,q=";
            printdf p; printdf q>>;
%now p+q and p-q are the factors of the quartic;
        knowndiscrimsign := 'negative;
        res:=quadratic(plusdf(q,p),var,res);
        res:=quadratic(plusdf(q,negdf p),var,res);
 quarticdone:
        knowndiscrimsign := nil;
        if !*trint then printc "Quartic done";
        return res;
    prime:
        if !*trint then printc "The following quartic does not split";
   exit:
        if !*trint then printdf pol;
        return ('log . pol) . res
    end;

endmodule;


module factr;   % Crude factorization routine for integrator.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(zlist);

global '(!*trint);

exports int!-fac,var2df;

imports cubic,df2q,f2df,interr,multdf,printdf,quadratic,quartic,unifac,
   uniform,vp1,vp2,sub1;

symbolic procedure int!-fac x;
% Input: primitive, square-free polynomial (s.form).
%output:
% list of 'factors' wrt zlist
% each item in this list is either
%     log . sq
% or  atan . sq
% and these logs and arctans are all that is needed in the
% integration of 1/(argument).
    begin         scalar res,pol,dset,var,degree,vars;
        pol:=f2df x; %convert to distributed form
        dset:=degreeset(pol);
%now extract factors of the form 'x' or 'log(x)' etc;
%these correspond to items in dset with a non-zero cdr.
        begin    scalar zl,ds;
           zl:=zlist; ds:=dset;
           while not null ds do <<
               if onep cdar ds then <<
                   res:=('log . var2df(car zl,1,zlist)) . res;
                        %record in answer.
                   pol:=multdf(var2df(car zl,-1,zlist),pol);
                         %divide out.
                   if !*trint then << printc "Trivial factor found";
                       printdf cdar res>>;
                   rplaca(ds,sub1 caar ds . cdar ds) >>
               else if null zerop cdar ds then
                  interr "Repeated trivial factor in arg to factor";
               zl:=cdr zl; ds:=cdr ds >>;
        end; %single term factors all removed now.
        dset:=mapcar(dset,function car); %get lower bounds.
        if !*trint
          then printc ("Upper bounds of remaining factors are now: " .
                         dset);
        if dset=vp2 zlist then go to finished; %thing left is constant.
        begin    scalar ds,zl;
            var:=car zlist; degree:=car dset;
            if not zerop degree then vars:=var . vars;
            ds:=cdr dset; zl:=cdr zlist;
            while not null ds do <<
                if not zerop car ds then <<
                    vars:=car zl . vars;
                    if zerop degree or degree>car ds then <<
                        var:=car zl; degree:=car ds >> >>;
                zl:=cdr zl; ds:=cdr ds >>
        end;
% Now var is variable that this poly involves to lowest degree.
% Degree is the degree of the poly in same variable.
        if !*trint
          then printc ("Best var is " . var . "with exponent " .
                         degree);
        if onep degree then <<
            res:=('log . pol) . res; %certainly irreducible.
            if !*trint
              then << printc "The following is certainly irreducible";
                printdf pol>>;
            go to finished >>;
        if degree=2 then <<
            if !*trint then << printc "Quadratic";
                printdf pol>>;
            res:=quadratic(pol,var,res);
            go to finished >>;
        dset:=uniform(pol,var);
        if not (dset='failed) then <<
            if !*trint then << printc "Univariate polynomial";
                printdf pol >>;
            res:=unifac(dset,var,degree,res);
            go to finished >>;
        if not null cdr vars then go to nasty; %only try univariate now.
        if degree=3 then <<
            if !*trint then << printc "Cubic";
                printdf pol>>;
            res:=cubic(pol,var,res);
%           if !*overlaymode then excise 'd3d4;
            go to finished >>;
        if degree=4 then <<
            if !*trint then << printc "Quartic";
                printdf pol>>;
            res:=quartic(pol,var,res);
%           if !*overlaymode then excise 'd3d4;
            go to finished>>;
%else abandon hope and hand back some rubbish.
nasty:
        res:=('log . pol) . res;
        printc
          "The following polynomial has not been properly factored";
        printdf pol;
        go to finished;


   finished: %res is a list of d.f. s as required
        pol:=nil; %convert back to standard forms
        while not null res do
            begin         scalar type,arg;
            type:=caar res; arg:=cdar res;
            arg:=df2q arg;
            if type='log then rplacd(arg,1);
            pol:=(type . arg) . pol;
            res:=cdr res end;
        return pol
    end;


symbolic procedure var2df(var,n,zlist);
    ((vp1(var,n,zlist) .* (1 ./ 1)) .+ nil);

symbolic procedure degreeset pol;
% Finds degree bounds for all vars in distributed form poly.
    degreesub(dbl lpow pol,red pol);

symbolic procedure dbl x;
% Converts list of x into list of (x . x).
    if null x then nil
    else (car x . car x) . dbl cdr x;

symbolic procedure degreesub(cur,pol);
% Update degree bounds 'cur' to include info about pol.
    <<
        while not null pol do <<
            cur:=degreesub1(cur,lpow pol);
            pol:=red pol >>;
        cur >>;

symbolic procedure degreesub1(cur,nxt);
%Merge information from exponent set next into cur.
    if null cur then nil
    else degreesub2(car cur,car nxt) . degreesub1(cdr cur,cdr nxt);

symbolic procedure degreesub2(two,one);
    max(car two,one) . min(cdr two,one);

endmodule;


module ibasics;   % Some basic support routines for integrator.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(!*backtrace !*gcd !*sqfree indexlist sqrtflag sqrtlist 
        varlist zlist);

global '(!*trint);

exports partialdiff,printdf,rationalintegrate,interr;

imports df2printform,printsf,varsinsf,addsq,multsq,multd,mksp;

symbolic procedure printdf u;
% Print distributed form via cheap conversion to reduce structure.
    begin scalar !*gcd;
       printsf df2printform u;
    end;


symbolic procedure !*n2sq(u1);
if u1=0 then nil . 1 else u1 . 1;


symbolic procedure indx(n);
if n<2 then (list 1) else(n . indx(isub1 n));


symbolic procedure interr mess;
   <<(!*trint or !*backtrace)
       and <<prin2 "***** INTEGRATION PACKAGE ERROR:  "; printc mess>>;
     error1()>>;


symbolic procedure rationalintegrate(x,var);
    begin         scalar n,d;
      n:=numr x; d:=denr x;
      if not var member varsinsf(d,nil) then
            return !*multsq(polynomialintegrate(n,var),1 ./ d);
      rederr "Rational integration not coded yet"
    end;


symbolic procedure polynomialintegrate(x,v);
% Integrate standard form. result is standard quotient.
    if null x then nil ./ 1
    else if atom x then ((mksp(v,1) .* 1) .+ nil) ./ 1
    else begin    scalar r;
      r:=polynomialintegrate(red x,v); % deal with reductum
      if v=mvar x then begin    scalar degree,newlt;
         degree:=1+tdeg lt x;
         newlt:=((mksp(v,degree) .* lc x) .+ nil) ./ 1; % up exponent
         r:=addsq(!*multsq(newlt,1 ./ degree),r)
         end
      else begin         scalar newterm;
        newterm:=(((lpow x) .* 1) .+ nil) ./ 1;
        newterm:=!*multsq(newterm,polynomialintegrate(lc x,v));
        r:=addsq(r,newterm)
        end;
      return r
    end;

symbolic procedure partialdiff(p,v);
% Partial differentiation of p wrt v - p is s.f. as is result.
    if domainp p then nil
    else
        if v=mvar p then
            (lambda x; if x=1 then lc p
             else ((mksp(v,x-1) .* multd(x,lc p))
                         .+ partialdiff(red p,v)))
            (tdeg lt p)
        else
            (lambda x; if null x then partialdiff(red p,v)
             else ((lpow p .* x) .+ partialdiff(red p,v)))
            (partialdiff(lc p,v));

put('pdiff,'simpfn,'simppdiff);

symbolic procedure ncdr(l,n);
  % we can use small integer arithmetic here.
  if n=0 then l else ncdr(cdr l,isub1 n);


symbolic procedure mkilist(old,term);
   if null old then nil
    else term.mkilist(cdr old,term);


%symbolic procedure addin(lista,first,listb);
%if null lista
% then nil
% else ((first.car listb).car lista).addin(cdr lista,first,cdr listb);



symbolic procedure removeduplicates(u);
  % Purges duplicates from the list passed to it.
if null u then nil
  else if (atom u) then u.nil
    else if member(car u,cdr u)
      then removeduplicates cdr u
      else (car u).removeduplicates cdr u;


symbolic procedure jsqfree(sf,var);
begin
  varlist:=getvariables(sf ./ 1);
  zlist:=findzvars(varlist,list var,var,nil);
  sqrtlist:=findsqrts varlist; % before the purge
  sqrtflag:=not null sqrtlist;
  varlist:=purge(zlist,varlist);
  if sf eq !*sqfree
    then return list list sf
    else return sqfree(sf,zlist)
  end;

symbolic procedure jfactor(sf,var);
begin
  scalar varlist,zlist,indexlist,sqrtlist,sqrtflag;
  scalar prim,answer,u,v; % scalar var2
  prim:=jsqfree(sf,var);
  indexlist:=createindices zlist;
  prim:=factorlistlist (prim,t);
  while prim do <<
    if caar prim eq 'log then <<
        u:=cdar prim;
        u:=!*multsq(numr u ./ 1,1 ./ cdr stt(numr u,var));
        v:=denr u;
        while not atom v do v:=lc v;
        if  (numberp v) and (0> v)
          then u:=(negf numr u) ./ (negf denr u);
        answer:=u.answer >>
      else if caar prim eq 'atan then <<
% We can ignore this, since we also get LOG (U**2+1) as another term.
       >>
      else interr "Unexpected term in jfactor";
    prim:=cdr prim >>;
  return answer
  end;


  symbolic procedure stt(u,x);
    if domainp u
      then if u eq nil
        then ((-1) . nil)
        else (0 . u)
      else if mvar u eq x
        then ldeg  u . lc u
        else if ordop(x,mvar u)
          then (0 . u)
          else begin
            scalar ltlc,ltrest;
            ltlc:=stt(lc u,x);
            ltrest:= stt(red u,x);
            if car ltlc = car ltrest then go to merge;
            if car ltlc > car ltrest
              then return car ltlc .
                               !*multf(cdr ltlc,(lpow u .* 1) .+ nil)
              else return ltrest;
          merge:
            return car ltlc.addf(cdr ltrest,
                                 !*multf(cdr ltlc,(lpow u .* 1) .+ nil))
            end;


symbolic procedure gcdinonevar(u,v,x);
% Gcd of u and v, regarded as polynnmials in x.
if null u
  then v
  else if null v
    then u
    else begin
      scalar u1,v1,z,w;
      u1:=stt(u,x);
      v1:=stt(v,x);
    loop:
      if (car u1) > (car v1)
        then go to ok;
      z:=u1;u1:=v1;v1:=z;
      z:=u;u:=v;v:=z;
    ok:
      if car v1 iequal 0
        then interr "Coprimeness in gcd";
      z:=gcdf(cdr u1,cdr v1);
      w:=quotf(cdr u1,z);
      if (car u1) neq (car v1)
        then w:=!*multf(w,!*p2f mksp(x,(car u1)-(car v1)));
      u:=addf(!*multf(v,w),
              !*multf(u,negf quotf(cdr v1,z)));
      if null u
        then return v;
      u1:=stt(u,x);
      go to loop
      end;


symbolic procedure mapply(funct,l);
   if null l then rederr "Empty list to mapply"
    else if null cdr l then car l
    else apply(funct,list(car l,mapply(funct,cdr l)));


symbolic procedure !*lcm!*(u,v);
!*multf(u,quotf(v,gcdf(u,v)));


symbolic procedure multsql(u,l);
% Multiplies (!*multsq) each element of l by u.
if null l
  then nil
  else !*multsq(u,car l).multsql(u,cdr l);


symbolic procedure intersect(x,y);
if null x then nil else if member(car x,y) then
    car(x) . intersect(cdr x,y) else
          intersect(cdr x,y);


symbolic procedure mapvec(v,f);
begin
  scalar n;
  n:=upbv v;
  for i:=0:n do
    apply(f,list getv(v,i))
  end;

endmodule;


module jpatches;   % Routines for manipulating sf's with power folding.

% Author: James H. Davenport.

fluid '(sqrtflag);

exports !*addsq,!*multsq,!*invsq,!*multf,squashsqrtsq,!*exptsq,!*exptf;

% !*MULTF(A,B) multiplies the polynomials (standard forms) U and V
% in much the same way as MULTF(U,V) would, EXCEPT...
%     (1) !*MULTF inhibits the action of OFF EXP and of non-commutative
%         multiplications
%     (2) Within !*MULTF powers of square roots, and powers of
%         exponential kernels are reduced as if substitution rules
%         such as FOR ALL X LET SQRT(X)**2=X were being applied;

% Note that !*MULTF comes between MULTF and !*Q2F SUBS2F MULTF in its
% behaviour, and that it is the responsibility of the user to call it
% in sensible places where its services are needed;

% similarly for the other functions defined here;


%symbolic procedure !*addsq(u,v);
   %U and V are standard quotients.
%  %Value is canonical sum of U and V;
%   if null numr u then v
%    else if null numr v then u
%    else if denr u=1 and denr v=1 then addf(numr u,numr v) ./ 1
%    else begin scalar nu,du,nv,dv,x;
%        x := gcdf(du:=denr u,dv:=denr v);
%        du:=quotf(du,x); dv:=quotf(dv,x);
%        nu:=numr u; nv:=numr v;
%        u:=addf(!*multf(nu,dv),!*multf(nv,du));
%        if u=nil then return nil ./ 1;
%        v:=!*multf(du,denr v);
%        return !*ff2sq(u,v)
%    end;

%symbolic procedure !*multsq(a,b);
%  begin
%    scalar n,d;
%    n:=!*multf(numr a,numr b);
%    d:=!*multf(denr a,denr b);
%    return !*ff2sq(n,d)
%  end;

%symbolic procedure !*ff2sq(a,b);
%  begin
%    scalar gg;
%    if null a then return nil ./ 1;
%    gg:=gcdf(a,b);
%    if not (gg=1) then <<
%        a:=quotf(a,gg);
%        b:=quotf(b,gg) >>;
%    if minusf b then <<
%        a:=negf a;
%        b:=negf b >>;
%    return a ./ b
%  end;

symbolic procedure !*addsq(u,v);
   %U and V are standard quotients.
   %Value is canonical sum of U and V;
   if null numr u then v
    else if null numr v then u
    else if denr u=1 and denr v=1 then addf(numr u,numr v) ./ 1
    else begin scalar du,dv,x,y,z;
        x := gcdf(du:=denr u,dv:=denr v);
        du:=quotf(du,x); dv:=quotf(dv,x);
        y:=addf(!*multf(dv,numr u),!*multf(du,numr v));
        if null y then return nil ./ 1;
        z:=!*multf(denr u,dv);
        if minusf z then <<y := negf y; z := negf z>>;
        if x=1 then return y ./ z;
        x := gcdf(y,x);
        return if x=1 then y ./ z else quotf(y,x) ./ quotf(z,x)
    end;

symbolic procedure !*multsq(u,v);
   %U and V are standard quotients. Result is the canonical product of
   %U and V with surd powers suitably reduced.
   if null numr u or null numr v then nil ./ 1
    else if denr u=1 and denr v=1 then !*multf(numr u,numr v) ./ 1
    else begin scalar w,x,y;
     x := gcdf(numr u,denr v);
     y := gcdf(numr v,denr u);
     w := !*multf(quotf(numr u,x),quotf(numr v,y));
     x := !*multf(quotf(denr u,y),quotf(denr v,x));
     if minusf x then <<w := negf w; x := negf x>>;
     y := gcdf(w,x);  % another factor may have been generated.
     return if y=1 then w ./ x else quotf(w,y) ./ quotf(x,y)
    end;

symbolic procedure !*invsq a;
   % Note that several examples (e.g., int(1/(x**8+1),x)) give a more
   % compact result when SQRTFLAG is true if SQRT2TOP is not called.
   if sqrtflag then sqrt2top invsq a else invsq a;

symbolic procedure !*multf(u,v);
  % U and V are standard forms
  % Value is SF for U*V;
  begin
    scalar x,y;
      if null u or null v
      then return nil
      else if u = 1
        then return squashsqrt v
        else if v = 1
        then return squashsqrt u
        else if domainp u
          then return multd(u,squashsqrt v)
          else if domainp v
            then return multd(v,squashsqrt u);
      x:=mvar u;
      y:=mvar v;
      if x eq y
        then go to c
        else if ordop(x,y)
          then go to b;
      x:=!*multf(u,lc v);
      y:=!*multf(u,red v);
      return if null x then y
              else if not domainp lc v
                and mvar u eq mvar lc v
                and not atom mvar u
                and car mvar u memq '(expt sqrt)
               then addf(!*multf(x,!*p2f lpow v),y) % what about noncom?
              else makeupsf(lpow v,x,y);
  b:  x:=!*multf(lc u,v);
      y:=!*multf(red u,v);
      return if null x then y
              else if not domainp lc u
                and mvar lc u eq mvar v
                and not atom mvar v
                and car mvar v memq '(expt sqrt)
               then addf(!*multf(!*p2f lpow u,x),y)
              else makeupsf(lpow u,x,y);
  c:  y:=addf(!*multf(list lt u,red v),!*multf(red u,v));
      if eqcar(x,'sqrt)
        then return addf(squashsqrt y,!*multfsqrt(x,
                        !*multf(lc u,lc v),ldeg u + ldeg v))
        else if eqcar(x,'expt) and prefix!-rational!-numberp caddr x
          then return addf(squashsqrt y,!*multfexpt(x,
                        !*multf(lc u,lc v),ldeg u + ldeg v));
      x:=mkspm(x,ldeg u + ldeg v);
      return if null x or null (u:=!*multf(lc u,lc v))
               then y
               else x .* u .+ y
    end;

symbolic procedure makeupsf(u,x,y);
% Makes u .* x .+ y  except when u is not a valid lpow (because of
% sqrts).
   if atom car u or cdr u = 1 then u .* x .+ y
     else if caar u eq 'sqrt then addf(!*multfsqrt(car u,x,cdr u),y)
       else if <<begin scalar v;
                    v:=car u;
                    if car v neq 'expt then return nil;
                    v:=caddr v;
                    if atom v then return nil;
                    return (car v eq 'quotient 
                            and numberp cadr v
                            and numberp caddr v)
                 end >>
         then addf(!*multfexpt(car u,x,cdr u),y)
         else u .* x .+ y;


symbolic procedure !*multfsqrt(x,u,w);
   % This code (Due to Norman a& Davenport) squashes SQRT(...)**2.
   begin scalar v;
     w:=divide(w,2);
     v:=!*q2f simp cadr x;
     u:=!*multf(u,exptf(v,car w));
     if not zerop cdr w then u:=!*multf(u,!*p2f mksp(x,1));
     return u
   end;


symbolic procedure !*multfexpt(x,u,w);
  begin scalar expon,v;
    expon:=caddr x;
    x:=cadr x;
    w:=w * cadr expon;
    expon:=caddr expon;
    v:=gcdn(w,expon);
    w:=w/v;
    v:=expon/v;
    if not (w > 0) then rederr "Invalid exponent"
     else if v = 1
      then return !*multf(u,exptf(if numberp x then x
                                    else if atom x then !*k2f x
                                    else !*q2f if car x eq '!*sq
                                                 then argof x
                                                else simp x,
                          w));
    expon:=0;
    while not (w < v) do <<expon:=expon + 1; w:=w-v>>;
    if expon>0 then u:=!*multf(u,exptf(!*q2f simp x,expon));
    if w = 0 then return u;
    x:=list('expt,x,list('quotient,1,v));
    return multf(squashsqrt u,!*p2f mksp(x,w))
  end;


symbolic procedure prefix!-rational!-numberp u;
  % Tests for m/n in prefix representation.
    eqcar(u,'quotient) and numberp cadr u and numberp caddr u;


symbolic procedure squashsqrtsq sq;
!*multsq(squashsqrt numr sq ./ 1,
         1 ./ squashsqrt denr sq);


symbolic procedure squashsqrt sf;
if (not sqrtflag) or atom sf or atom mvar sf
  then sf
  else if car mvar sf eq 'sqrt and ldeg sf > 1
    then addf(squashsqrt red sf,!*multfsqrt(mvar sf,lc sf,ldeg sf))
    else if car mvar sf eq 'expt
       and prefix!-rational!-numberp caddr mvar sf
       and ldeg sf >= caddr caddr mvar sf
      then addf(squashsqrt red sf,!*multfexpt(mvar sf,lc sf,ldeg sf))
      else (lpow sf .* squashsqrt lc sf) .+ squashsqrt red sf;




%remd 'simpx1;

%symbolic procedure simpx1(u,m,n);
%   %u,m and n are prefix expressions;
%   %value is the standard quotient expression for u**(m/n);
%   begin scalar flg,z;
%        if null frlis!* or null xn(frlis!*,flatten (m . n))
%          then go to a;
%        exptp!* := t;
%        return !*k2q list('expt,u,if n=1 then m
%                                   else list('quotient,m,n));
%    a:  if numberp m and fixp m then go to e
%         else if atom m then go to b
%         else if car m eq 'minus then go to mns
%         else if car m eq 'plus then go to pls
%         else if car m eq 'times and numberp cadr m and fixp cadr m
%                and numberp n
%          then go to tms;
%    b:  z := 1;
%    c:  if atom u and not numberp u then flag(list u,'used!*);
%        u := list('expt,u,if n=1 then m else list('quotient,m,n));
%        if not u member exptl!* then exptl!* := u . exptl!*;
%    d:  return mksq(u,if flg then -z else z); %u is already in lowest
%%       %terms;
%    e:  if numberp n and fixp n then go to int;
%        z := m;
%        m := 1;
%        go to c;
%    mns: m := cadr m;
%        if !*mcd then return invsq simpx1(u,m,n);
%        flg := not flg;
%        go to a;
%    pls: z := 1 ./ 1;
%    pl1: m := cdr m;
%        if null m then return z;
%        z := multsq(simpexpt list(u,
%                        list('quotient,if flg then list('minus,car m)
%                                        else car m,n)),
%                    z);
%        go to pl1;
%    tms: z := gcdn(n,cadr m);
%        n := n/z;
%        z := cadr m/z;
%        m := retimes cddr m;
%        go to c;
%    int:z := divide(m,n);
%        if cdr z<0 then z:= (car z - 1) . (cdr z+n);
%        if 0 = cdr z
%          then return simpexpt list(u,car z);
%        if n = 2
%          then return multsq(simpexpt list(u,car z),
%                             simpsqrti u);
%        return multsq(simpexpt list(u,car z),
%                        mksq(list('expt,u,list('quotient,1,n)),cdr z))
%   end;

symbolic procedure !*exptsq(a,n);
% raise A to the power N using !*MULTSQ;
    if n=0 then 1 ./ 1
    else if n=1 then a
    else if n<0 then !*exptsq(invsq a,-n)
    else begin
      scalar q,r;
      q:=divide(n,2);
      r:=cdr q; q:=car q;
      q:=!*exptsq(!*multsq(a,a),q);
      if r=0 then return q
      else return !*multsq(a,q)
    end;


symbolic procedure !*exptf(a,n);
% raise A to the power N using !*MULTF;
    if n=0 then 1
    else if n=1 then a
    else begin
      scalar q,r;
      q:=divide(n,2);
      r:=cdr q; q:=car q;
      q:=!*exptf(!*multf(a,a),q);
      if r=0 then return q
      else return !*multf(a,q)
    end;

endmodule;


module hacksqrt;  % Routines for manipulation of sqrt expressions.

% Author: James H. Davenport.

fluid '(nestedsqrts thisplace);

exports sqrtsintree,sqrtsinsq,sqrtsinsql,sqrtsinsf,sqrtsign;
exports degreenest,sortsqrts;

imports mkvect,interr,getv,dependsp,union;

symbolic procedure sqrtsintree(u,var,slist);
% Adds to slist all the sqrts in the prefix-type tree u.
if atom u
  then slist
  else if car u eq '!*sq
    then union(slist,sqrtsinsq(cadr u,var))
    else if car u eq 'sqrt
      then if dependsp(argof u,var)
        then <<
          slist:=sqrtsintree(argof u,var,slist);
          %  nested square roots
          if member(u,slist)
            then slist
            else u.slist >>
        else slist
      else sqrtsintree(car u,var,sqrtsintree(cdr u,var,slist));


symbolic procedure sqrtsinsq(u,var);
   % Returns list of all sqrts in sq.
   sqrtsinsf(denr u,sqrtsinsf(numr u,nil,var),var);


symbolic procedure sqrtsinsql(u,var);
% Returns list of all sqrts in sq list.
if null u
  then nil
  else sqrtsinsf(denr car u,
      sqrtsinsf(numr car u,sqrtsinsql(cdr u,var),var),var);


symbolic procedure sqrtsinsf(u,slist,var);
% Adds to slist all the sqrts in sf.
if domainp u or null u
  then slist
  else <<
    if  eqcar(mvar u,'sqrt) and
        dependsp(argof mvar u,var) and
        not member(mvar u,slist)
      then begin
        scalar slist2;
        slist2:=sqrtsintree(argof mvar u,var,nil);
        if slist2
          then <<
            nestedsqrts:=t;
            slist:=union(slist2,slist) >>;
        slist:=(mvar u).slist
        end;
    sqrtsinsf(lc u,sqrtsinsf(red u,slist,var),var) >>;


symbolic procedure easysqrtsign(slist,things);
% This procedure builds a list of all substitutions for all possible
% combinations of square roots in list.
if null slist
  then things
  else easysqrtsign(cdr slist,
                    nconc(mapcons(things,(car slist).(car slist)),
                          mapcons(things,
                                  list(car slist,'minus,car slist))));

symbolic procedure hardsqrtsign(slist,things);
% This procedure fulfils the same role for nested sqrts
% ***assumption: the simpler sqrts come further up the list.
if null slist
  then things
  else begin
    scalar thisplace,answers,pos,neg;
    thisplace:=car slist;
    answers:=mapcar(things,function (lambda u;sublis(u,thisplace).u));
    pos:=mapcar(answers,function (lambda u;(thisplace.car u).(cdr u)));
    % pos is sqrt(f) -> sqrt(innersubst f)
    neg:=mapcar(answers,
        function (lambda u;list(thisplace,'minus,car u).(cdr u)));
    % neg is sqrt(f) -> -sqrt(innersubst f)
    return hardsqrtsign(cdr slist,nconc(pos,neg))
    end;


symbolic procedure degreenest(pf,var);
% Returns the maximum degree of nesting of var
% inside sqrts in the prefix form pf.
if atom pf
  then 0
  else if car pf eq 'sqrt
    then if dependsp(cadr pf,var)
      then iadd1 degreenest(cadr pf,var)
      else 0
    else if car pf eq 'expt
      then if dependsp(cadr pf,var)
        then if eqcar(caddr pf,'quotient)
          then iadd1 degreenest(cadr pf,var)
          else degreenest(cadr pf,var)
        else 0
      else degreenestl(cdr pf,var);

symbolic procedure degreenestl(u,var);
%Returns max degreenest from list of pfs u.
if null u
  then 0
  else max(degreenest(car u,var),
           degreenestl(cdr u,var));


symbolic procedure sortsqrts(u,var);
% Sorts list of sqrts into order required by hardsqrtsign
% (and many other parts of the package).
begin
  scalar i,v;
  v:=mkvect(10); %should be good enough!
  while u do <<
    i:=degreenest(car u,var);
    if i iequal 0
      then interr "Non-dependent sqrt found";
    if i > 10
      then interr
         "Degree of nesting exceeds 10 (recompile with 10 increased)";
    putv(v,i,(car u).getv(v,i));
    u:=cdr u >>;
  u:=getv(v,10);
  for i :=9 step -1 until 1 do
    u:=nconc(getv(v,i),u);
  return u
  end;


symbolic procedure sqrtsign(sqrts,x);
   if nestedsqrts then hardsqrtsign(sortsqrts(sqrts,x),list nil)
    else easysqrtsign(sqrts,list nil);

endmodule;


module kron;   % Kronecker factorization of univ. polys over integers.

% Authors: Mary Ann Moore and Arthur C. Norman.

global '(!*trint);

exports linfac,quadfac;

imports zfactor;

% Only linear and quadratic factors are found.

symbolic procedure linfac(w);
    trykr(w,'(0 1));

symbolic procedure quadfac(w);
    trykr(w,'(-1 0 1));

symbolic procedure trykr(w,points);
%Look for factor of w by evaluation at (points) and use of
% interpolate. Return (fac . cofac) with fac=nil if none
% found and cofac=nil if nothing worthwhile is left.
    begin         scalar values,attempt;
        if null w then return nil . nil;
        if  (length points > car w) then return w . nil;
%that says if w is already tiny, it is already factored.
        values:=mapcar(points,function (lambda x;
           evalat(w,x)));
        if !*trint then << printc ("At x= " . points);
            printc ("p(x)= " . values)>>;
        if 0 member values then go to lucky; %(x-1) is a factor!
        values:=mapcar(values,function zfactors);
        rplacd(values,mapcar(cdr values,function (lambda y;
            append(y,mapcar(y,function minus)))));
        if !*trint then <<printc "Possible factors go through some of";
            print values>>;
        attempt:=search4fac(w,values,nil);
        if null attempt then attempt:=nil . w;
        return attempt;
  lucky: %here (x-1) is a factor because p(0) or p(1) or p(-1)
         %vanished and cases p(0), p(-1) will have been removed
         %elsewhere.
        attempt:='(1 1 -1); %the factor
        return attempt . testdiv(w,attempt)
    end;

symbolic procedure zfactors n;
% Produces a list of all (positive) integer factors of the integer n.
    if n=0 then list 0
    else if (n:=abs n)=1 then list 1
    else combinationtimes zfactor n;

symbolic procedure search4fac(w,values,cv);
% Combinatorial search. cv gets current selected value-set.
% Returns nil if fails, else factor . cofactor.
    if null values then tryfactor(w,cv)
    else begin    scalar ff,q;
        ff:=car values; %try all values here
 loop:  if null ff then return nil; %no factor found
        q:=search4fac(w,cdr values,(car ff) . cv);
        if null q then << ff:=cdr ff; go to loop>>;
        return q
    end;

symbolic procedure tryfactor(w,cv);
 % Tests if cv represents a factor of w.
    begin         scalar ff,q;
        if null cddr cv then ff:=linethrough(cadr cv,car cv)
        else ff:=quadthrough(caddr cv,cadr cv,car cv);
        if ff='failed then return nil; %it does not interpolate
        q:=testdiv(w,ff);
        if q='failed then return nil; %not a factor
        return ff . q
    end;

symbolic procedure evalat(p,n);
  % Evaluate polynomial at integer point n.
    begin         scalar r;
        r:=0;
        p:=cdr p;
        while not null p do <<
            r:=n*r+car p;
            p:=cdr p >>;
        return r
    end;

symbolic procedure testdiv(a,b);
% Quotient a/b or failed.
    begin         scalar q;
        q:=testdiv1(cdr a,car a,cdr b,car b);
        if q='failed then return q;
        return (car a-car b) . q
    end;

symbolic procedure testdiv1(a,da,b,db);
    if da<db then begin
    check0: if null a then return nil
            else if not zerop car a then return 'failed;
            a:=cdr a;
            go to check0
        end
    else begin    scalar q;
        q:=divide(car a,car b);
        if zerop cdr q then q:=car q
        else return 'failed;
        a:=testdiv1(ambq(cdr a,cdr b,q),da-1,b,db);
        if a='failed then return a;
        return q . a
    end;

symbolic procedure ambq(a,b,q);
% A-B*Q with Q an integer.
    if null b then a
    else ((car a)-(car b)*q) . ambq(cdr a,cdr b,q);

symbolic procedure linethrough(y0,y1);
    begin         scalar a;
        a:=y1-y0;
        if zerop a then return 'failed;
        if a<0 then <<a:=-a; y0:=-y0 >>;
        if onep gcdn(a,y0) then return list(1,a,y0);
        return 'failed
    end;

symbolic procedure quadthrough(ym1,y0,y1);
    begin         scalar a,b,c;
        a:=divide(ym1+y1,2);
        if zerop cdr a then a:=(car a)-y0
        else return 'failed;
        if zerop a then return 'failed; %linear things already done.
        c:=y0;
        b:=divide(y1-ym1,2);
        if zerop cdr b then b:=car b
        else return 'failed;
        if not onep gcdn(a,gcd(b,c)) then return 'failed;
        if a<0 then <<a:=-a; b:=-b; c:=-c>>;
        return list(2,a,b,c)
    end;

endmodule;


module lowdeg;   % Splitting of low degree polynomials.

% Author: To be determined.

fluid '(clogflag knowndiscrimsign zlist);

global '(!*trint);

exports forceazero,makepolydf,quadratic,covecdf,exponentdf;

imports dfquotdf,gcdf,interr,minusdfp,multdf,multdfconst,!*multf,
   negsq,minusp,printsq,multsq,invsq,pnth,nth,mknill,
   negdf,plusdf,printdf,printsq,quotf,sqrtdf,var2df,vp2,addsq,sub1;

symbolic procedure covecdf(pol,var,degree);
% Extract coefficients of polynomial wrt var, given a degree-bound
% degree. Result is a lisp vector.
    begin         scalar v,x,w;
        w:=pol;
        v:=mkvect(degree);
        while not null w do <<
            x:=exponentof(var,lpow w,zlist);
            if (x<0) or (x>degree) then interr "Bad degree in covecdf";
            putv(v,x,lt w . getv(v,x));
            w:=red w >>;
        for i:=0:degree do putv(v,i,multdf(reversewoc getv(v,i),
            var2df(var,-i,zlist)));
        return v
    end;

symbolic procedure quadratic(pol,var,res);
% Add in to res logs or arctans corresponding to splitting the
% polynomial.  Pol given that it is quadratic wrt var.
% Does not assume pol is univariate.
    begin       scalar a,b,c,w,discrim;
         w:=covecdf(pol,var,2);
         a:=getv(w,2); b:=getv(w,1); c:=getv(w,0);
% that split the quadratic up to find the coefficients a,b,c.
        if !*trint then << printc "a="; printdf a;
            printc "b="; printdf b;
            printc "c="; printdf c>>;
        discrim:=plusdf(multdf(b,b),
            multdfconst((-4) . 1,multdf(a,c)));
        if !*trint then << printc "Discriminant is";
            printdf discrim>>;
        if null discrim then interr "Discrim=0 in quadratic";
        if knowndiscrimsign
          then <<if knowndiscrimsign eq 'negative then go to atancase>>
         else if (not clogflag) and (minusdfp discrim)
          then go to atancase;
        discrim:=sqrtdf(discrim);
        if discrim='failed then go to nofactors;
        if !*trint then << printc "Square root is";
            printdf discrim>>;
        w:=var2df(var,1,zlist);
        w:=multdf(w,a);
        b:=multdfconst(1 ./ 2,b);
        discrim:=multdfconst(1 ./ 2,discrim);
        w:=plusdf(w,b); %a*x+b/2.
        a:=plusdf(w,discrim); b:=plusdf(w,negdf(discrim));
        if !*trint then << printc "Factors are";
            printdf a; printdf b>>;
        return ('log . a) . ('log . b) . res;
atancase:
        discrim:=sqrtdf negdf discrim; %sqrt(4*a*c-b**2) this time!
        if discrim='failed then go to nofactors; %sqrt did not exist?
        res := ('log . pol) . res; %one part of the answer
        a:=multdf(a,var2df(var,1,zlist));
        a:=plusdf(b,multdfconst(2 ./ 1,a));
        a:=dfquotdf(a,discrim); %assumes division is exact
        return ('atan . a) . res;
nofactors:
        if !*trint
         then <<printc
                   "The following quadratic does not seem to factor";
                printdf pol>>;
        return ('log . pol) . res
    end;

symbolic procedure exponentof(var,l,zl);
    if null zl then interr "Var not found in exponentof"
    else if var=car zl then car l
    else exponentof(var,cdr l,cdr zl);


symbolic procedure df2sf a;
    if null a then nil
    else if ((null red a) and
        (denr lc a = 1) and
        (lpow a=vp2 zlist)) then numr lc a
    else interr "Nasty cubic or quartic";


symbolic procedure makepolydf p;
% Multiply df by lcm of denominators of all coefficient denominators.
    begin       scalar h,w;
        if null(w:=p) then return nil; %poly is zero already.
        h:=denr lc w; %a good start.
        w:=red w;
        while not null w do <<
            h:=quotf(!*multf(h,denr lc w),gcdf(h,denr lc w));
            w:=red w >>;
        %h is now lcm of denominators.
        return multdfconst(h ./ 1,p)
    end;


symbolic procedure forceazero(p,n);
%Shift polynomial p so that coeff of x**(n-1) vanishes.
%Return the amount of the shift, update (vector) p.
    begin       scalar r,i,w;
        for i:=0:n do putv(p,i,df2sf getv(p,i)); %convert to polys.
        r:=getv(p,n-1);
        if null r then return nil ./ 1; %already zero.
        r:= !*multsq(r ./ 1,invsq(!*multf(n,getv(p,n)) ./ 1));
           % Used to be subs2q multsq
                        %the shift amount.
%now I have to set p:=subst(x-r,x,p) and then reduce to sf again.
        if !*trint then << printc "Shift is by ";
            printsq r>>;
        w:=mkvect(n); %workspace vector.
        for i:=0:n do putv(w,i,nil ./ 1); %zero it.
        i:=n;
        while not minusp i do <<
            mulvecbyxr(w,negsq r,n); %W:=(X-R)*W;
            putv(w,0,addsq(getv(w,0),getv(p,i) ./ 1));
            i:=i-1 >>;
        if !*trint then << printc "SQ shifted poly is";
            print w>>;
        for i:=0:n do putv(p,i,getv(w,i));
        w:=denr getv(p,0);
        for i:=1:n do w:=quotf(!*multf(w,denr getv(p,i)),
            gcdf(w,denr getv(p,i)));
        for i:=0:n do putv(p,i,numr !*multsq(getv(p,i),w ./ 1));
           % Used to be subs2q multsq
        w:=getv(p,0);
        for i:=1:n do w:=gcdf(w,getv(p,i));
        if not (w=1) then
            for i:=0:n do putv(p,i,quotf(getv(p,i),w));
        if !*trint then << printc "Final shifted poly is ";
            print p>>;
        return r
    end;

symbolic procedure mulvecbyxr(w,r,n);
% W is a vector representing a poly of degree n.
% Multiply it by (x+r).
    begin       scalar i,im1;
        i:=n;
        im1:=sub1 i;
        while not minusp im1 do <<
            putv(w,i,!*addsq(getv(w,im1),!*multsq(r,getv(w,i))));
           % Used to be subs2q addsq/multsq
            i:=im1; im1:=sub1 i >>;
        putv(w,0,!*multsq(getv(w,0),r));
           % Used to be subs2q multsq
        return w
    end;

endmodule;


module reform; % Reformulate expressions using C-constant substitution.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(cmap cval loglist ulist);

global '(!*trint);

exports logstosq,substinulist;

imports prepsq,mksp,nth,multsq,addsq,domainp,invsq,plusdf;

symbolic procedure substinulist ulist;
% Substitutes for the C-constants in the values of the U's given in
% ULIST. Result is a D.F.
   if null ulist then nil
   else begin scalar temp,lcu;
      lcu:=lc ulist;
      temp:=evaluateuconst numr lcu;
      if null numr temp then temp:=nil
      else temp:=((lpow ulist) .*
        !*multsq(temp,!*invsq(denr lcu ./ 1))) .+ nil;
      return plusdf(temp,substinulist red ulist)
   end;

symbolic procedure evaluateuconst coefft;
% Substitutes for the C-constants into COEFFT (=S.F.). Result is S.Q.;
    if null coefft or domainp coefft then coefft ./ 1
    else begin scalar temp;
      if null(temp:=assoc(mvar coefft,cmap)) then
            temp:=(!*p2f lpow coefft) ./ 1
      else temp:=getv(cval,cdr temp);
      temp:=!*multsq(temp,evaluateuconst(lc coefft));
   % Next line had addsq previously
      return !*addsq(temp,evaluateuconst(red coefft))
    end;

symbolic procedure logstosq;
% Converts LOGLIST to sum of the log terms as a S.Q.;
   begin scalar lglst,logsq,i,temp;
      i:=1;
      lglst:=loglist;
      logsq:=nil ./ 1;
loop: if null lglst then return logsq;
      temp:=cddr car lglst;
      if !*trint
        then <<printc "SF arg for log etc ="; printc temp>>;
      if not (caar lglst='iden) then <<
          temp:=prepsq temp; %convert to prefix form.
          temp:=list(caar lglst,temp); %function name.
          temp:=((mksp(temp,1) .* 1) .+ nil) ./ 1 >>;
      temp:=!*multsq(temp,getv(cval,i));
      % Next line had addsq previously
      logsq:=!*addsq(temp,logsq);
      lglst:=cdr lglst;
      i:=i+1;
      go to loop
   end;

endmodule;


module simplog;  % Simplify logarithms.

% Authors: Mary Ann Moore and Arthur C. Norman.

exports simplog,simplogsq;

imports quotf,prepf,mksp,simp!*,!*multsq,simptimes,addsq,minusf,negf,
   addf,comfac,negsq,mk!*sq,carx;

symbolic procedure simplog(exxpr); simplogi carx(exxpr,'simplog);

symbolic procedure simplogi(sq);
begin
   if atom sq then go to simplify;
   if car sq eq 'times
     then return simpplus(for each u in cdr sq
                            collect mk!*sq simplogi u);
   if car sq eq 'quotient
     then return addsq(simplogi cadr sq,
                       negsq simplogi caddr sq);
   if car sq eq 'expt
     then return simptimes list(caddr sq,
                                mk!*sq simplogi cadr sq);
   if car sq eq 'nthroot
     then return !*multsq(1 ./ caddr sq,simplogi cadr sq);
     % we had (nthroot of n).
   if car sq eq 'sqrt
      then return !*multsq(1 ./ 2,simplogi argof sq);
  if car sq = '!*sq
    then return simplogsq cadr sq;
 simplify:
   sq:=simp!* sq;
  return simplogsq sq
  end;

symbolic procedure simplogsq sq;
addsq((simplog2 numr sq),negsq(simplog2 denr sq));

symbolic procedure simplog2(sf);
 if atom sf
   then if null sf then rederr "Log 0 formed"
     else if numberp sf
       then if sf iequal 1
         then nil ./ 1
         else if sf iequal 0 then rederr "Log 0 formed"
           else((mksp(list('log,sf),1) .* 1) .+ nil) ./ 1
       else formlog(sf)
   else begin
     scalar form;
     form:=comfac sf;
     if not null car form
       then return addsq(formlog(form .+ nil),
                         simplog2 quotf(sf,form .+ nil));
     % we have killed common powers.
     form:=cdr form;
     if form neq 1
       then return addsq(simplog2 form,
                         simplog2 quotf(sf,form));
     % remove a common factor from the sf.
     return (formlog sf)
     end;

symbolic procedure formlogterm(sf);
begin
  scalar u;
  u:=mvar sf;
  if not atom u and (car u member '(times sqrt expt nthroot))
    then u:=addsq(simplog2 lc sf,
                    !*multsq(simplogi u,simp!* ldeg sf))
    else if (lc sf iequal 1) and (ldeg sf iequal 1)
      then u:=((mksp(list('log,u),1) .* 1) .+ nil) ./ 1
      else u:=addsq(simptimes list(list('log,u),ldeg sf),
                    simplog2 lc sf);
  return u
  end;

symbolic procedure formlog sf;
if null red sf
  then formlogterm sf
   else if minusf sf
     then addf((mksp(list('log,-1),1) .* 1) .+ nil,
               formlog2 negf sf) ./ 1
     else (formlog2 sf) ./ 1;

symbolic procedure formlog2 sf;
((mksp(list('log,prepf sf),1) .* 1) .+ nil);

endmodule;


module simpsqrt;   % Simplify square roots.

% Authors: Mary Ann Moore and Arthur C. Norman.
% Heavily modified J.H. Davenport for algebraic functions.

fluid '(!*backtrace !*conscount !*galois !*pvar basic!-listofallsqrts
        gaussiani basic!-listofnewsqrts kord!* knowntobeindep
        listofallsqrts listofnewsqrts sqrtflag sqrtlist
        sqrt!-places!-alist variable varlist zlist);

global '(!*tra !*trint);

% This module should be rewritten in terms of the REDUCE function
% SIMPSQRT;

% remd 'simpsqrt;

exports proper!-simpsqrt,simpsqrti,simpsqrtsq,simpsqrt2,sqrtsave,
        newplace,actualsimpsqrt,formsqrt;

symbolic procedure proper!-simpsqrt(exprn);
   simpsqrti carx(exprn,'proper!-simpsqrt);


symbolic procedure simpsqrti sq;
begin
   scalar u;
   if atom sq
     then if numberp sq
       then return (simpsqrt2 sq) ./ 1
       else if (u:=get(sq,'avalue))
         then return simpsqrti cadr u
           % BEWARE!!! This is VERY system dependent.
         else return simpsqrt2((mksp(sq,1) .* 1) .+ nil) ./ 1;
           % If it doesnt have an AVALUE then it is itself;
   if car sq eq 'times
     then return mapply(function multsq,
                        mapcar(cdr sq,function simpsqrti));
   if car sq eq 'quotient
     then return multsq(simpsqrti cadr sq,
                        invsq simpsqrti caddr sq);
   if car sq eq 'expt and numberp caddr sq
     then if evenp caddr sq
       then return simpexpt list(cadr sq,caddr sq / 2)
       else return simpexpt
                     list(mk!*sq simpsqrti cadr sq,caddr sq);
  if car sq = '!*sq
    then return simpsqrtsq cadr sq;
  return simpsqrtsq tidysqrt simp!* sq
  end;


symbolic procedure simpsqrtsq sq;
(simpsqrt2 numr sq) ./ (simpsqrt2 denr sq);


symbolic procedure simpsqrt2 sf;
if minusf sf
  then if sf iequal -1
    then gaussiani
    else begin
      scalar u;
      u:=negf sf;
      if numberp u
        then return multf(gaussiani,simpsqrt3 u);
      % we cannot negate general expressions for the following reason:
%       (%%%thesis remark%%%)
%       sqrt(x*x-1) under x->1/x gives sqrt(1-x*x)/x=i*sqrt(x*x-1)/x
%                 under x->1/x gives x*i*sqrt(-1+1/x*x)=i**2*sqrt(x*x-1)
%       hence an abysmal catastrophe;
      return simpsqrt3 sf
      end
  else simpsqrt3 sf;


symbolic procedure simpsqrt3 sf;
begin
  scalar u;
  u:=assoc(sf,listofallsqrts);
  if u
    then return cdr u;
  % now see if 'knowntobeindep'can help.
  u:=atsoc(listofnewsqrts,knowntobeindep);
  if null u
    then go to no;
  u:=assoc(sf,cdr u);
  if u
    then <<
      listofallsqrts:=u.listofallsqrts;
      return cdr u >>;
no:
  u:=actualsimpsqrt sf;
  listofallsqrts:=(sf.u).listofallsqrts;
  return u
  end;


symbolic procedure sqrtsave(u,v,place);
begin
  scalar a;
  %u is new value of listofallsqrts, v of new.
  a:=assoc(place,sqrt!-places!-alist);
  if null a
    then sqrt!-places!-alist:=(place.(listofnewsqrts.listofallsqrts))
           .sqrt!-places!-alist
    else rplacd(a,listofnewsqrts.listofallsqrts);
      listofnewsqrts:=v;
      % throw away things we are not going to need in future.
      if not !*galois
        then listofallsqrts:=u;
        % we cannot guarantee the validity of our calculations.
      if listofallsqrts eq u
        then return nil;
      v:=listofallsqrts;
      while not (cdr v eq u) do
        v:=cdr v;
      rplacd(v,nil);
      % listofallsqrts is all those added since routine was entered.
      v:=atsoc(listofnewsqrts,knowntobeindep);
      if null v
        then knowntobeindep:=(listofnewsqrts.listofallsqrts)
                              . knowntobeindep
        else rplacd(v,union(cdr v,listofallsqrts));
      listofallsqrts:=u;
      return nil
  end;


symbolic procedure newplace(u);
% Says to restart algebraic bases at a new place u.
begin
  scalar v;
  v:=assoc(u,sqrt!-places!-alist);
  if null v
    then <<
      listofallsqrts:=basic!-listofallsqrts;
      listofnewsqrts:=basic!-listofnewsqrts >>
    else <<
      v:=cdr v;
      listofnewsqrts:=car v;
      listofallsqrts:=cdr v >>;
  return if v then v
              else listofnewsqrts.listofallsqrts
  end;


symbolic procedure mknewsqrt u;
% U is prefix form.
begin
  scalar v,w;
  if not !*galois then go to new;
    % no checking required.
  v:=addf(!*p2f mksp(!*pvar,2),negf !*q2f tidysqrt simp u);
% count !*conscount;
  w:=errorset(list('afactor,mkquote v,mkquote !*pvar),t,!*backtrace);
% if !*tra then <<
%   princ "*** That took ";
%   princ (!*conscount - count nil);
%   printc " conses" >>;
% count 0;
  if atom w
    then go to new
    else w:=car w; %the actual result of afactor.
  if cdr w
    then go to notnew;
new:
  w:=sqrtify u;
  listofnewsqrts:=w . listofnewsqrts;
  return !*kk2f w;
notnew:
  w:=car w;
  v:=stt(w,!*pvar);
  if car v neq 1
    then rederr "HELP ...";
  w:=addf(w,multf(cdr v,(mksp(!*pvar,car v) .* -1) .+nil));
  w:=sqrt2top(w ./ cdr v);
  w:=quotf(numr w,denr w);
  if null w
    then rederr "Division failure";
  return w
  end;


symbolic procedure actualsimpsqrt(sf);
if sf iequal -1
  then gaussiani
  else actualsqrtinner(sf,listofnewsqrts);


symbolic procedure actualsqrtinner(sf,l);
if null l
  then actualsimpsqrt2 sf
  else begin
    scalar z;
%   z:=simp argof car l;
%   if denr z neq 1 or (z := numr z) iequal -1
    z:=!*q2f simp argof car l;
    if z iequal -1
      then return actualsqrtinner(sf,cdr l);
    z:=quotf(sf,z);
    if null z
      then return actualsqrtinner(sf,cdr l);
    return !*multf(!*kk2f car l,actualsimpsqrt z)
    end;


symbolic procedure actualsimpsqrt2(sf);
 if atom sf
   then if null sf
     then nil
     else if numberp sf
       then if sf < 0
         then multf(gaussiani,actualsimpsqrt2(- sf))
           %Above 2 lines inserted JHD 4 Sept 80;
           % test case: SQRT(B*X**2-C)/SQRT(X);
         else begin
           scalar n;
           n:=int!-sqrt sf;
           % Changed for conformity with DEC20 LISP JHD July 1982;
           if not fixp n
             then return mknewsqrt sf
             else return n
           end
     else mknewsqrt(sf)
   else begin
     scalar form;
     form:=comfac sf;
     if car form
       then return multf((if null cdr sf and (car sf = form)
                            then formsqrt(form .+ nil)
                            else simpsqrt2(form .+ nil)),
                            %The above 2 lines changed by JHD;
                            %(following suggestions of Morrison);
                            %to conform to Standard LISP 4 Sept 80;
                         simpsqrt2 quotf(sf,form .+ nil));
     % we have killed common powers.
     form:=cdr form;
     if form neq 1
       then return multf(simpsqrt2 form,
                          simpsqrt2 quotf(sf,form));
     % remove a common factor from the sf.
     return formsqrt sf
     end;


symbolic procedure int!-sqrt n;
   % Return sqrt of n if same is exact, or something non-numeric
   % otherwise.
    if not numberp n then 'nonnumeric
    else if n<0 then 'negative
    else if floatp n then sqrt!-float n
    else if n<2 then n
    else int!-nr(n,(n+1)/2);


symbolic procedure int!-nr(n,root);
% root is an overestimate here. nr moves downwards to root;
 begin
    scalar w;
    w:=root*root;
    if n=w then return root;
    w:=(root+n/root)/2;
    if w>=root then return !*q2f simpsqrt list n;
    return int!-nr(n,w)
 end;


 symbolic procedure formsqrt(sf);
 if (null red sf)
   then if (lc sf iequal 1) and (ldeg sf iequal 1)
     then mknewsqrt mvar sf
     else multf(if evenp ldeg sf
                  then !*p2f mksp(mvar sf,ldeg sf / 2)
                  else exptf(mknewsqrt mvar sf,ldeg sf),simpsqrt2 lc sf)
   else begin
     scalar varlist,zlist,sqrtlist,sqrtflag;
     scalar v,l,n,w;
     % This returns a list, the i-th member of which is
%      a list of the factors of multiplicity i (as s.f's);
     v:=jsqfree(sf,if variable and involvesf(sf,variable)
                     then variable
                     else findatom mvar sf);
                     % VARIABLE is the best thing to do square-free
%                      decompositions with respect to, but anything
%                      else will do if VARIABLE is not set;
     if null cdr v and null cdar v
       then return mknewsqrt prepf sf;
       % The JSQFREE did nothing;
     l:=nil;
     n:=0;
     while v do <<
       n:=n+1;
       w:=car v;
       while w do <<
         l:=list('expt,mk!*sq !*f2q car w,n) . l;
         w:=cdr w >>;
       v:=cdr v >>;
     if null cdr l
       then l:=car l
       else l:='times.l;
       % makes L into a valid prefix form;
     return !*q2f simpsqrti l
     end;


symbolic procedure findatom pf;
if atom pf
  then pf
  else findatom argof pf;


symbolic procedure sqrtify u;
% Actually creates the sqrt.
begin
  scalar v,n,prinlist;
  n:=degreenest(u,nil);
% v:=list('sqrt,u);
  v := mksqrt u;   % To ensure sqrt**2 rule set.
  prinlist:=member(v,kord!*);
  if prinlist then return car prinlist;
  % This might improve sharing.
  % anyway, we mustn't re-add this object to KORD!*;
  while kord!* and
        eqcar(car kord!*,'sqrt) and
        (degreenest(argof car kord!*,nil) > n) do <<
    prinlist:=(car kord!*) . prinlist;
    kord!*:=cdr kord!* >>;
  kord!*:=v . kord!*;
  while prinlist do <<
    kord!*:=(car prinlist) . kord!*;
    prinlist:=cdr prinlist >>;
  return v
  end;


% deflist ('((sqrt (((x) quotient (sqrt x) (times 2 x))))),'dfn);

% put('sqrt,'simpfn,'proper!-simpsqrt); % Now in driver.

endmodule;


module isolve;   % Routines for solving the final reduction equation.

% Author: Mary Ann Moore and Arthur C. Norman.
% Modifications by: John P. Fitch.

fluid '(badpart
        ccount
        cmap
        cmatrix
        cval
        indexlist
        lhs!*
        lorder
        nnn
        orderofelim
        pt
        rhs!*
        sillieslist
        tanlist
        ulist
        zlist);

global '(!*number!* !*statistics !*trint);

exports solve!-for!-u;

imports nth,findpivot,gcdf,int!-gensym1,mkvect,interr,multdfconst,
   !*multf!*,negdf,orddf,plusdf,printdf,printsf,printspreadc,printsq,
   quotf,putv,spreadc,subst4eliminatedcs,mknill,pnth,domainp,addf,
   invsq,multsq;

symbolic procedure uterm(powu,rhs!*);
% Finds the contribution from RHS!* of reduction equation, of the;
% U-coefficient given by POWU. Result is in D.F.;
   if null rhs!* then nil
   else begin    scalar coef,power;
      power:=addinds(powu,lpow rhs!*);
      coef:=evaluatecoeffts(numr lc rhs!*,powu);
      if null coef then return uterm(powu,red rhs!*);
      coef:=coef ./ denr lc rhs!*;
      return plusdf((power .* coef) .+ nil,uterm(powu,red rhs!*))
   end;

symbolic procedure solve!-for!-u(rhs!*,lhs!*,ulist);
% Solves the reduction eqn LHS!*=RHS!*. Returns list of U-coefficients
% and their values (ULIST are those we have so far), and a list of
% C-equations to be solved (CLIST are the eqns we have so far).
   if null lhs!* then ulist
   else begin    scalar u,lpowlhs;
      lpowlhs:=lpow lhs!*;
      begin scalar ll,mm,chge; ll:=maxorder(rhs!*,zlist,0);
        mm:=lorder;
        while mm do << if car ll < car mm then
                << chge:=t; rplaca(mm,car ll) >>;
            ll:=cdr ll; mm:=cdr mm >>;
        if !*trint and chge then << print ("Maxorder now ".lorder) >>
      end;
      u:=pickupu(rhs!*,lpow lhs!*,t);
      if null u then
      << if !*trint then << printc "***** C-equation to solve:";
             printsf numr lc lhs!*;
             printc "    = 0";
             printc " ">>;
          % Remove a zero constant from the lhs, rather than use
          % Gauss Elim;
        if gausselimn(numr lc lhs!*,lt lhs!*) then
                 lhs!*:=squashconstants(red lhs!*)
        else lhs!*:=red lhs!* >>
      else
      << ulist:=(car u .
           !*multsq(coefdf(lhs!*,lpowlhs),invsq cdr u)).ulist;
                % used to be subs2q multsq
        if !*statistics then !*number!*:=!*number!*+1;
         if !*trint then <<prin2 "***** U"; prin2 car u; prin2t " =";
                      printsq multsq(coefdf(lhs!*,lpowlhs),invsq cdr u);
                      printc " ">>;
         lhs!*:=plusdf(lhs!*,
                negdf multdfconst(cdar ulist,uterm(car u,rhs!*))) >>;
      if !*trint then << printc ".... LHS is now:";
          printdf lhs!*;
          printc " ">>;
      return solve!-for!-u(rhs!*,lhs!*,ulist)
   end;

symbolic procedure squashconstants(express);
begin scalar constlst,ii,xp,cl,subby,cmt,xx;
        constlst:=reverse cmap;
        cmt:=cmatrix;
xxx:    xx:=car cmt;            % Look at next row of Cmatrix;
        cl:=constlst;           % and list of the names;
        ii:=1;          % will become index of removed constant;
        while not getv(xx,ii) do
                << ii:=ii+1; cl:=cdr cl >>;
        subby:=caar cl;         %II is now index, and SUBBY the name;
        if member(subby,sillieslist) then
                <<cmt:=cdr cmt; go to xxx>>; %This loop must terminate;
                        % This is because at least one constant remains;
        xp:=prepsq !*f2q getv(xx,0);    % start to build up the answer;
        cl:=cdr cl;
        if not (ccount=ii) then for jj:=ii+1:ccount do <<
                if getv(xx,jj) then
                        xp:=list('plus,xp,
                                list('times,caar cl,
                                        prepsq !*f2q getv(xx,jj)));
                cl:=cdr cl >>;
        xp:=list('quotient,list('minus,xp),
                        prepsq !*f2q getv(xx,ii));
        if !*trint then << prin2 "Replace "; prin2 subby;
                prin2 " by "; printsq simp xp >>;
        sillieslist:=subby . sillieslist;
        return subdf(express,xp,subby)
end;

symbolic procedure checku(ulist,u);
% Checks that U is not already in ULIST - ie. that this u-coefficient;
% has not already been given a value;
   if null ulist then nil
   else if (car u) = caar ulist then t
   else checku(cdr ulist,u);

symbolic procedure checku1(powu,rhs!*);
%Checks that use of a particular U-term will not cause trouble;
%by introducing negative exponents into lhs when it is used;
    begin
    top:
        if null rhs!* then return nil;
        if negind(powu,lpow rhs!*) then
          if not null evaluatecoeffts(numr lc rhs!*,powu) then return t;
        rhs!*:=red rhs!*;
        go to top
    end;

symbolic procedure negind(pu,pr);
%check if substituting index values in power gives rise to -ve
% exponents;
    if null pu then nil
    else if (car pu+caar pr)<0 then t
    else negind(cdr pu,cdr pr);


symbolic procedure evaluatecoeffts(coefft,indlist);
% Substitutes the values of the i,j,k,...'s that appear in the S.F. ;
% COEFFT (=coefficient of r.h.s. of reduction equation). Result is S.F.;
   if null coefft or domainp coefft then
      if coefft=0 then nil else coefft
   else begin    scalar temp;
      if mvar coefft member indexlist then
         temp:=valuecoefft(mvar coefft,indlist,indexlist)
      else temp:=!*p2f lpow coefft;
      temp:=!*multf(temp,evaluatecoeffts(lc coefft,indlist));
      return addf(temp,evaluatecoeffts(red coefft,indlist))
   end;

symbolic procedure valuecoefft(var,indvalues,indlist);
% Finds the value of VAR, which should be in INDLIST, given INDVALUES;
% - the corresponding values of INDLIST variables;
   if null indlist then interr "Valuecoefft - no value"
   else if var eq car indlist then
      if car indvalues=0 then nil
      else car indvalues
   else valuecoefft(var,cdr indvalues,cdr indlist);

symbolic procedure addinds(powu,powrhs);
% Adds indices in POWU to those in POWRHS. Result is LPOW of D.F.;
   if null powu then if null powrhs then nil
      else interr "Powrhs too long"
   else if null powrhs then interr "Powu too long"
   else (car powu + caar powrhs).addinds(cdr powu,cdr powrhs);


symbolic procedure pickupu(rhs!*,powlhs,flg);
% Picks up the 'lowest' U coefficient from RHS!* if it exists and
% returns it in the form of LT of D.F..
% Returns NIL if no legal term in RHS!* can be found.
% POWLHS is the power we want to match (LPOW of D.F).
% and COEFFU is the list of previous coefficients that must be zero;
 begin scalar coeffu,u;
    pt:=rhs!*;
top:
    if null pt then return nil; %no term found - failed;
    u:=nextu(lt pt,powlhs); %check this term...;
    if null u then go to notthisone;
    if not testord(car u,lorder) then go to neverthisone;
    if not checkcoeffts(coeffu,car u) then go to notthisone;
    %that inhibited clobbering things already passed over;
    if checku(ulist,u) then go to notthisone;
    %that avoided redefining a u value;
    if checku1(car u,rhs!*) then go to neverthisone;
    %avoid introduction of negative exponents;
    if flg then
        u:=patchuptan(list u,powlhs,red pt,rhs!*);
    return u;
neverthisone:
    coeffu:=(lc pt) . coeffu;
notthisone:
    pt:=red pt;
    go to top
 end;

symbolic procedure patchuptan(u,powlhs,rpt,rhs!*);
        begin
            scalar uu,cc,dd,tanlist,redu,redu1;
            pt:=rpt;
            while pt do <<
                if (uu:=pickupu(pt,powlhs,nil))
                        and testord(car uu,lorder) then <<
                                % Nasty found, patch it up;
                    cc:=(int!-gensym1('!C).caar u).cc;
                                % CC is an alist of constants;
                    if !*trint then <<prin2 "***** U";
                                      prin2 caar u;
                                      prin2t " =";
                                      print caar cc >>;
                    redu:=plusdf(redu,
                        multdfconst(!*k2q caar cc,uterm(caar u,rhs!*)));
                    u:=uu.u
                >>;
                if pt then pt:=red pt >>;
            redu1:=redu;
            while redu1 do begin scalar xx; xx:=car redu1;
if !*trint then << prin2 "Introduced residue "; print xx >>;
                if (not testord(car xx,lorder)) then <<
                    if !*trint then <<
                        printsq cdr xx; printc "  =  0" >>;
                    if dd:=killsingles(cadr xx,cc) then <<
                        redu:=subdf(redu,0,car dd);
                        redu1:=subdf(redu1,0,car dd);
                        ulist:=((cdr dd).(nil ./ 1)).ulist;
                        u:=rmve(u,cdr dd);
                        cc:=purgeconst(cc,dd) >>
                    else redu1:=cdr redu1  >>
                else redu1:=cdr redu1  end;
            for each xx in redu do <<
                if (not testord(car xx,lorder)) then <<
                    while cc do << 
                                addctomap(caar cc);
                                ulist:=((cdar cc).(!*k2q caar cc))
                                          . ulist;
                                if !*statistics
                                  then !*number!*:=!*number!*+1;
                                cc:=cdr cc >>;
                        gausselimn(numr lc redu,lt redu)>> >>;
            if redu then << while cc do << addctomap(caar cc);
                        ulist:=((cdar cc).(!*k2q caar cc)).ulist;
                        if !*statistics then !*number!*:=!*number!*+1;
                        cc:=cdr cc >>;
                lhs!*:=plusdf(lhs!*,negdf redu) >>;
    return car u
end;

symbolic procedure killsingles(xx,cc);
  if atom xx then nil
  else if not (cdr xx eq nil) then nil
  else begin scalar dd;
    dd:=assoc(caaar xx,cc);
    if dd then return dd;
    return killsingles(cdar xx,cc)
end;

symbolic procedure rmve(l,x);
   if caar l=x then cdr l else cons(car l,rmve(cdr l,x));

symbolic procedure subdf(a,b,c);
% SUBSTITUTE B FOR C INTO THE DF A;
% Used to get rid of silly constants introduced;
if a=nil then nil else
  begin scalar x;
    x:=subs2q subf(numr lc a,list (c . b)) ;
    if x=(nil . 1) then return subdf(red a,b,c)
        else return plusdf(
                list ((lpow a).((car x).!*multf(cdr x,denr lc a))),
                subdf(red a,b,c))
end;

symbolic procedure testord(a,b);
% Test order of two DF's in recursive fashion;
  if null a then t
    else if car a leq car b then testord(cdr a,cdr b)
    else nil;

symbolic procedure tanfrom(rhs!*,z,nnn);
% We notice that in all bad cases we have (j-num)tan**j...;
% Extract the num;
begin scalar n,zz,r,rr;
    r:=rhs!*;
    n:=0; zz:=zlist;
    while car zz neq z do << n:=n+1; zz:=cdr zz >>;
 a: if null r then go to b;
        rr:=caar r;  % The list of powers;
        for i:=1:n do rr:=cdr rr;
        if fixp caar rr then if caar rr>0 then <<
                rr:=numr cdar r;
                if null red rr then rr:=nil ./ 1
         else if fixp (rr:=quotf(red rr,lc rr))
                then rr:=-rr else rr:=0>>;
        if atom rr then go to b;
        r:=cdr r;
    go to a;
 b: if null r then return maxfrom(lhs!*,nnn)+1;
   return max(rr,maxfrom(lhs!*,nnn)+1)
end;


symbolic procedure coefdf(y,u);
  if y=nil then nil
  else if lpow y=u then lc y
  else coefdf(red y,u);


symbolic procedure purgeconst(a,b);
% Remove a const from and expression. May be the same as DELETE?;
  if null a then nil
  else if car a=b then purgeconst(cdr a,b)
  else cons(car a,purgeconst(cdr a,b));

symbolic procedure maxorder(rhs!*,z,n);
% Find a limit on the order of terms, theis is ad hoc;
  if null z then nil
    else if eqcar(car z,'sqrt) then
        cons(1,maxorder(rhs!*,cdr z,n+1))
    else if (atom car z) or (caar z neq 'tan) then
        cons(maxfrom(lhs!*,n)+1,maxorder(rhs!*,cdr z,n+1))
    else cons(tanfrom(rhs!*,car z,n),maxorder(rhs!*,cdr z,n+1));

symbolic procedure maxfrom(l,n);
% Largest order in the nth varable;
  if null l then 0
  else max(nth(caar l,n+1),maxfrom(cdr l,n));


symbolic procedure copy u;
  if atom u then u
    else cons(copy car u,copy cdr u);


symbolic procedure addctomap cc;
begin
    scalar ncval;
    ccount:=ccount+1;
    ncval:=mkvect(ccount);
    for i:=0:(ccount-1) do putv(ncval,i,getv(cval,i));
    putv(ncval,ccount,nil ./ 1);
    cval:=ncval;
    cmap:=(cc . ccount).cmap;
    if !*trint then << prin2 "Constant map changed to "; print cmap >>;
    cmatrix:=mapcar(cmatrix,function addtovector);
end;

symbolic procedure addtovector v;
    begin scalar vv;
        vv:=mkvect(ccount);
        for i:=0:(ccount-1) do putv(vv,i,getv(v,i));
        putv(vv,ccount,nil);
        return vv
    end;

symbolic procedure checkcoeffts(cl,indv);
% checks to see that the coefficients in CL (coefficient list - S.Q.s);
% are zero when the i,j,k,... are given values in INDV (LPOW of;
% D.F.). if so the result is true else NIL=false;
    if null cl then t
    else begin    scalar res;
        res:=evaluatecoeffts(numr car cl,indv);
        if not(null res or res=0) then return nil
        else return checkcoeffts(cdr cl,indv)
    end;

symbolic procedure nextu(ltrhs,powlhs);
% picks out the appropriate U coefficients for term: LTRHS to match the
% powers of the z-variables given in POWLHS (= exponent list of D.F.).
% return this coefficient in form LT of D.F. If U coefficient does
% not exist then result is NIL. If it is multiplied by a zero then
% result is NIL;
   if null ltrhs then nil
   else begin    scalar indlist,ucoefft;
      indlist:=subtractinds(powlhs,car ltrhs,nil);
      if null indlist then return nil;
      ucoefft:=evaluatecoeffts(numr cdr ltrhs,indlist);
      if null ucoefft or ucoefft=0 then return nil;
      return indlist .* (ucoefft ./ denr cdr ltrhs)
   end;

symbolic procedure subtractinds(powlhs,l,sofar);
% subtract the indices in list L from those in POWLHS to find;
% appropriate values for i,j,k,... when equating coefficients of terms;
% on lhs of reduction eqn. SOFAR is the resulting value list we;
% have constructed so far. if any i,j,k,... value is -ve then result;
% is NIL;
    if null l then reversewoc sofar
    else if ((car powlhs)-(caar l))<0 then nil
    else subtractinds(cdr powlhs,cdr l,
        ((car powlhs)-(caar l)) . sofar);

symbolic procedure gausselimn(equation,tokill);
% Performs Gaussian elimination on the matrix for the c-equations;
% as each c-equation is found. EQUATION is the next one to deal with;
   begin         scalar newrow,pivot;
      if zerop ccount then go to noway; %failure
      newrow:=mkvect(ccount);
      spreadc(equation,newrow,1);
      subst4eliminatedcs(newrow,reverse orderofelim,reverse cmatrix);
      pivot:=findpivot newrow;
      if null pivot then go to nopivotfound;
      orderofelim:=pivot . orderofelim;
      newrow:=makeprim newrow; %remove hcf from new equation
      cmatrix:=newrow . cmatrix;
%      if !*trint then printspreadc newrow;
      return t;
 nopivotfound:
      if null getv(newrow,0) then <<
        if !*trint then printc "Already included";
        return nil>>; %equation was 0=0
 noway:
      badpart:=tokill . badpart; %non-integrable term.
      if !*trint then printc "Inconsistent";
      return nil
   end;

symbolic procedure makeprim row;
    begin scalar g;
        g:=getv(row,0);
        for i:=1:ccount do g:=gcdf(g,getv(row,i));
        if g neq 1 then 
           for i:=0:ccount do putv(row,i,quotf(getv(row,i),g));
        for i := 0:ccount do
          <<g := getv(row,i);
            if g and not domainp g
              then putv(row,i,numr resimp((rootextractf g) ./ 1))>>;
        return row
    end;

endmodule;


module sqrtf;   % Square root of standard forms.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(!*noextend zlist);

exports minusdfp,sqrtdf,nrootn,domainp,minusf;

imports contentsmv,gcdf,interr,!*multf,partialdiff,printdf,quotf,
   simpsqrt2,vp2;

symbolic procedure minusdfp a;
  % Test sign of leading coedd of d.f.
    if null a then interr "Minusdfp 0 illegal"
    else minusf numr lc a;

symbolic procedure sqrtdf l;
   % Takes square root of distributive form. "Failed" usually means
   % that the square root is not among already existing objects.
    if null l then nil
    else begin scalar c;
        if lpow l=vp2 zlist then go to ok;
        c:=sqrtsq df2q l;
        if numr c eq 'failed
          then return 'failed;
        if denr c eq 'failed
          then return 'failed;
        return for each u in f2df numr c
                 collect (car u).!*multsq(cdr u,1 ./ denr c);
    ok: c:=sqrtsq lc l;
        if  numr c eq 'failed or
            denr c eq 'failed
          then return 'failed
          else return (lpow l .* c) .+nil
    end;

symbolic procedure sqrtsq a;
    sqrtf numr a ./ sqrtf denr a;

symbolic procedure sqrtf p;
    begin       scalar ip,qp;
        if null p then return nil;
        ip:=sqrtf1 p;
        qp:=cdr ip;
        ip:=car ip; %respectable and nasty parts of the sqrt.
        if qp=1 then return ip; %exact root found.
         if !*noextend then return 'failed;
            % We cannot add new square roots in this case, since it is
            % then impossible to determine if one square root depends
            % on another if new ones are being added all the time.
         if zlistp qp then return 'failed;
            % Liouville's theorem tells you that you never need to add
            % new algebraics depending on the variable of integration.
        qp:=simpsqrt2 qp;
        return !*multf(ip,qp)
    end;

symbolic procedure zlistp qp;
if atom qp then member(qp,zlist)
  else or(member(mvar qp,zlist),zlistp lc qp,zlistp red qp);

symbolic procedure sqrtf1 p;
  % Returns a . b with p=a**2*b.
    if domainp p
     then if fixp p then nrootn(p,2)
           else !*q2f simpsqrt list prepf p . 1
    else begin scalar co,pp,g,pg;
        co:=contentsmv(p,mvar p,nil); %contents of p.
        pp:=quotf(p,co); %primitive part.
        co:=sqrtf1(co); %process contents via recursion.
        g:=gcdf(pp,partialdiff(pp,mvar pp));
        pg:=quotf(pp,g);
        g:=gcdf(g,pg); %a repeated factor of pp.
        if g=1 then pg:=1 . pp
        else <<
            pg:= quotf(pp,!*multf(g,g)); %what is still left.
            pg:=sqrtf1(pg); %split that up.
            rplaca(pg,!*multf(car pg,g))>>;
                 %put in the thing found here.
        rplaca(pg, !*multf(car pg,car co));
        rplacd(pg, !*multf(cdr pg,cdr co));
        return pg
    end;

% NROOTN removed as in REDUCE base.

endmodule;


module tdiff;   % Differentiation routines for integrator.

% Authors: Mary Ann Moore and Arthur C. Norman.

exports !-!-simpdf;

imports simpcar,kernp,diffsq,prepsq,msgpri;

flag('(!-!-simpdf),'lose);

symbolic procedure !-!-simpdf u;
   % U is a list of forms, the first an expression and the remainder
   % kernels and numbers.
   % Value is derivative of first form wrt rest of list.
   begin    scalar v,x,y,tt;
        tt := time(); %start the clock;
        v := cdr u;
        u := simpcar u;
    a:  if null v or null numr u then go to exit;
        x := if null y or y=0 then simpcar v else y;
        if null kernp x then go to e;
        x := caaaar x;
        v := cdr v;
        if null v then go to c;
        y := simpcar v;
        if null numr y then go to d
         else if not denr y=1 or not numberp numr y then go to c;
        y := car y;
        v := cdr v;
    b:  if y=0 then go to a;
        u := diffsq(u,x);
        y := y-1;
        go to b;
    c:  u := diffsq(u,x);
        go to a;
    d:  y := nil;
        v := cdr v;
        go to a;
    exit:
       print list('time,time()-tt);
       return u;
    e:  msgpri("Differentiation wrt",prepsq x,"not allowed",nil,t)
   end;

put('tdf,'simpfn,'!-!-simpdf);

endmodule;


module tidysqrt;  % General tidying up of square roots.

% Authors: Mary Ann Moore and Arthur C. Norman.
% Modifications by J.H. Davenport.

exports sqrt2top,tidysqrt;

%symbolic procedure tidysqrtdf a;
%    if null a then nil
%    else begin    scalar tt,r;
%        tt:=tidysqrt lc a;
%        r:=tidysqrtdf red a;
%        if null numr tt then return r;
%        return ((lpow a) .* tt) .+ r
%    end;
%
symbolic procedure tidysqrt q;
    begin    scalar nn,dd;
        nn:=tidysqrtf numr q;
        if null nn then return nil ./ 1; %answer is zero.
        dd:=tidysqrtf denr q;
        return multsq(nn,invsq dd)
    end;

symbolic procedure tidysqrtf p;
%Input - standard form.
%Output - standard quotient.
%Simplifies sqrt(a)**n with n>1.
    if domainp p then p ./ 1
    else begin    scalar v,w;
        v:=lpow p;
        if car v='i then v:=mksp('(sqrt -1),cdr v); %I->sqrt(-1);
        if eqcar(car v,'sqrt) and not onep cdr v
          then begin    scalar x;
             %here we have a reduction to apply.
            x:=divide(cdr v,2); %halve exponent.
            w:=exptsq(simp cadar v,car x); %rational part of answer.
            if not zerop cdr x then w:=multsq(w,
                ((mksp(car v,1) .* 1) .+ nil) ./ 1);
            %the next line allows for the horrors of nested sqrts.
            w:=tidysqrt w
            end
        else w:=((v .* 1) .+ nil) ./ 1;
        v:=multsq(w,tidysqrtf lc p);
        return addsq(v,tidysqrtf red p)
    end;


symbolic procedure multoutdenr q;
  % Move sqrts in a sq to the numerator.
    begin  scalar n,d,root,conj;
        n:=numr q;
        d:=denr q;
        while (root:=findsquareroot d) do <<
          conj:=conjugatewrt(d,root);
          n:=!*multf(n,conj);
          d:=!*multf(d,conj) >>;
        while (root:=findnthroot d) do <<
          conj:=conjugateexpt(d,root,kord!*);
          n:=!*multf(n,conj);
          d:=!*multf(d,conj) >>;
        return (n . d);
        end;

symbolic procedure conjugateexpt(d,root,kord!*);
  begin scalar ord,ans,repl,xi;
  ord:=caddr caddr root; % the denominator of the exponent;
  ans:=1;
  kord!*:= (xi:=gensym()) . kord!*;
  % XI is an ORD'th root of unity;
  for i:=1:ord-1 do <<
    ans:=!*multf(ans,numr subf(d,
                   list(root . list('times,root,list('explt,xi,i)))));
    while (mvar ans eq xi) and ldeg ans > ord do
      ans:=addf(red ans,(xi) to (ldeg ans - ord) .* lc ans .+ nil);
    if (mvar ans eq xi) and ldeg ans = ord then
      ans:=addf(red ans,lc ans) >>;
  if (mvar ans eq xi) and ldeg ans = ord-1 then <<
    repl:=-1;
    for i:=1:ord-2 do
      repl:=(xi) to i .* -1 .+ repl;
    ans:=addf(red ans,!*multf(lc ans,repl)) >>;
  if not domainp ans and mvar ans eq xi
    then interr "Conjugation failure";
  return ans;
  end;

symbolic procedure sqrt2top q;
begin
  scalar n,d;
  n:=multoutdenr q;
  d:=denr n;
  n:=numr n;
  if d eq denr q
    then return q;%no change.
  if d iequal 1
    then return (n ./ 1);
  q:=gcdcoeffsofsqrts n;
  if q iequal 1
    then if minusf d
      then return (negf n ./ negf d)
      else return (n ./ d);
  q:=gcdf(q,d);
  n:=quotf(n,q);
  d:=quotf(d,q);
  if minusf d
    then return (negf n ./ negf d)
    else return (n ./ d)
    end;

%symbolic procedure denrsqrt2top q;
%begin
%  scalar n,d;
%  n:=multoutdenr q;
%  d:=denr n;
%  n:=numr n;
%  if d eq denr q
%    then return d; % no changes;
%  if d iequal 1
%    then return 1;
%  q:=gcdcoeffsofsqrts n;
%  if q iequal 1
%    then return d;
%  q:=gcdf(q,d);
%  if q iequal 1
%    then return d
%    else return quotf(d,q)
%  end;

symbolic procedure findsquareroot p;
  % Locate a sqrt symbol in poly p.
    if domainp p then nil
    else begin scalar w;
        w:=mvar p; %check main var first.
        if atom w
          then return nil; %we have passed all sqrts.
        if eqcar(w,'sqrt) then return w;
        w:=findsquareroot lc p;
        if null w then w:=findsquareroot red p;
        return w
    end;

symbolic procedure findnthroot p;
   nil;   % Until corrected.

symbolic procedure x!-findnthroot p;
    % Locate an n-th root symbol in poly p.
    if domainp p then nil
    else begin scalar w;
        w:=mvar p; %check main var first.
        if atom w
          then return nil; %we have passed all sqrts.
        if eqcar(w,'expt) and eqcar(caddr w,'quotient) then return w;
        w:=findnthroot lc p;
        if null w then w:=findnthroot red p;
        return w
    end;

symbolic procedure conjugatewrt(p,var);
  % Var -> -var in form p.
    if domainp p then p
    else if mvar p=var then begin
        scalar x,c,r;
        x:=tdeg lt p; %degree
        c:=lc p; %coefficient
        r:=red p; %reductum
        x:=remainder(x,2); %now just 0 or 1.
        if x=1 then c:=negf c; %-coefficient.
        return (lpow p .* c) .+ conjugatewrt(r,var) end
    else if ordop(var,mvar p) then p
    else (lpow p .* conjugatewrt(lc p,var)) .+
        conjugatewrt(red p,var);

symbolic procedure gcdcoeffsofsqrts u;
if atom u
  then if numberp u and minusp u
    then -u
    else u
  else if eqcar(mvar u,'sqrt)
    then begin
      scalar v;
      v:=gcdcoeffsofsqrts lc u;
      if v iequal 1
        then return v
        else return gcdf(v,gcdcoeffsofsqrts red u)
      end
    else begin
      scalar root;
      root:=findsquareroot u;
      if null root
        then return u;
      u:=makemainvar(u,root);
      root:=gcdcoeffsofsqrts lc u;
      if root iequal 1
        then return 1
        else return gcdf(root,gcdcoeffsofsqrts red u)
      end;

endmodule;


module trcase;  % Driving routine for integration of transcendental fns.

% Authors: Mary Ann Moore and Arthur C. Norman.
% Modifications by: John P. Fitch.

fluid '(!*backtrace
        !*nowarnings
        !*purerisch
        !*reverse
        badpart
        ccount
        cmap
        cmatrix
        content
        cuberootflag
        cval
        denbad
        denominator
        indexlist
        lhs!*
        loglist
        lorder
        orderofelim
        rhs!*
        sillieslist
        sqfr
        sqrtflag
        sqrtlist
        tanlist
        svar
        varlist
        xlogs
        zlist);

% !*reverse:       flag to re-order zlist.
% !*nowarnings:    flag to lose messages.

global '(!*failhard
         !*number!*
         !*ratintspecial
         !*seplogs
         !*spsize!*
         !*statistics
         !*trint
         gensymcount);

switch failhard;

exports transcendentalcase;

imports backsubst4cs,countz,createcmap,createindices,df2q,dfnumr,
  difflogs,fsdf,factorlistlist,findsqrts,findtrialdivs,gcdf,mkvect,
  interr,logstosq,mergin,multbyarbpowers,!*multf,multsqfree,
  printdf,printsq,quotf,rationalintegrate,putv,
  simpint1,solve!-for!-u,sqfree,sqmerge,sqrt2top,substinulist,trialdiv,
  mergein,negsq,addsq,f2df,mknill,pnth,invsq,multsq,domainp,mk!*sq,
  mksp,prettyprint,prepsq;

% Note that SEPLOGS keeps logarithmic part of result together as a
% kernel form, but this can lead to quite messy results.

symbolic 
   procedure transcendentalcase(integrand,svar,xlogs,zlist,varlist);
   begin scalar divlist,jhd!-content,content,prim,sqfr,dfu,indexlist,
%      JHD!-CONTENT is local, while CONTENT is free (set in SQFREE).
        sillieslist,originalorder,wrongway,
      sqrtlist,tanlist,loglist,dflogs,eprim,dfun,unintegrand,
      sqrtflag,badpart,rhs!*,lhs!*,gcdq,cmap,cval,orderofelim,cmatrix;
      scalar cuberootflag,ccount,denominator,result,denbad;
        gensymcount:=0;
      integrand:=sqrt2top integrand; % Move the sqrts to the numerator.
      if !*trint then << printc "Extension variables z<i> are";
          print zlist>>;
      if !*ratintspecial and null cdr zlist then
            return rationalintegrate(integrand,svar);
% *** now unnormalize integrand, maybe ***.
     begin scalar w,gg;
        gg:=1; 
        foreach z in zlist do <<
            w:=subs2 diffsq(simp z,svar);
            gg:=!*multf(gg,quotf(denr w,gcdf(denr w,gg))) >>; 
        gg:=quotf(gg,gcdf(gg,denr integrand)); 
        unintegrand:=(!*multf(gg,numr integrand) 
                        ./ !*multf(gg,denr integrand));
        if !*trint then <<
                printc "Unnormalized integrand =";
                printsq unintegrand >> end; 
      divlist:=findtrialdivs zlist;
                 %also puts some things on loglist sometimes.
%     if !*trint
%       then << printc "Exponentials and tans to try dividing:";
%               print divlist>>;
        sqrtlist:=findsqrts zlist;
%     if !*trint then << printc "Square-root z-variables";
%         print sqrtlist >>;
      divlist:=trialdiv(denr unintegrand,divlist);
%     if !*trint then << printc "Divisors:";
%         print car divlist;
%         print cdr divlist>>;
%n.b. the next line also sets 'content' as a free variable.
% Since SQFREE may be used later, we copy it into JHD!-CONTENT.
      prim:=sqfree(cdr divlist,zlist);
      jhd!-content:=content;
      printfactors(prim,nil);
      eprim:=sqmerge(countz car divlist,prim,nil);
      printfactors(eprim,t);
%     if !*trint then << terpri();
%         printsf denominator;
%         terpri();
%         printc "...content is:";
%         printsf jhd!-content>>;
      sqfr:=for each u in eprim collect multup u;
%      sqfr:=multsqfree eprim;
%     if !*trint then << printc "...sqfr is:";
%         superprint sqfr>>;
      if !*reverse then zlist:=reverse zlist; %ALTER ORDER FUNCTION;
      indexlist:=createindices zlist;
%     if !*trint then << printc "...indices are:";
%         superprint indexlist>>;
      dfu:=dfnumr(svar,car divlist);
%     if !*trint then << terpri();
%         printc "************ Derivative of u is:";
%         printsq dfu>>;
      loglist:=append(loglist,factorlistlist (prim,nil));
      loglist:=mergein(xlogs,loglist);
      loglist:=mergein(tanlist,loglist);
      cmap:=createcmap();
      ccount:=length cmap;
      if !*trint then << printc "Loglist ";
           print loglist >>;
      dflogs:=difflogs(loglist,denr unintegrand,svar);
      if !*trint then << printc "************ 'Derivative' of logs is:";
          printsq dflogs>>;
      dflogs:=addsq((numr unintegrand) ./ 1,negsq dflogs);
      % Put everything in reduction eqn over common denominator.
      gcdq:=gcdf(denr dflogs,denr dfu);
      dfun:= !*multf(numr dfu,
                                denbad:=quotf(denr dflogs,gcdq));
      denbad:=!*multf(denr dfu,denbad);
      denbad:= !*multf(denr unintegrand,denbad);
      dflogs:= !*multf(numr dflogs,quotf(denr dfu,gcdq));
      dfu:=dfun;
      % Now DFU and DFLOGS are S.F.s.
      rhs!*:=multbyarbpowers f2df dfu;
      if checkdffail(rhs!*,svar) then interr "Simplification failure";
      if !*trint then << printc "Distributed Form of U is:";
          printdf rhs!*>>;
      lhs!*:=f2df dflogs;
      if checkdffail(lhs!*,svar) then interr "Simplification failure";
      if !*trint then << printc "Distributed Form of l.h.s. is:";
          printdf lhs!*;
          terpri()>>;
      cval:=mkvect(ccount);
      for i:=0 : ccount do putv(cval,i,nil ./ 1);
      lorder:=maxorder(rhs!*,zlist,0);
        originalorder:=lorder;
        if !*trint then << printc "Maximum order determined as ";
                print lorder >>;
        if !*statistics then << !*number!*:=0;
                !*spsize!*:=1;
                foreach xx in lorder do
                   !*spsize!*:=!*spsize!* * (xx+1) >>;
                % That calculates the largest U that can appear.
      dfun:=solve!-for!-u(rhs!*,lhs!*,nil);
      backsubst4cs(nil,orderofelim,cmatrix);
%      if !*trint then if not (ccount=0) then printvecsq cval;
        if !*statistics then << prin2 !*number!*; prin2 " used out of ";
                printc !*spsize!* >>;
      badpart:=substinulist badpart;
                 %substitute for c<i> still in badpart.
      dfun:=df2q substinulist dfun;
%     if !*trint then superprint dfun;
      result:= !*multsq(dfun,!*invsq(denominator ./ 1));
      result:= !*multsq(result,!*invsq(jhd!-content ./ 1));
%     if !*trint then superprint result;
      dflogs:=logstosq();
      if not null numr dflogs then <<
          if !*seplogs and (not domainp numr result) then <<
              result:=mk!*sq result;
              result:=(mksp(result,1) .* 1) .+ nil;
              result:=result ./ 1 >>;
          result:=addsq(result,dflogs)>>;
      if !*trint then << superprint result;
          terpri();
          printc
          "*****************************************************";
          printc
           "************ THE INTEGRAL IS : **********************";
          printc
           "*****************************************************";
          terpri();
          printsq result;
          terpri()>>;
      if not null badpart then <<
          if !*trint then printc "plus a bad part";
          lhs!*:=badpart;
          lorder:=maxorder(rhs!*,zlist,0);
          while lorder do <<
                if car lorder > car originalorder then
                        wrongway:=t;
                lorder:=cdr lorder;
                originalorder:=cdr originalorder >>;
          dfun:=df2q badpart;
          if !*trint
            then <<printsq dfun; printc "Denbad = "; printsf denbad>>;
          dfun:= !*multsq(dfun,invsq(denbad ./ 1));
          if wrongway then << result:= nil ./ 1; dfun:=integrand >>;
          if rootcheckp(unintegrand,svar) then
                return simpint1(integrand . svar.nil)
          else if !*purerisch or allowedfns zlist then 
              dfun:=simpint1 (dfun . svar.nil)
           else << !*purerisch:=t;
                if !*trint
                  then <<printc "   [Transforming ..."; printsq dfun>>;
              denbad:=transform(dfun,svar);
              if denbad=dfun
                then dfun:=simpint1(dfun . svar.nil)
              else <<denbad:=errorset('(integratesq denbad svar xlogs),
                                      !*backtrace,!*backtrace);
                if not atom denbad then dfun:=untan car denbad
                else dfun:=simpint1(dfun . svar.nil) >> >>;
          if !*trint then printsq dfun;
          if !*failhard then rederr "FAILHARD switch set";
          if !*seplogs and not domainp result then <<
                result:=mk!*sq result;
                if not numberp result
                  then result:=(mksp(result,1) .* 1) .+ nil;
                result:=result ./ 1>>;
          result:=addsq(result,dfun) >>;
%      if !*overlaymode then excise transcode;
      return sqrt2top result
   end;

symbolic procedure checkdffail(u,v);
   u and (depends(lc u,v) or checkdffail(red u,v));

symbolic procedure printfactors(w,prdenom);
    % W is a list of factors to each power. If PRDENOM is true
    % this prints denominator of answer, else prints square-free
    % decomposition.
    begin         scalar i,wx;
        i:=1;
        if prdenom then <<
            denominator:=1;
            if !*trint
              then printc "Denominator of 1st part of answer is:";
            if not null w then w:=cdr w >>;
loopx:  if w=nil then return;
        if !*trint then <<prin2 "Factors of multiplicity "; print i>>;
        wx:=car w;
        while not null wx do <<
            if !*trint then printsf car wx;
            for j:=1 : i do 
                denominator:= !*multf(car wx,denominator);
            wx:=cdr wx >>;
        i:=i+1;
        w:=cdr w;
        go to loopx
    end;

% unfluid '(dfun svar xlogs);

endmodule;


module halfangle;  % Routines for conversion to half angle tangents.

% Author: Steve Harrington.
% Modifications by: John P. Fitch.

fluid '(!*gcd);

exports halfangle,untan;

symbolic procedure transform(u,x);
   % Transform the SQ U to remove the 'bad' functions sin, cos, cot etc
   % in favor of half angles;
   halfangle(u,x);

symbolic procedure quotqq(u1,v1);
   multsq(u1, invsq(v1));

symbolic procedure !*subtrq(u1,v1);
   addsq(u1, negsq(v1));

symbolic procedure !*int2qm(u1);
   if u1=0 then nil . 1 else u1 . 1;

symbolic procedure halfangle(r,x);
   % Top level procedure for converting;
   % R is a rational expression to be converted,
   % X the integration variable.
   % A rational expression is returned.
   quotqq(hfaglf(numr(r),x), hfaglf(denr(r),x));

symbolic procedure hfaglf(p,x);
   % Converting polynomials,  a rational expression is returned.
   if domainp(p) then !*f2q(p)
    else subs2q addsq(multsq(exptsq(hfaglk(mvar(p),x), ldeg(p)),
                             hfaglf(lc(p),x)),
                      hfaglf(red(p),x));

symbolic procedure hfaglk(k,x);
   % Converting kernels,  a rational expression is returned.
   begin
      scalar kt;
      if atom k or not member(x,flatten(cdr(k))) then return !*k2q k;
      k := car(k) . hfaglargs(cdr(k), x);
      kt := simp list('tan, list('quotient, cadr(k), 2));
      return if car(k) = 'sin
       then quotqq(multsq(!*int2qm(2),kt), addsq(!*int2qm(1),
                            exptsq(kt,2)))
      else if car(k) = 'cos
       then quotqq(!*subtrq(!*int2qm(1),exptsq(kt,2)),addsq(!*int2qm(1),
         exptsq(kt,2)))
      else if car(k) = 'tan
       then quotqq(multsq(!*int2qm(2),kt), !*subtrq(!*int2qm(1),
                            exptsq(kt,2)))
      else if car(k) = 'sinh then
        quotqq(!*subtrq(exptsq(!*k2q('expt.('e. cdr k)),2),
        !*int2qm(1)), multsq(!*int2qm(2), !*k2q('expt . ('e . cdr(k)))))
      else if car(k) = 'cosh then
        quotqq(addsq(exptsq(!*k2q('expt.('e. cdr k)),2),
        !*int2qm(1)), multsq(!*int2qm(2), !*k2q('expt . ('e . cdr(k)))))
      else if car(k) = 'tanh then
        quotqq(!*subtrq(exptsq(!*k2q('expt.('e. cdr k)),2),
        !*int2qm(1)), addsq(exptsq(!*k2q ('expt.('e.cdr(k))),2),
        !*int2qm(1)))
      else !*k2q(k);  % additional transformation might be added here.
   end;


symbolic procedure hfaglargs(l,x);
   % Conversion of argument list.
   if null l then nil
    else prepsq(hfaglk(car(l),x)) . hfaglargs(cdr(l), x);

symbolic procedure untanf x; 
   % This should be done by a table.
   begin scalar y,z,w;
      if domainp x then return x . 1; 
      y := mvar x; 
      if eqcar(y,'int) then error1();  % assume all is hopeless.
      z := ldeg x; 
      w := 1 . 1; 
      y := 
       if atom y then !*k2q y
        else if car y eq 'tan
         then if evenp z
                then <<z := z/2; 
                       simp list('quotient,
                                 list('plus,
                                      list('minus,
                                           list('cos,
                                                'times
                                                  . (2 . cdr y))),
                                      1),list('plus,
                                              list('cos,
                                                   'times
                                                     . (2 . cdr y)),
                                              1))>>
               else if z=1
                then simp list('quotient,
                               list('plus,
                                    list('minus,
                                         list('cos,
                                              'times . (2 . cdr y))),
                                    1),list('sin,
                                            'times . (2 . cdr y)))
               else <<z := (z - 1)/2; 
                      w := 
                       simp list('quotient,
                                 list('plus,
                                      list('minus,
                                           list('cos,
                                                'times
                                                  . (2 . cdr y))),
                                      1),list('sin,
                                              'times
                                                . (2 . cdr y))); 
                      simp list('quotient,
                                list('plus,
                                     list('minus,
                                          list('cos,
                                               'times
                                                 . (2 . cdr y))),
                                     1),list('plus,
                                             list('cos,
                                                  'times
                                                    . (2 . cdr y)),
                                             1))>>
        else simp y;
      return addsq(multsq(multsq(exptsq(y,z),untanf lc x),w),
                   untanf red x)
   end;

symbolic procedure untanlist(y);
   if null y then nil
    else (prepsq (untan(simp car y)) . untanlist(cdr y));

symbolic procedure untan(x);
   % Expects x to be canonical quotient.
   begin scalar y;
      y:=cossqchk sinsqrdchk multsq(untanf(numr x),
                                    invsq untanf(denr x));
      return if length flatten y>length flatten x then x else y
   end;

symbolic procedure sinsqrdchk(x);
   multsq(sinsqchkf(numr x), invsq sinsqchkf(denr x));

symbolic procedure sinsqchkf(x);
   begin
      scalar y,z,w;
      if domainp x then return x . 1;
      y := mvar x;
      z := ldeg x;
      w := 1 . 1;
      y := if eqcar(y,'sin) then if evenp z
       then <<z := quotient(z,2);
              simp list('plus,1,list('minus,
                                     list('expt,('cos . cdr(y)),2)))>>
      else if z = 1 then !*k2q y
      else  << z := quotient(difference(z,1),2); w := !*k2q y;
             simp list('plus,1,list('minus,
                                    list('expt,('cos . cdr(y)),2)))>>
       else !*k2q y;
      return addsq(multsq(multsq(exptsq(y,z),sinsqchkf(lc x)),w),
                   sinsqchkf(red x));
   end;

symbolic procedure cossqchkf(x);
   begin
      scalar y,z,w,x1,x2;
      if domainp x then return x . 1;
      y := mvar x;
      z := ldeg x;
      w := 1 . 1;
      x1 := cossqchkf(lc x);
      x2 := cossqchkf(red x);
      x := addsq(multsq(!*p2q lpow x,x1),x2);
      y := if eqcar(y,'cos) then if evenp z
       then <<z := quotient(z,2);
              simp list('plus,1,list('minus,
                                     list('expt,('sin . cdr(y)),2)))>>
      else if z = 1 then !*k2q y
      else  << z := quotient(difference(z,1),2); w := !*k2q y;
             simp list('plus,1,list('minus,
                                    list('expt,('sin . cdr(y)),2)))>>
       else !*k2q y;
      y := addsq(multsq(multsq(exptsq(y,z),w),x1),x2);
      return if length(y) > length(x) then x else y;
   end;

symbolic procedure cossqchk(x);
begin scalar !*gcd;
   !*gcd := t;
   return multsq(cossqchkf(numr x), invsq cossqchkf(denr x))
end;

symbolic procedure lrootchk(l,x);
   % Checks each member of list l for a root.
   if null l then nil else krootchk(car l, x) or lrootchk(cdr l, x);

symbolic procedure krootchk(f,x);
   % Checks a kernel to see if it is a root.
   if atom f then nil
    else if car(f) = 'sqrt and member(x, flatten cdr f) then t
   else if car(f) = 'expt
        and not atom caddr(f)
        and caaddr(f) = 'quotient
        and member(x, flatten cadr f)  then t
   else lrootchk(cdr f, x);

symbolic procedure rootchk1p(f,x);
   % Checks polynomial for a root.
   if domainp f then nil
    else krootchk(mvar f,x) or rootchk1p(lc f,x) or rootchk1p(red f,x);

symbolic procedure rootcheckp(f,x);
   % Checks rational (standard quotient) for a root.
   rootchk1p(numr f,x) or rootchk1p(denr f,x);

endmodule;


module trialdiv;  % Trial division routines.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(denominator loglist tanlist);

global '(!*trint);

exports countz,findsqrts,findtrialdivs,trialdiv,simp,mksp;

imports !*multf,printsf,quotf;

symbolic procedure countz dl;
% DL is a list of S.F.s;
    begin         scalar s,n,rl;
loop2:  if null dl then return arrangelistz rl;
        n:=1;
loop1:  n:=n+1;
        s:=car dl;
        dl:=cdr dl;
        if not null dl and (s eq car dl) then
            go to loop1
        else rl:=(s.n).rl;
        go to loop2
    end;

symbolic procedure arrangelistz d;
    begin         scalar n,s,rl,r;
        n:=1;
        if null d then return rl;
loopd:  if (cdar d)=n then s:=(caar d).s
        else r:=(car d).r;
        d:=cdr d;
        if not null d then go to loopd;
        d:=r;
        rl:=s.rl;
        s:=nil;
        r:=nil;
        n:=n+1;
        if not null d then go to loopd;
        return reversewoc rl
    end;

symbolic procedure findtrialdivs zl;
%zl is list of kernels found in integrand. result is a list
%giving things to be treated specially in the integration
%viz: exps and tans.
%Result is list of form ((a . b) ...)
% with a a kernel and car a=expt or tan
% and b a standard form for either expt or (1+tan**2).
    begin         scalar dlists1,args1;
        while not null zl do <<
            if exportan car zl then <<
                if caar zl='tan
                  then << args1:=(mksp(car zl,2) .* 1) .+ 1;
                    tanlist:=(args1 ./ 1) . tanlist>>
                else args1:=!*k2f car zl;
                dlists1:=(car zl . args1) . dlists1>>;
            zl:=cdr zl >>;
        return dlists1
    end;

symbolic procedure exportan dl;
    if atom dl then nil
    else begin
    % extract exp or tan fns from the z-list.
    if eq(car dl,'tan) then return t;
nxt:    if not eq(car dl,'expt) then return nil;
        dl:=cadr dl;
        if atom dl then return t;
% Make sure we find nested exponentials?
        go to nxt
    end;

symbolic procedure findsqrts z; 
    begin  scalar r; 
        while not null z do << 
            if eqcar(car z,'sqrt) then r:=(car z) . r; 
            z:=cdr z >>; 
        return r 
    end; 

symbolic procedure trialdiv(x,dl);
    begin         scalar qlist,q;
    while not null dl do
        if not null(q:=quotf(x,cdar dl)) then <<
            if (caaar dl='tan) and not eqcar(qlist,cdar dl) then
                loglist:=('iden . simp cadr caar dl) . loglist;
                         %tan fiddle!
            qlist:=(cdar dl).qlist;
            x:=q >>
        else dl:=cdr dl;
    return qlist.x
    end;

endmodule;


module unifac;  % Univariate factorization for integration.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(knowndiscrimsign zlist);

global '(!*trint);

exports unifac;

imports cubic,linfac,printdf,quadfac,quadratic,quartic,vp1,
        gcd,minusp,prettyprint;

symbolic procedure unifac(pol,var,degree,res);
    begin         scalar w,q,c;
        w:=pol;
        if !*trint then superprint w;
%now try looking for linear factors.
trylin: q:=linfac(w);
        if null car q then go to nomorelin;
        res := ('log . back2df(car q,var)) . res;
        w:=cdr q;
        go to trylin;
nomorelin:
        q:=quadfac(w);
        if null car q then go to nomorequad;
        res := quadratic(back2df(car q,var),var,res);
        w:=cdr q;
        go to nomorelin;
nomorequad:
        if null w then return res; %all done.
        degree:=car w; %degree of what is left.
        c:=back2df(w,var);
        if degree=3 then res:=cubic(c,var,res)
        else if degree=4 then res:=quartic(c,var,res)
        else if evenp degree and
                pairp (q := halfpower cddr w)
         then <<w := (degree/2) . (cadr w . q);
                w := unifac(w,var,car w,nil);
                res := pluckfactors(w,var,res)>>
        else <<
            printc "The following has not been split";
            printdf c;
            res:=('log . c) . res>>;
        return res
    end;

symbolic procedure halfpower w;
   if null w then nil
    else if car w=0 
     then (lambda r;
           if r eq 'failed then r else cadr w . r) halfpower cddr w
    else 'failed;

symbolic procedure pluckfactors(w,var,res);
   begin scalar p,q,knowndiscrimsign;
      while w do
        <<p := car w;
          if car p eq 'atan then nil
           else if car p eq 'log
            then <<q := doublepower cdr p . q;
                   %prin2 "q="; %printdf car q;
                  >>
           else interr "Bad form";
          w := cdr w>>;
      while q do
       <<p := car q;
         if caaar p=4 
           then <<knowndiscrimsign := 'negative;
                  res := quartic(p,var,res);
                  knowndiscrimsign := nil>>
           else if caaar p=2 
            then res := quadratic(p,var,res)
           else res := ('log . p) . res;
          q := cdr q>>;
      return res
   end;

symbolic procedure doublepower r;
   if null r then nil
    else ((for each j in caar r collect 2*j) . cdar r)
           . doublepower cdr r;

symbolic procedure back2df(p,v);
  % Undo the effect of uniform.
    begin         scalar r,n;
        n:=car p;
        p:=cdr p;
        while not minusp n do <<
            if not zerop car p then r:=
                (vp1(v,n,zlist) .* (car p ./ 1)) .+ r;
            p:=cdr p;
            n:=n-1 >>;
        return reversewoc r
    end;

endmodule;


module uniform;  % Convert from D.F. to list of coefficients.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(zlist);

exports uniform;

imports exponentof;

symbolic procedure uniform(p,v);
%Convert from d.f. in one variable (v) to a simple list of
%coeffs (with degree consed onto front).
%Fails if coefficients are not all simple integers.
    if null p then 0 . (0 . nil)
    else begin    scalar a,b,c,d;
        a:=exponentof(v,lpow p,zlist);
        b:=lc p;
        if not(denr b=1) then return 'failed;
        b:=numr b;
        if null b then b:=0
        else if not numberp b then return 'failed;
        if a=0 then return a . (b . nil); %constant term.
        c:=uniform(red p,v);
        if c='failed then return 'failed;
        d:=car c;
        c:=cdr c;
        d:=d+1;
        while not (a=d) do <<
            c:=0 . c;
            d:=d+1>>;
        return a . (b . c)
    end;

endmodule;


module makevars; % Make dummy variables for integration process.

% Authors: Mary Ann Moore and Arthur C. Norman.

fluid '(!*gensymlist!* !*purerisch);

exports getvariables,varsinlist,varsinsq,varsinsf,findzvars,
        createindices,mergein;

imports dependsp,union;

% Note that 'i' is already maybe committed for sqrt(-1),
% also 'l' and 'o' are not used as they print badly on certain
% terminals etc and may lead to confusion.

!*gensymlist!* := '(! j ! k ! m ! n ! p ! q ! r ! s ! t ! u ! v ! w ! x
                    ! y ! z);

%mapc(!*gensymlist!*,function remob); %REMOB protection;


symbolic procedure varsinlist(l,vl);
% L is a list of s.q. - find all variables mentioned,
% given thal vl is a list already known about.
    begin       while not null l do <<
            vl:=varsinsf(numr car l,varsinsf(denr car l,vl));
            l:=cdr l >>;
        return vl
    end;

symbolic procedure getvariables sq;
    varsinsf(numr sq,varsinsf(denr sq,nil));

symbolic procedure varsinsq(sq,vl);
  varsinsf(numr sq,varsinsf(denr sq,vl));

symbolic procedure varsinsf(form,l);
   if domainp form then l
   else begin
     while not domainp form do <<
        l:=varsinsf(lc form,union(l,list mvar form));
        form:=red form >>;
     return l
   end;

symbolic procedure findzvars(vl,zl,var,flg);
    begin         scalar v;
% VL is the crude list of variables found in the original integrand;
% ZL must have merged into it all EXP, LOG etc terms from this.
% If FLG is true then ignore DF as a function.
scan: if null vl then return zl;
         v:=car vl; % next variable.
         vl:=cdr vl;
% at present items get put onto ZL if they are non-atomic
% and they depend on the main variable. The arguments of
% functions are decomposed by recursive calls to findzvar.
        %give up if V has been declared dependent on other things;
        if atom v and v neq var and depends(v,var) then 
           rederr "Can't integrate in the presence of side-relations"
         else if not atom v and (not v member zl) and dependsp(v,var)
         then if car v='!*sq then zl:=findzvarssq(cadr v,zl,var)
         else if car v memq '(times quotient plus minus difference int)
                 or (((car v) eq 'expt) and fixp caddr v)
             then
                 zl:=findzvars(cdr v,zl,var,flg)
         else if flg and car v eq 'df
          then <<!*purerisch := t; return zl>> % try and stop it
             else zl:=v . findzvars(cdr v,zl,var,flg);
                 % scan arguments of fn.
             %ACH: old code used to look only at CADR if a DF involved.
        go to scan
   end;

symbolic procedure findzvarssq(sq,zl,var);
    findzvarsf(numr sq,findzvarsf(denr sq,zl,var),var);

symbolic procedure findzvarsf(sf,zl,var);
    if domainp sf then zl
    else findzvarsf(lc sf,
                    findzvarsf(red sf,
                               findzvars(list mvar sf,zl,var,nil),
                               var),
                  var);

symbolic procedure createindices zl; 
% Produces a list of unique indices, each associated with a ; 
% different Z-variable; 
     reversewoc crindex1(zl,!*gensymlist!*); 
 
symbolic procedure crindex1(zl,gl); 
 begin if null zl then return nil; 
    if null gl then << gl:=list int!-gensym1 'i; %new symbol needed;
        nconc(!*gensymlist!*,gl) >>; 
    return (car gl) . crindex1(cdr zl,cdr gl) end; 

symbolic procedure rmember(a,b);
    if null b then nil
    else if a=cdar b then car b
    else rmember(a,cdr b);

symbolic procedure mergein(dl,ll);
    % Adjoin logs of things in dl to existing list ll.
    if null dl then ll
    else if rmember(car dl,ll) then mergein(cdr dl,ll)
    else mergein(cdr dl,('log . car dl) . ll);

endmodule;


module vect;  % Vector support routines.

% Authors: Mary Ann Moore and Arthur C. Norman.
% Modified by: James H. Davenport.

exports mkuniquevect,mkvec,mkvecf2q,mkidenm,copyvec,vecsort,swap,
        non!-null!-vec,mkvect2;

symbolic procedure mkuniquevect v;
begin scalar u,n;
  n:=upbv v;
  for i:=0:n do begin
    scalar uu;
    uu:=getv(v,i);
    if not (uu member u)
      then u:=uu.u
    end;
  return mkvec u
  end;

symbolic procedure mkvec(l);
begin scalar v,i;
  v:=mkvect(isub1 length l);
  i:=0;
  while l do <<putv(v,i,car l); i:=iadd1 i; l:=cdr l>>;
  return v
  end;

symbolic procedure mkvecf2q(l);
begin
  scalar v,i,ll;
  v:=mkvect(isub1 length l);
  i:=0;
  while l do <<
    ll:=car l;
    if ll = 0 then ll:=nil;
    putv(v,i,!*f2q ll);
    i:=iadd1 i;
    l:=cdr l >>;
  return v
  end;

symbolic procedure mkidenm n;
begin
  scalar ans,u;
  scalar c0,c1;
  c0:=nil ./ 1;
  c1:= 1 ./ 1;
  % constants.
  ans:=mkvect(n);
  for i:=0 step 1 until n do <<
    u:=mkvect n;
    for j:=0 step 1 until n do
      if i iequal j
        then putv(u,j,c1)
        else putv(u,j,c0);
    putv(ans,i,u) >>;
  return ans
  end;

symbolic procedure copyvec(v,n);
   begin scalar new;
    new:=mkvect(n);
    for i:=0:n do putv(new,i,getv(v,i));
    return new
   end;

symbolic procedure vecsort(u,l);
% Sorts vector v of numbers into decreasing order.
% Performs same interchanges of all vectors in the list l.
begin
  scalar j,k,n,v,w;
  n:=upbv u;% elements 0...n exist.
  % algorithm used is a bubble sort.
  for i:=1:n do begin
    v:=getv(u,i);
    k:=i;
  loop:
    j:=k;
    k:=isub1 k;
    w:=getv(u,k);
    if v<=w
      then goto ordered;
    putv(u,k,v);
    putv(u,j,w);
    mapc(l,function (lambda u;swap(u,j,k)));
    if k>0
      then goto loop;
  ordered:
    end;
  return nil
  end;

symbolic procedure swap(u,j,k);
if null u
  then nil
  else begin
    scalar v;
    %swaps elements i,j of vector u.
    v:=getv(u,j);
    putv(u,j,getv(u,k));
    putv(u,k,v)
    end;

symbolic procedure non!-null!-vec v;
begin
  scalar cnt;
  cnt := 0;
  for i:=0:upbv v do
    if getv(v,i)
      then cnt:=iadd1 cnt;
  return cnt
  end;

symbolic procedure mkvect2(n,initial);
begin
  scalar u;
  u:=mkvect n;
  for i:=0:n do
    putv(u,i,initial);
  return u
  end;

endmodule;


end;

Added r33/mathlib.red version [099f0ed8fd].



























































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
MODULE MATHLIB;  % Some useful mathematical functions.

% Authors: W. Galway, M. L. Griss, A. C. Hearn. D. Irish, A. C. Norman,
%          D. Morrison.

% ***** Constants declared as NewNam's *****

% We can't use these long numbers in some Lisps because the reader can't
% handle them (and it would truncate instead of round, anyway).  These
% are here for reference for implementation on other machines.

% put('NumberPi,'NewNam,3.14159265358979324);
% put('NumberPi!/2,'NewNam,1.57079632679489662);
% put('NumberPi!/4,'NewNam,0.785398163397448310);

deflist('((Number2Pi 6.2831853)
          (NumberPi 3.1415927)
          (NumberPi!/2 1.5707963)
          (NumberPi!/4 0.78539816)
          (Number3Pi!/4 2.3561945)
          (Number!-2Pi -6.2831853)
          (Number!-Pi -3.1415927)
          (Number!-Pi!/2 -1.5707963)
          (Number!-Pi!/4 -0.78539816)
          (SqrtTolerance 0.0000001)
          (NumberE 2.718281828)
          (NumberInverseE 0.36787944)
          (NaturalLog2 0.69314718)
          (NaturalLog10 2.3025851)
          (TrigPrecisionLimit 80)),
'newnam);

% ***** Basic Functions *****

symbolic procedure mod(M,N);
   % Returns M modulo N.  Unlike remainder function, it returns
   % positive result in range 0..N-1, even if M is negative.
   % Needs more work for case of negative N.)
   (if result >= 0 then result else result + N)
      where result = remainder(M,N);

symbolic procedure Floor x;
   % Returns the largest integer less than or equal to x
   % (i.e. the "greatest integer" function.)
   % Note the trickiness to compensate for fact that (unlike APL's
   % "FLOOR" function) FIX truncates towards zero.
   if fixp x then x
    else (if x = float n then n else if x >= 0 then n else n-1)
       where n = fix x;

symbolic procedure Ceiling X;
   % Returns the smallest integer greater than or equal to X.
   % Note the trickiness to compensate for fact that (unlike APL's
   % "FLOOR" function) FIX truncates towards zero.
   if fixp X then X
    else (if x = float n then n else if x >= 0 then n+1 else n)
       where n = fix x;

symbolic procedure Round X;
   % Rounds to the closest integer.
   % Kind of sloppy -- it's biased when the digit causing rounding is a
   % five. It's a bit weird with negative arguments, round(-2.5)= -2.
   if fixp X then X else floor(X+0.5);

% ***** Trigonometric Functions *****

% Trig functions are all in radians.  The following few functions may
% be used to convert to/from degrees, or degrees/minutes/seconds.

symbolic procedure DegreesToRadians x;
   x*0.017453292; % 2*pi/360

symbolic procedure RadiansToDegrees x;
   x*57.29578;    % 360/(2*pi)

symbolic procedure RadiansToDMS x;
    % Converts radians to a list of degrees, minutes, and seconds
    % (rounded, not truncated, to the nearest integer).
    begin scalar Degs,Mins;
       x := RadiansToDegrees x;
       Degs := fix x;
       x := 60*(x-Degs);
       Mins := fix x;
       return list(Degs,Mins, Round(60*(x-Mins)))
    end;

symbolic procedure DMStoRadians(Degs,Mins,Sex);
   % Converts degrees, minutes, seconds to radians.
   % DegreesToRadians(Degs+Mins/60.0+Sex/3600.0)
   DegreesToRadians(Degs+Mins*0.016666667+Sex*0.00027777778);

symbolic procedure sin x;
   % Accurate to about 6 decimal places, so long as the argument is
   % of commensurate precision.  This will, of course, NOT be true for
   % large arguments, since they will be coming in with small precision.
   begin scalar neg;
      if minusp x then <<neg := T; x := -x>>;
      if x>TrigPrecisionLimit
        then ErrorPrintF
                "Possible loss of precision in computation of SIN";
      if x>NumberPi then x := x-Number2Pi*fix((x+NumberPi)/Number2Pi);
      if minusp x then <<neg := not neg; x := -x>>;
      if x > NumberPi!/2 then x := NumberPi-x;
      return if neg then -ScaledSine x else ScaledSine x
   end;

symbolic procedure ScaledSine x;
   % assumes its argument is scaled to between 0 and pi/2.
   begin scalar xsqrd;
      xsqrd := x*x;
      return x*(1+xsqrd*(-0.16666667+xsqrd*(0.0083333315
                   +xsqrd*(-0.0001984090
                      +xsqrd*(0.0000027526-xsqrd*0.0000000239)))))
   end;

symbolic procedure cos x;
   % Accurate to about 6 decimal places, so long as the argument is
   % of commensurate precision.  This will, of course, NOT be true for
   % large arguments, since they will be coming in with small precision.
   <<if minusp x then x := - x;
     if x>TrigPrecisionLimit
       then ErrorPrintf
               "Possible loss of precision in computation of COS";
     if x>NumberPi then x := x-Number2Pi*fix((x+NumberPi)/Number2Pi);
     if minusp x then x := -x;
     if x>NumberPi!/2 then -ScaledCosine(NumberPi-x)
      else ScaledCosine x>>;

symbolic procedure ScaledCosine x;
   % Expects its argument to be between 0 and pi/2.
   begin scalar xsqrd;
      xsqrd := x*x;
      return 1+xsqrd*(-0.5+xsqrd*(0.041666642+xsqrd*(-0.0013888397+
                  xsqrd*(0.0000247609-xsqrd*0.0000002605))))
   end;

symbolic procedure tan x;
   % Accurate to about 6 decimal places, so long as the argument is
   % of commensurate precision.  This will, of course, NOT be true for
   % large arguments, since they will be coming in with small precision.
   begin scalar neg;
      if minusp x then <<neg := T; x := -x>>;
      if x>TrigPrecisionLimit
        then ErrorPrintF
                "Possible loss of precision in computation of TAN";
      if x>NumberPi!/2
        then x := x-NumberPi*fix((x+NumberPi!/2)/NumberPi);
      if minusp x then <<neg := not neg; x := -x>>;
      if x<NumberPi!/4 then x := ScaledTangent x
       else x := ScaledCotangent(-(x-numberpi!/2));
      return if neg then -x else x
   end;

symbolic procedure cot x;
   % Accurate to about 6 decimal places, so long as the argument is
   % of commensurate precision.  This will, of course, NOT be true for
   % large arguments, since they will be coming in with small precision.
   begin scalar neg;
     if minusp x then <<neg := T; x := -x>>;
     if x>NumberPi!/2
       then x := x-NumberPi*fix((x+NumberPi!/2)/NumberPi);
     if x>TrigPrecisionLimit
       then ErrorPrintF
               "Possible loss of precision in computation of COT";
     if minusp x then <<neg := not neg; x := -x>>;
     if x<NumberPi!/4 then x := ScaledCotangent x
      else x := ScaledTangent(-(x-numberpi!/2));
     return if neg then -x else x
   end;

symbolic procedure ScaledTangent x;
   % Expects its argument to be between 0 and pi/4.
   (x*(1.0+xsqrd*(0.3333314+xsqrd*(0.1333924
                   +xsqrd*(0.05337406 + xsqrd*(0.024565089
                       +xsqrd*(0.002900525+xsqrd*0.0095168091)))))))
      where xsqrd = x*x;

symbolic procedure ScaledCotangent x;
   % Expects its argument to be between 0 and pi/4.
   ((1.0-xsqrd*(0.33333334+xsqrd*(0.022222029+xsqrd*(0.0021177168 +
              xsqrd*(0.0002078504+xsqrd*0.0000262619)))))/x)
      where xsqrd = x*x;

symbolic procedure sec x; 1.0/cos x;

symbolic procedure csc x; 1.0/sin x;

symbolic procedure sinD x; sin DegreesToRadians x;

symbolic procedure cosD x; cos DegreesToRadians x;

symbolic procedure tanD x; tan DegreesToRadians x;

symbolic procedure cotD x; cot DegreesToRadians x;

symbolic procedure secD x; sec DegreesToRadians x;

symbolic procedure cscD x; csc DegreesToRadians x;

symbolic procedure asin x;
   begin scalar neg;
      if minusp x then <<neg := T; x := -x>>;
      if x>1.0 then stderror list("Argument to ASIN too large:",x);
      return if neg then CheckedArcCosine x - NumberPi!/2
              else NumberPi!/2 - CheckedArcCosine x
   end;

symbolic procedure acos x;
   begin scalar neg;
     if minusp x then <<neg := T; x := -x>>;
     if x>1.0 then stderror list("Argument to ACOS too large:",x);
     return if neg then NumberPi - CheckedArcCosine x
             else CheckedArcCosine x
   end;

symbolic procedure CheckedArcCosine x;
   % Return cosine of a "checked number", assumes its argument is in
   % the range 0 <= x <= 1.
   sqrt(1.0-x)*(1.5707963+x*(-0.2145988+x*(0.088978987+x*(-0.050174305+
           x*(0.030891881+x*(-0.017088126+x*(0.0066700901
                                              -x*(0.0012624911))))))));

symbolic procedure atan x;
   if minusp x
     then if x < -1.0 then Number!-Pi!/2 + CheckedArcTangent(-1.0/x)
           else -CheckedArcTangent(-x)
    else if x>1.0 then NumberPi!/2 - CheckedArcTangent(1.0/x)
    else CheckedArcTangent x;

symbolic procedure acot x;
   if minusp x
     then if x<-1.0 then -CheckedArcTangent(-1.0/x)
           else Number!-Pi!/2 + CheckedArcTangent(-x)
    else if x>1.0 then CheckedArcTangent(1.0/x)
    else NumberPi!/2 - CheckedArcTangent x;

symbolic procedure CheckedArcTangent x;
   (x*(1+xsqrd*(-0.33333145+xsqrd*(0.19993551+xsqrd*(-0.14208899+
           xsqrd*(0.10656264+xsqrd*(-0.07528964+xsqrd*(0.042909614+
             xsqrd*(-0.016165737+xsqrd*0.0028662257)))))))))
      where xsqrd = x*x;

symbolic procedure asec x; acos(1.0/x);

symbolic procedure acsc x; asin(1.0/x);

symbolic procedure asinD x; RadiansToDegrees asin x;

symbolic procedure acosD x; RadiansToDegrees acos x;

symbolic procedure atanD x; RadiansToDegrees atan x;

symbolic procedure acotD x; RadiansToDegrees acot x;

symbolic procedure asecD x; RadiansToDegrees asec x;

symbolic procedure acscD x; RadiansToDegrees acsc x;


% ***** Hyperbolic Functions *****

symbolic procedure sinh x; (exp x - exp(-x))/2.0;

symbolic procedure cosh x; (exp x + exp(-x))/2.0;

symbolic procedure tanh x; sinh x/cosh x;

symbolic procedure csch x; 1/sinh x;

symbolic procedure sech x; 1/cosh x;

symbolic procedure coth x; 1/tanh x;

symbolic procedure asinh x; log(x + sqrt(x**2+1.0));

symbolic procedure acosh x;
   <<if x<0 then x := -x;
     if x<1 then stderror list("Argument to ACOSH too small:",x);
     log(x + sqrt(x**2-1.0))>>;

symbolic procedure atanh x;
   begin scalar neg;
      if x<0 then <<neg := t; x := -x>>;
      if x>=1 then stderror list("Argument to ATANH too large:",x);
      x := log((1.0+x)/(1-x));
      return if neg then -x else x
   end;

symbolic procedure acsch x;
   if x=0 then stderror "0 invalid argument to ACSCH"
    else log(y + sqrt(y**2+1)) where y = 1.0/x;

symbolic procedure asech x;
   <<if x<0 then x := -x;
     if x>1 then stderror list("Argument to ASECH too large:",x);
     log(y + sqrt(y**2-1)) where y = 1.0/x>>;

symbolic procedure acoth x;
   begin scalar neg;
      if x=0 then stderror "0 invalid argument to ACOTH"
       else if x<0 then <<neg := t; x := -x>>;
      if x<=1 then stderror list("Argument to ACOTH too small:",x);
      x := log((x+1.0)/(x-1));
      return if neg then -x else x
   end;


% ***** Roots and Such *****

symbolic procedure sqrt N;
   % Simple Newton-Raphson floating point square root calculator.
   % Not warranted against truncation errors, etc.
   begin integer scale; scalar answer;
      N:=FLOAT N;
      if N<0.0 then stderror list("SQRT given negative argument:",N);
      if zerop N then return N;
      % Scale argument to within 1e-10 to 1e+10;
      scale := 0;
      while N > 1.0E10 do <<scale := scale + 1; N := N * 1.0E-10>>;
      while N < 1.0E-10 do <<scale := scale - 1; N := N * 1.0E10>>;
      answer := if N>2.0 then (N+1)/2
                 else if N<0.5 then 2/(N+1)
                 else N;
      % Here's the heart of the algorithm.
      while abs(answer**2/N - 1.0) > SqrtTolerance do
         answer := 0.5*(answer+N/answer);
      return answer * 10.0**(5*scale)
   end;

% ***** Logs and Exponentials *****

symbolic procedure exp x;
   % Returns the exponential (ie, e**x) of its floatnum argument as
   % a flonum. The argument is scaled to
   % the interval -ln  2 to  0, and a  Taylor series  expansion
   % used (formula 4.2.45 on page 71 of Abramowitz and  Stegun,
   % "Handbook of Mathematical  Functions"). Note that little effort
   % has been expended to minimize truncation errors.
   % On many systems it will be appropriate to define a system-
   % specific EXP routine that does bother about rounding and that
   % understands the precision of the host floating point arithmetic;
   begin scalar N;
     N := ceiling(x / NaturalLog2);
     x := N * NaturalLog2 - x;
     return 2.0**N * (1.0+x*(-0.9999999995+x*(0.4999999206
               +x*(-0.1666653019+x*(0.0416573475+x*(-0.0083013598
                   +x*(0.0013298820+x*(-0.0001413161))))))))
   end;

symbolic procedure log x;
   % See Abramowitz and Stegun, page 69.
   if x<=0.0 then stderror list("LOG given non-positive argument:",x)
    else if x < 1.0 then -log(1.0/x)
    else
    % Find natural log of x > 1;
    begin scalar nextx, ipart;      % ipart is the "integer part" of
                                    % the logarithm.
      ipart := 0;

      % Keep multiplying by 1/e until x is small enough, may want to
      % be more "efficient" if we ever use really big numbers.
      while (nextx := NumberInverseE * x) > 1.0 do
        <<x := nextx; ipart := ipart + 1>>;
      return ipart + if x < 2.0 then CheckedLogarithm x
                      else 2.0 * CheckedLogarithm(sqrt(x))
    end;
 
symbolic procedure CheckedLogarithm x;
% Should have 1 <= x <= 2.  (i.e. x = 1+y  0 <= y <= 1)
   <<x := x-1.0;
     x*(0.99999642+x*(-0.49987412+x*(0.33179903+x*(-0.24073381
        +x*(0.16765407+x*(-0.09532939
            +x*(0.036088494-x*0.0064535442)))))))>>;

symbolic procedure log2 x; log x / NaturalLog2;

symbolic procedure log10 x; log x / NaturalLog10;

symbolic procedure factorial n;   % simple factorial
   if n<0 or not fixp n
     then error(50,list(n,"invalid factorial argument"))
    else begin scalar m;
       m:=1;
       for i:=1:n do m:=m*i;
       return m;
     end;


% Some functions from ALPHA_1 users

symbolic procedure atan2d( y, x );
   radianstodegrees atan2( y, x );

symbolic procedure atan2( y, x );
  <<x := float x;
    y := float y;
    if x = 0.0
      then if y>=0.0 then numberpi!/2 else numberpi+numberpi!/2
     else if x>=0.0 and y>=0.0 then atan(y/x)  % first quadrant.
     else if x<0.0 and y>=0.0 then numberpi - atan(y/-x)
        % second quadrant.
     else if x<0.0 and y<0.0 then numberpi + atan(y/x)
        % third quadrant.
     else number2pi - atan(-y/x)   % fourth quadrant.
   >>;

symbolic procedure transfersign( s, val );
   % transfers the sign of s to val by returning abs(val) if s >= 0,
   % otherwise -abs(val).
   if s >= 0 then abs(val) else -abs(val);

symbolic procedure dmstodegrees(degs,mins,sex);
   % converts degrees, minutes, seconds to degrees
   % degs+mins/60.0+sex/3600.0
   degs+mins*0.016666667+sex*0.00027777778;

symbolic procedure degreestodms x;
   % converts degrees to a list of degrees, minutes, and seconds
   % (all integers, rounded, not truncated).
   begin scalar degs,mins;
      degs := fix x;
      x := 60*(x-degs);
      mins := fix x;
      return list(degs,mins, round(60*(x-mins)))
   end;

endmodule;

end;

Added r33/matr.red version [be96d4b0f1].













































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
module matr;

% Author: Anthony C. Hearn;

% This module is rife with essential references to RPLAC-based
% functions.

fluid '(!*sub2);

global '(nxtsym!* subfg!*);

symbolic procedure matrix u;
   %declares list U as matrices;
   begin scalar v,w,x;
        for each j in u do
           if atom j then if null (x := gettype j)
                            then put(j,'rtype,'matrix)
                           else if x eq 'matrix             
                            then <<lprim list(x,j,"redefined");
                                   put(j,'rtype,'matrix)>>
                           else typerr(list(x,j),"matrix")
            else if not idp car j
                   or length (v := revlis cdr j) neq 2
                   or not natnumlis v
             then errpri2(j,'hold)
            else if not (x := gettype car j) or x eq 'matrix
             then <<w := nil;
                    for n := 1:car v do w := nzero cadr v . w;
                    put(car j,'rtype,'matrix);
                    put(car j,'rvalue,'mat . w)>>
            else typerr(list(x,car j),"matrix")
   end;

symbolic procedure natnumlis u;
   % True if U is a list of natural numbers.
   null u
      or numberp car u and fixp car u and car u>0 and natnumlis cdr u;

rlistat '(matrix);

symbolic procedure nzero n;
   % Returns a list of N zeros.
   if n=0 then nil else 0 . nzero(n-1);

% Parsing interface.

symbolic procedure matstat;
   % Read a matrix.
   begin scalar x,y;
   a: scan();
      scan();
      y := xread 'paren;
      if not eqcar(y,'!*comma!*) then y := list y else y := remcomma y;
      x := y . x;
      if nxtsym!* eq '!)
        then return <<scan(); scan(); 'mat . reversip x>>
       else if not(nxtsym!* eq '!,) then symerr("Syntax error",nil);
      go to a
   end;

put('mat,'stat,'matstat);

symbolic procedure formmat(u,vars,mode);
   'list . mkquote 'mat
     . for each x in cdr u collect('list . formlis(x,vars,mode));

put('mat,'formfn,'formmat);

put('mat,'i2d,'mkscalmat);

put('mat,'inversefn,'matinverse);

put('mat,'lnrsolvefn,'lnrsolve);

put('mat,'rtypefn,'(lambda (x) 'matrix));

flag('(mat tp),'matflg);

flag('(mat),'noncommuting);

put('mat,'prifn,'matpri);

flag('(mat),'struct);      % for parsing

put('matrix,'fn,'matflg);

put('matrix,'evfn,'matsm!*);

flag('(matrix),'sprifn);

put('matrix,'tag,'mat);

put('matrix,'lengthfn,'matlength);

put('matrix,'getelemfn,'getmatelem);

put('matrix,'setelemfn,'setmatelem);

symbolic procedure mkscalmat u;
   % Converts id u to 1 by 1 matrix.
   list('mat,list u);

symbolic procedure getmatelem u;
   begin scalar x;
      x := get(car u,'rvalue);
      if not eqcar(x,'mat) then rederr list("Matrix",car u,"not set")
       else if not numlis (u := revlis cdr u) or length u neq 2
        then errpri2(x . u,t);
      return nth(nth(cdr x,car u),cadr u)
   end;

symbolic procedure setmatelem(u,v); letmtr(u,v,get(car u,'rvalue));

symbolic procedure matlength u;
   if not eqcar(u,'mat) then rederr list("Matrix",u,"not set")
    else list('list,length cdr u,length cadr u);

symbolic procedure matsm!*(u,v);
   % Matrix expression simplification function.
   begin
        u := 'mat . for each j in matsm u collect
                        for each k in j collect mk!*sq2 k;
        !*sub2 := nil;   %since all substitutions done;
        return u
   end;

symbolic procedure mk!*sq2 u;
   begin scalar x;
        x := !*sub2;   %since we need value for each element;
        u := subs2 u;
        !*sub2 := x;
        return mk!*sq u
   end;

symbolic procedure matsm u;
   begin scalar x,y;
      for each j in nssimp(u,'matrix) do 
         <<y := multsm(car j,matsm1 cdr j);
           x := if null x then y else addm(x,y)>>;
      return x
   end;

symbolic procedure matsm1 u;
   %returns matrix canonical form for matrix symbol product U;
   begin scalar x,y,z; integer n;
    a:  if null u then return z
         else if eqcar(car u,'!*div) then go to d
         else if atom car u then go to er
         else if caar u eq 'mat then go to c1
         else x := apply(caar u,cdar u);
    b:  z := if null z then x
              else if null cdr z and null cdar z then multsm(caar z,x)
              else multm(x,z);
    c:  u := cdr u;
        go to a;
    c1: if not lchk cdar u then rederr "Matrix mismatch";
        x := for each j in cdar u collect
                for each k in j collect xsimp k;
        go to b;
    d:  y := matsm cadar u;
        if (n := length car y) neq length y
          then rederr "Non square matrix"
         else if (z and n neq length z) then rederr "Matrix mismatch"
         else if cddar u then go to h
         else if null cdr y and null cdar y then go to e;
        x := subfg!*;
        subfg!* := nil;
        if null z then z := apply1(get('mat,'inversefn),y)
         else if null(x := get('mat,'lnrsolvefn))
          then z := multm(apply1(get('mat,'inversefn),y),z)
         else z := apply2(get('mat,'lnrsolvefn),y,z);
        subfg!* := x;
        % Make sure there are no power substitutions.
        z := for each j in z collect for each k in j collect
                 <<!*sub2 := t; subs2 k>>;
        go to c;
    e:  if null caaar y then rederr "Zero denominator";
        y := revpr caar y;
        z := if null z then list list y else multsm(y,z);
        go to c;
     h: if null z then z := generateident n;
        go  to c;
    er: rederr list("Matrix",car u,"not set")
   end;

symbolic procedure lchk u;
   begin integer n;
        if null u or atom car u then return nil;
        n := length car u;
        repeat u := cdr u
           until null u or atom car u or length car u neq n;
        return null u
   end;

symbolic procedure addm(u,v);
   %returns sum of two matrix canonical forms U and V;
   for each j in addm1(u,v,function cons)
      collect addm1(car j,cdr j,function addsq);

symbolic procedure addm1(u,v,w);
   if null u and null v then nil
    else if null u or null v then rederr "Matrix mismatch"
    else apply(w,list(car u,car v)) . addm1(cdr u,cdr v,w);

symbolic procedure tp u; tp1 matsm u;

put('tp,'rtypefn,'getrtypecar);

symbolic procedure tp1 u;
   %returns transpose of the matrix canonical form U;
   %U is destroyed in the process;
   begin scalar v,w,x,y,z;
        v := w := list nil;
        while car u do
         <<x := u;
           y := z := list nil;
           while x do
             <<z := cdr rplacd(z,list caar x);
               x := cdr rplaca(x,cdar x)>>;
           w := cdr rplacd(w,list cdr y)>>;
        return cdr v
   end;

symbolic procedure scalprod(u,v);
   %returns scalar product of two lists (vectors) U and V;
   if null u and null v then nil ./ 1
    else if null u or null v then rederr "Matrix mismatch"
    else addsq(multsq(car u,car v),scalprod(cdr u,cdr v));

symbolic procedure multm(u,v);
   %returns matrix product of two matrix canonical forms U and V;
    (lambda x;
        for each y in u collect for each k in x collect scalprod(y,k))
     tp1 v;

symbolic procedure multsm(u,v);
   %returns product of standard quotient U and matrix standard form V;
   if u = (1 ./ 1) then v
    else for each j in v collect for each k in j collect multsq(u,k);

symbolic procedure letmtr(u,v,y);
   %substitution for matrix elements;
   begin scalar z;
        if not eqcar(y,'mat) then rederr list("Matrix",car u,"not set")
         else if not numlis (z := revlis cdr u) or length z neq 2
          then return errpri2(u,'hold);
        rplaca(pnth(nth(cdr y,car z),cadr z),v);
   end;

endmodule;


module matpri;   % Matrix printing routines.

% Author: Anthony C. Hearn;

global '(!*nat);

symbolic procedure setmatpri(u,v);
   matpri1(cdr v,u);

put('mat,'setprifn,'setmatpri);

symbolic procedure matpri u;
   matpri1(cdr u,"MAT");

symbolic procedure matpri1(u,x);
   %prints a matrix canonical form U with name X;
   begin scalar m,n;
        m := 1;
        for each y in u do
         <<n := 1;
           for each z in y do
              <<varpri(z,list('setq,list(x,m,n),z),'only); n := n+1>>;
        m := m+1>>
   end;

endmodule;


module bareiss; % Inversion routines using the Bareiss 2-step method.

% Author: Anthony C. Hearn;

% This module is rife with essential references to RPLAC-based
% functions.

fluid '(!*exp asymplis!*);

global '(wtl!*);

symbolic procedure matinverse u;
   lnrsolve(u,generateident length u);

symbolic procedure lnrsolve(u,v);
   %U is a matrix standard form, V a compatible matrix form.
   %Value is U**(-1)*V.
   begin integer n; scalar !*exp,temp;
        !*exp := t; n := length u;
        if asymplis!* or wtl!*
          then <<temp := asymplis!* . wtl!*;
                 asymplis!* := wtl!* := nil>>;
        v := backsub(bareiss car normmat augment(u,v),n);
        if temp then <<asymplis!* := car temp; wtl!* := cdr temp>>;
        u := rhside(car v,n);
        v := cdr v;
        return if temp
                 then for each j in u collect
                          for each k in j collect resimp(k ./ v)
                else for each j in u collect
                          for each k in j collect cancel(k ./ v)
   end;

symbolic procedure augment(u,v);
   if null u then nil else append(car u,car v) . augment(cdr u,cdr v);

symbolic procedure generateident n;
  %returns matrix canonical form of identity matrix of order N.
   begin scalar u,v;
        for i := 1:n do
         <<u := nil;
           for j := 1:n do u := ((if i=j then 1 else nil) . 1) . u;
           v := u . v>>;
        return v
   end;

symbolic procedure rhside(u,m);
   if null u then nil else pnth(car u,m+1) . rhside(cdr u,m);

symbolic procedure bareiss u;
  %The 2-step integer preserving elimination method of Bareiss
  %based on the implementation of Lipson.
  %If the value of procedure is NIL then U is singular, otherwise the
  %value is the triangularized form of U (in matrix polynomial form).
  begin scalar aa,c0,ci1,ci2,ik1,ij,kk1,kj,k1j,k1k1,ui,u1,x;
        integer k,k1;
        %U1 points to K-1th row of U
        %UI points to Ith row of U
        %IJ points to U(I,J)
        %K1J points to U(K-1,J)
        %KJ points to U(K,J)
        %IK1 points to U(I,K-1)
        %KK1 points to U(K,K-1)
        %K1K1 points to U(K-1,K-1)
        %M in comments is number of rows in U
        %N in comments is number of columns in U.
        aa:= 1;
        k:= 2;
        k1:=1;
        u1:=u;
        go to pivot;
   agn: u1 := cdr u1;
        if null cdr u1 or null cddr u1 then return u;
        aa:=nth(car u1,k);              %aa := u(k,k).
        k:=k+2;
        k1:=k-1;
        u1:=cdr u1;
   pivot:  %pivot algorithm.
        k1j:= k1k1 := pnth(car u1,k1);
        if car k1k1 then go to l2;
        ui:= cdr u1;                    %i := k.
   l:   if null ui then return nil
         else if null car(ij := pnth(car ui,k1))
          then go to l1;
   l0:  if null ij then go to l2;
        x:= car ij;
        rplaca(ij,negf car k1j);
        rplaca(k1j,x);
        ij:= cdr ij;
        k1j:= cdr k1j;
        go to l0;
   l1:  ui:= cdr ui;
        go to l;
   l2:  ui:= cdr u1;                    %i:= k;
   l21: if null ui then return; %if i>m then return;
        ij:= pnth(car ui,k1);
        c0:= addf(multf(car k1k1,cadr ij),
                    multf(cadr k1k1,negf car ij));
        if c0 then go to l3;
        ui:= cdr ui;                    %i:= i+1;
        go to l21;
   l3:  c0:= quotf!*(c0,aa);
        kk1 := kj := pnth(cadr u1,k1);  %kk1 := u(k,k-1);
        if cdr u1 and null cddr u1 then go to ev0
         else if ui eq cdr u1 then go to comp;
   l31: if null ij then go to comp;     %if i>n then go to comp;
        x:= car ij;
        rplaca(ij,negf car kj);
        rplaca(kj,x);
        ij:= cdr ij;
        kj:= cdr kj;
        go to l31;
        %pivoting complete.
    comp:
        if null cdr u1 then go to ev;
        ui:= cddr u1;                   %i:= k+1;
    comp1:
        if null ui then go to ev;       %if i>m then go to ev;
        ik1:= pnth(car ui,k1);
        ci1:= quotf!*(addf(multf(cadr k1k1,car ik1),
                           multf(car k1k1,negf cadr ik1)),
                     aa);
        ci2:= quotf!*(addf(multf(car kk1,cadr ik1),
                           multf(cadr kk1,negf car ik1)),
                     aa);
        if null cddr k1k1 then go to comp3;%if j>n then go to comp3;
        ij:= cddr ik1;                     %j:= k+1;
        kj:= cddr kk1;
        k1j:= cddr k1k1;
    comp2:
        if null ij then go to comp3;
        rplaca(ij,quotf!*(addf(multf(car ij,c0),
                               addf(multf(car kj,ci1),
                                  multf(car k1j,ci2))),
                     aa));
        ij:= cdr ij;
        kj:= cdr kj;
        k1j:= cdr k1j;
        go to comp2;
    comp3:
        ui:= cdr ui;
        go to comp1;
    ev0:if null c0 then return;
    ev: kj := cdr kk1;
        x := cddr k1k1;                 %x := u(k-1,k+1);
        rplaca(kj,c0);
    ev1:kj:= cdr kj;
        if null kj then go to agn;
        rplaca(kj,quotf!*(addf(multf(car k1k1,car kj),
                               multf(car kk1,negf car x)),
                     aa));
        x := cdr x;
        go to ev1
   end;

symbolic procedure backsub(u,m);
   begin scalar detm,det1,ij,ijj,ri,summ,uj,ur; integer i,jj;
   %N in comments is number of columns in U.
        if null u then rederr "Singular matrix";
        ur := reverse u;
        detm := car pnth(car ur,m);             %detm := u(i,j).
        if null detm then rederr "Singular matrix";
        i := m;
    rows:
        i := i-1;
        ur := cdr ur;
        if null ur then return u . detm;
                %if i=0 then return u . detm.
        ri := car ur;
        jj := m+1;
        ijj:=pnth(ri,jj);
    r2: if null ijj then go to rows;    %if jj>n then go to rows;
        ij := pnth(ri,i);               %j := i;
        det1 := car ij;                 %det1 := u(i,i);
        uj := pnth(u,i);
        summ := nil;                    %summ := 0;
    r3: uj := cdr uj;                   %j := j+1;
        if null uj then go to r4;       %if j>m then go to r4;
        ij := cdr ij;
        summ := addf(summ,multf(car ij,nth(car uj,jj)));
                %summ:=summ+u(i,j)*u(j,jj);
        go to r3;
    r4: rplaca(ijj,quotf!*(addf(multf(detm,car ijj),negf summ),det1));
                %u(i,j):=(detm*u(i,j)-summ)/det1;
        jj := jj+1;
        ijj := cdr ijj;
        go to r2
   end;

symbolic procedure normmat u; 
   %U is a matrix standard form.
   %Value is dotted pair of matrix polynomial form and factor.
   begin scalar x,y,z; 
      x := 1; 
      for each v in u do
         <<y := 1; 
           for each w in v do y := lcm(y,denr w);
           z := (for each w in v
                    collect multf(numr w,quotf(y,denr w)))
              . z; 
           x := multf(y,x)>>; 
      return reverse z . x
   end;

endmodule;


module det;   % Determinant and trace routines.

% Author: Anthony C. Hearn;

symbolic procedure simpdet u; detq matsm carx(u,'det);

% The hashing and determinant routines below are due to M. L. Griss.

comment Some general purpose hashing functions;

flag('(array),'eval);      %declared again for bootstrapping purposes;

array !$hash 64;  %general array for hashing;

symbolic procedure gethash key;
   %access previously saved element;
   assoc(key,!$hash(remainder(key,64)));

symbolic procedure puthash(key,valu);
   begin integer k; scalar buk;
      k := remainder(key,64);
      buk := (key . valu) . !$hash k;
      !$hash k := buk;
      return car buk
   end;

symbolic procedure clrhash;
   for i := 0:64 do !$hash i := nil;

comment Determinant Routines;

symbolic procedure detq u;
   %top level determinant function;
   begin integer len;
      len := length u;   %number of rows;
      for each x in u do
        if length x neq len then rederr "NON SQUARE MATRIX";
      if len=1 then return caar u;
      clrhash();
      u := detq1(u,len,0);
      clrhash();
      return u
   end;

symbolic procedure detq1(u,len,ignnum);
   %U is a square matrix of order LEN. Value is the determinant of U;
   %Algorithm is expansion by minors of first row;
   %IGNNUM is packed set of column indices to avoid;
   begin integer n2; scalar row,sign,z;
      row := car u;   %current row;
      n2 := 1;
      if len=1
        then return <<while twomem(n2,ignnum)
                         do <<n2 := 2*n2; row := cdr row>>;
                      car row>>;   %last row, single element;
      if z := gethash ignnum then return cdr z;
      len := len-1;
      u := cdr u;
      z := nil ./ 1;
      for each x in row do
        <<if not twomem(n2,ignnum)
            then <<if numr x
                     then <<if sign then x := negsq x;
                            z:= addsq(multsq(x,detq1(u,len,n2+ignnum)),
                                        z)>>;
                   sign := not sign>>;
          n2 := 2*n2>>;
      puthash(ignnum,z);
      return z
   end;

symbolic procedure twomem(n1,n2);
   %for efficiency reasons, this procedure should be coded in assembly
   %language;
   not evenp(n2/n1);

put('det,'simpfn,'simpdet);

symbolic procedure simptrace u;
   begin integer n; scalar z;
        u := matsm carx(u,'trace);
        if length u neq length car u then rederr "NON SQUARE MATRIX";
        n := 1;
        z := nil ./ 1;
        for each x in u do <<z := addsq(nth(x,n),z); n := n+1>>;
        return z
   end;

put('trace,'simpfn,'simptrace);

endmodule;


module glmat; % Routines for inverting matrices and finding eigen-values
              % and vectors. Methods are the same as in glsolve module.
 
% Author: Eberhard Schruefer.
 
fluid '(!*cramer !*gcd kord!*);
 
global '(!!arbint);

if null !!arbint then !!arbint := 0;

switch cramer;
 
put('cramer,'simpfg,
    '((t (put 'mat 'lnrsolvefn 'clnrsolve)
     (put 'mat 'inversefn 'matinv))
      (nil (put 'mat 'lnrsolvefn 'lnrsolve)
       (put 'mat 'inversefn 'matinverse))));
 
% algebraic operator arbcomplex;

% Done this way since it's also defined in the solve1 module.

deflist('((arbcomplex simpiden)),'simpfn);

symbolic procedure clnrsolve(u,v);
   %interface to matrix package.
   multm(matinv u,v);
 
symbolic procedure minv u;
   matinv matsm u;
 
put('minv,'rtypefn,'(lambda (x) 'matrix));

flag('(minv),'matflg);
 
%put('mateigen,'rtypefn,'(lambda (x) 'matrix));
remprop('mateigen,'rtypefn);
%flag('(mateigen),'matflg);
remflag('(mateigen),'matflg);
 
put('detex,'simpfn,'detex);
 
symbolic procedure matinv u;
   %u is a matrix form. Result is the inverse of matrix u.
   begin scalar sgn,x,y,z;
     integer l,m,lm;
     z := 1;
     lm := length car u;
     for each v in u do
       <<y := 1;
     for each w in v do y := lcm(y,denr w);
     m := lm;
     x := list(nil . (l := l + 1)) .* negf y .+ nil;
     for each j in reverse v do
       <<if numr j then
        x := list m .* multf(numr j,quotf(y,denr j)) .+ x;
         m := m - 1>>;
     z := c!:extmult(x,z)>>;
      if singularchk lpow z then rederr "singular matrix";
     sgn := evenp length lpow z;
      return for each k in lpow z collect
          <<sgn := not sgn;
            for each j in lpow z collect mkglimat(k,z,sgn,j)>>
   end;
 
symbolic procedure singularchk u;
   pairp car reverse u;
 
flag('(mateigen),'opfn);

flag('(mateigen),'noval);

symbolic procedure mateigen(u,eival);
   %u is a matrix form, eival an indeterminate naming the eigenvalues.
   %Result is a list of lists: 
   %  {{eival-eq1,multiplicity1,eigenvector1},....},
   %where eival-eq is a polynomial and eigenvector is a matrix.
%    How much should we attempt to solve the eigenvalue eq.? sqfr?
%    Sqfr is necessary if we want to have the full eigenspace. If there
%    are multiple roots another pass through eigenvector calculation
%    is needed(done).
%    We should actually perform the calculations in the extension
%    field generated by the eigenvalue equation(done inside).
%*** needs still checking; seems to do fairly well.
  begin scalar arbvars,exu,sgn,q,r,s,x,y,z,eivec;
     integer l,m,lm;
     z := 1;
     if not(getrtype u eq 'matrix) then typerr(u,"matrix");
     u := matsm u;
     lm := length car u;
     exu := for each v in u collect
          <<y := 1;
        for each w in v do y := lcm(y,denr w);
        m := lm;
        l := l + 1;
        x := nil;
        for each j in reverse v do
          <<if l=m then j := addsq(j,negsq !*k2q !*a2k eival);
            if numr j then
            x := list m .* multf(numr j,quotf(y,denr j)) .+ x;
            m := m - 1>>;
        y := z;
        z := c!:extmult(if null red x then <<
               q := (if p then (car p  . (cdr p + 1)) . delete(p,q)
                      else (lc x  . 1) . q) where p = assoc(lc x,q);
                        !*p2f lpow x>> else x,z);
        x>>;
     r := if minusf lc z then negf lc z else lc z;
     r := numr subs2(r ./ 1);
     kord!* := eival . kord!*;
     if domainp r then s := 1 else
     s := comfac!-to!-poly comfac(r := reorder r);
     r := quotf1(r,s);
     r := if domainp r then nil else sqfrf r;
     if null domainp s and (mvar s eq eival) then
     if red s then r := (s . 1) . r
     else r := (!*k2f eival . ldeg s) . r;
     for each j in q do r := (absf reorder car j . cdr j) . r;
     kord!* := cdr kord!*;
     r := for each j in r collect reorder car j . cdr j;
     l := length r;
     return 'list .
       for each j in r collect
     <<if null((cdr j = 1) and (l = 1)) then
         <<y := 1;
           for each k in exu do
         if x := reduce!-mod!-eig(car j,c!:extmult(k,y))
           then y := x>>;
       arbvars := nil;
       for each k in lpow z do
          if (y=1) or null(k member lpow y) then
         arbvars := (k . makearbcomplex()) . arbvars;
       sgn := (y=1) or evenp length lpow y;
       eivec := 'mat . for each k in lpow z collect list
                           if x := assoc(k,arbvars)
                              then mvar cdr x
                            else prepsq!* mkgleig(k,y,
                                    sgn := not sgn,arbvars);
       list('list,prepsq!*(car j ./ 1),cdr j,eivec)>>
   end;

symbolic procedure reduce!-mod!-eig(u,v);
   %reduces exterior product v wrt eigenvalue equation u.
   begin scalar x,y;
     for each j on v do
       if numr(y := reduce!-mod!-eigf(u,lc j)) then
      x := lpow j .* y .+ x;
     y := 1;
     for each j on x do y := lcm(y,denr lc j);
     return for each j on reverse x collect
          lpow j .* multf(numr lc j,quotf(y,denr lc j))
   end;
 
symbolic procedure reduce!-mod!-eigf(u,v);
   subs2 reduce!-eival!-powers(lpow u . negsq cancel(red u ./ lc u),v);
 
symbolic procedure reduce!-eival!-powers(v,u);
   if domainp u then u ./ 1
    else if mvar u eq caar v then reduce!-eival!-powers1(v,u ./ 1)
    else if ordop(caar v,mvar u) then u ./ 1
    else addsq(multpq(lpow u,reduce!-eival!-powers(v,lc u)),
           reduce!-eival!-powers(v,red u));
 
symbolic procedure reduce!-eival!-powers1(v,u);
   %reduces powers with the help of the eigenvalue polynomial;
   if domainp numr u or (ldeg numr u<pdeg car v) then u
    else if ldeg numr u=pdeg car v then
        addsq(multsq(cdr v,lc numr u ./ denr u),
          red numr u ./ denr u)
   else reduce!-eival!-powers1(v,
    addsq(multsq(multpf(mvar numr u .** (ldeg numr u-pdeg car v),
                lc numr u) ./ denr u,
         cdr v),red numr u ./ denr u));
 
symbolic procedure detex u;
   %u is a matrix form, result is determinant of u.
   begin scalar f,x,y,z;
     integer m,lm;
     z := 1;
     u := matsm car u;
     lm := length car u;
     f := 1;
     for each v in u do
       <<y := 1;
     for each w in v do y := lcm(y,denr w);
     f := multf(y,f);
     m := lm;
     x := nil;
     for each j in v do
       <<if numr j then
        x := list m .* multf(numr j,quotf(y,denr j)) .+ x;
         m := m - 1>>;
     z := c!:extmult(x,z)>>;
      return cancel(lc z ./ f)
   end;
 
symbolic procedure mkglimat(u,v,sgn,k);
   begin scalar s,x,y;
     x := nil ./ 1;
     y := lpow v;
     for each j on red v do
       if s := glmatterm(u,y,j,k)
      then x := addsq(cancel(s ./ lc v),x);
     return if sgn then negsq x else x
   end;
 
symbolic procedure glmatterm(u,v,w,k);
   begin scalar x,y,sgn;
     x := lpow w;
     a: if null x then return
       if pairp car y and (cdar y = k) then lc w else nil;
    if car x = u then return nil
         else if car x member v then <<x := cdr x;
                     if y then sgn := not sgn>>
         else if y then return nil
               else <<y := list car x; x := cdr x>>;
        go to a
   end;
 
symbolic procedure mkgleig(u,v,sgn,arbvars);
   begin scalar s,x,y,!*gcd;
     x := nil ./ 1;
     y := lpow v;
     !*gcd := t;
     for each j on red v do
       if s := glsoleig(u,y,j,arbvars)
      then x := addsq(cancel(s ./ lc v),x);
     return if sgn then negsq x else x
   end;
 
symbolic procedure glsoleig(u,v,w,arbvars);
   begin scalar x,y,sgn;
     x := lpow w;
     a: if null x then return
           if null car y then lc w
        else multf(cdr assoc(car y,arbvars),
               if sgn then negf lc w else lc w);
        if car x = u then return nil
         else if car x member v then <<x := cdr x;
                     if y then sgn := not sgn>>
         else if y then return nil
               else <<y := list car x; x := cdr x>>;
        go to a
   end;
 
 
%**** Support for exterior multiplication ****
% Data structure is lpow ::= list of col.-ind. in exterior product
%                            | nil . number of eq. for inhomog. terms.
%                   lc   ::= standard form
 
 
symbolic procedure c!:extmult(u,v);
   %Special exterior multiplication routine. Degree of form v is
   %arbitrary, u is a one-form.
   if null u or null v then  nil
    else if v = 1 then u                   %unity
    else (if x then cdr x .* (if car x then negf multf(lc u,lc v)
                   else multf(lc u,lc v))
              .+ c!:extadd(c!:extmult(!*t2f lt u,red v),
                       c!:extmult(red u,v))
       else c!:extadd(c!:extmult(!*t2f lt u,red v),
              c!:extmult(red u,v)))
      where x = c!:ordexn(car lpow u,lpow v);
 
symbolic procedure c!:extadd(u,v);
   if null u then v
    else if null v then u
    else if lpow u = lpow v then
            (lambda x,y; if null x then y else lpow u .* x .+ y)
        (addf(lc u,lc v),c!:extadd(red u,red v))
    else if c!:ordexp(lpow u,lpow v) then lt u .+ c!:extadd(red u,v)
    else lt v .+ c!:extadd(u,red v);
 
symbolic procedure c!:ordexp(u,v);
   if null u then t
    else if car u = car v then c!:ordexp(cdr u,cdr v)
    else c!:ordxp(car u,car v);
 
symbolic procedure c!:ordexn(u,v);
   %u is a single index, v a list. Returns nil if u is a member
   %of v or a dotted pair of a permutation indicator and the ordered
   %list of u merged into v.
   begin scalar s,x;
     a: if null v then return(s . reverse(u . x))
     else if (u = car v) or (pairp u and pairp car v)
         then return nil
     else if c!:ordxp(u,car v) then
         return(s . append(reverse(u . x),v))
         else  <<x := car v . x;
                 v := cdr v;
                 s := not s>>;
         go to a
   end;
 
symbolic procedure c!:ordxp(u,v);
   if pairp u then if pairp v then cdr u < cdr v
            else nil
    else if pairp v then t
    else u < v;
 
endmodule;


end;

Added r33/mkfasl.red version [6cc13169e1].



























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
MODULE MKFASL --- Produce a fasl loading version of a given file;

% Author: Martin L. Griss.

% Modifications by: Anthony C. Hearn;


fluid '(rfasl!* rsrc!* !*break !*lower !*quiet!_faslout !*usermode
        !*writingfaslfile);

global '(!*echo);

symbolic procedure mkfasl u;
   % produce a FASL file for the module u;
   if errorp errorset(list('mkfasl1,mkquote u),t,!*backtrace)
     then <<if !*writingfaslfile then eval '(faslend);
            errorprintf("***** Error during mkfasl of %w%n",u)>>;

flag('(mkfasl),'opfn);

flag('(mkfasl),'noval);

symbolic procedure mkfasl1 u;
   begin scalar !*int,!*lower,!*usermode,!*quiet!_faslout,!*break,echo,
                ichan,oldichan;
      echo := !*echo;
      !*echo := nil;
      !*quiet!_faslout := t;
      terpri();
      prin2t bldmsg("*** Compiling %w ...",u);
      terpri();
      u := string!-downcase u;
      ichan := open(concat(u,".red"),'input);
      oldichan := rds ichan;
      faslout bldmsg("%w%w",rfasl!*,u);
      begin1();
      eval '(faslend);
      !*echo := echo;
      close ichan;
      rds oldichan
   end;

endmodule;

end;

Added r33/mkreduce.sl version [6ab0299bb2].











































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
(setq !*verboseload t)

(dskin "$reduce/src/symget.dat")        % for fast plist access
(load prolog)                           % Aliasing of ids used by PSL
(flag '(foreach repeat while) 'lose)
(load rlisp)                            % RLISP
(load rend)                             % PSL dependent code
(load arith)
(load mathlib)                          % mathematical function library
(load alg1)                             % basic algebra
(load alg2)                             % and augmentations
(load nbig)                             % PSL bignums
(remd 'crefon)                          % Since we don't use PSL version
(load entry)                            % entry points for other modules
(load init!-file)                       % allows for init file .reducerc

(setq !*verboseload nil)

(initreduce)

(setq date* "15-Jan-88")                % Official release date

Added r33/prolog.red version [b96035cd30].

























































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
% module prolog;   % system dependent code for REDUCE

% Author: Anthony C. Hearn

% This file defines functions, variables and declarations needed to
% make REDUCE and the underlying PSL system compatible, and which need
% to be input before the system independent REDUCE source is loaded.

% Code for resolving aliasing name conflicts.

global '(!*quotenewnam);

symbolic procedure define!-alias!-list u;
   begin scalar x;
   a: if null u then return nil;
      x := intern compress append(explode '!~,explode car u);
      put(car u,'newnam,x);
      put(car u,'quotenewnam,x);
      u := cdr u;
      go to a
   end;


% Support for module loading

symbolic procedure load!-module u;
   begin scalar x;
      if not idp u then rederr list(u,"is not a module name");
      if null (x := get(u,'module!-list)) then return evload list u;
   a: if null x then return nil;
      load!-module car x;
      x := cdr x;
      go to a
   end;

% PSL doesn't need PRINTPROMPT

remflag('(printprompt),'lose);

symbolic procedure printprompt u; nil;

flag('(printprompt),'lose);

flag('(aconc atsoc copy delasc eqcar geq lastpair leq mkquote neq prin2t
       reversip rplacw union xn putc yesp),'lose);

flag('(block foreach lprim repeat while),'user);  % permits redefinition

!*quotenewnam := nil;

define!-alias!-list
      '(arrayp do for on off logand logxor let clear flatten imports
        indx mkid copy mkvec vector editf spaces2 prettyprint);

!*quotenewnam := t;

% Resolution of non-local variable definitions.

% The following PSL variables differ from the Standard LISP Report

remprop('!*comp,'vartype);

remprop('!*echo,'vartype);

remprop('!*raise,'vartype);

% The following are not in the Standard LISP Report, but differ from
% usual REDUCE usage.

remprop('!*output,'vartype);

remprop('cursym!*,'vartype);

% endmodule;

end;

Added r33/rcref.red version [a3cac14af6].

















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
module redio; % General Purpose I/O package, sorting and positioning.

% Author: Martin L. Griss.

% Modified by: Anthony C. Hearn.

global '(!*formfeed lnnum!* maxln!* orig!* pgnum!* title!*);

% This module is functionally equivalent to the PSL file PSL-CREFIO.RED.

% FORMFEED (ON)  controls ^L or spacer of ====;

symbolic procedure initio();
% Set-up common defaults;
   begin
        !*formfeed:=t;
        orig!*:=0;
        lnnum!*:=0;
        linelength(75);
        maxln!*:=55;
        title!*:=nil;
        pgnum!*:=1;
   end;

symbolic procedure lposn();
   lnnum!*;

initio();

symbolic procedure setpgln(p,l);
  begin if p then maxln!*:=p;
        if l then linelength(l);
  end;

% We use EXPLODE to produce a list of chars from atomname,
% and TERPRI() to terminate a buffer..all else
% done in package..spaces,tabs,etc. ;

comment Character lists are (length . chars), for FITS;


symbolic  procedure getes u;
% Returns for U , EE=(Length . List of char);
   begin scalar ee;
        if not idp u then return<<ee:=explode u;length(ee).ee>>;
        if not(ee:=get(u,'rccnam)) then <<ee:=explode(u);
                                   ee:=length(ee) . ee;
                                   put(u,'rccnam,ee)>>;
        return ee;
   end;

% symbolic smacro procedure prtwrd u;
%   if numberp u then prtnum u else prtatm u;

symbolic procedure prtatm u;
        prin2 u;        % For a nice print;

symbolic procedure prtlst u;
 if atom u then prin2 u else for each x in u do prin2 x;

symbolic procedure prtnum n;
   % We use this kludge to defeat the new line that several LISPs
   % including PSL like to insert when printing a number near the line
   % boundary.
   for each x in explode2 n do prin2 x;

symbolic procedure princn ee;
% output a list of chars, update POSN();
         while (ee:=cdr ee) do prin2 car ee;

symbolic procedure spaces n; for i:=1:n do prin2 '!  ;

symbolic procedure spaces!-to n;
   begin scalar x;
        x := n - posn();
        if x<1 then newline n
         else spaces x;
   end;

symbolic procedure setpage(title,page);
% Initialise current page and title;
   begin
        title!*:= title ;
        pgnum!*:=page;
   end;

symbolic procedure newline n;
% Begins a fresh line at posn N;
   begin
        lnnum!*:=lnnum!*+1;
        if lnnum!*>=maxln!* then newpage()
         else terpri();
        spaces(orig!*+n);
   end;

symbolic procedure newpage();
% Start a fresh page, with PGNUM and TITLE, if needed;
   begin scalar a;
        a:=lposn();
        lnnum!*:=0;
        if posn() neq 0 then newline 0;
        if a neq 0 then formfeed();
        if title!* then
          <<spaces!-to 5; prtlst title!*>>;
        spaces!-to (linelength(nil)-4);
        if pgnum!* then <<prtnum pgnum!*; pgnum!*:=pgnum!*+1>>
         else pgnum!*:=2;
        newline 10;
        newline 0;
   end;

symbolic procedure underline2 n;
        if n>=linelength(nil) then
          <<n:=linelength(nil)-posn();
            for i:=0:n do prin2 '!- ;
            newline(0)>>
         else begin scalar j;
                j:=n-posn();
                for i:=0:j do prin2 '!-;
              end;

symbolic procedure lprint(u,n);
% prints a list of atoms within block LINELENGTH(NIL)-n;
   begin scalar ee; integer l,m;
        spaces!-to n;
        l := linelength nil-posn();
        if l<=0 then error(13,"WINDOW TOO SMALL FOR LPRINT");
        while u do
           <<ee:=getes car u; u:=cdr u;
            if linelength nil<posn() then newline n;
             if car ee<(m := linelength nil-posn()) then princn ee
              else if car ee<l then <<newline n; princn ee>>
              else begin
                 ee := cdr ee;
              a: for i := 1:m do <<prin2 car ee; ee := cdr ee>>;
                 newline n;
                 if null ee then nil
                  else if length ee<(m := l) then princn(nil . ee)
                  else go to a
                end;
             if posn()<linelength nil then prin2 '! >>
   end;

symbolic procedure rempropss(atmlst,lst);
   for each x in atmlst do
      for each y in lst do remprop(x,y);


symbolic procedure remflagss(atmlst,lst);
   for each x in lst do remflag(atmlst,x);

symbolic procedure formfeed;
        if !*formfeed then eject()
         else <<terpri();
                prin2 " ========================================= ";
                terpri()>>;

endmodule;


module rcref; % Cross reference program.

% Author: Martin L. Griss.

fluid '(!*backtrace !*cref !*defn !*mode calls!* curfun!* dfprint!*
        globs!* locls!* toplv!*);

global '(undefg!* gseen!* btime!* expand!* haveargs!* notuse!* nolist!*
        dclglb!* entpts!* undefns!* seen!* tseen!* op!*!* cloc!*
        pfiles!* curlin!* pretitl!* !*creftime !*saveprops maxarg!*
        !*crefsummary !*comp !*raise !*rlisp !*globals !*algebraics);

switch cref;

!*algebraics:='t; % Default is normal parse of algebraic;
!*globals:='t;  % Do analyze globals;
% !*RLISP:=NIL;   % REDUCE as default;
maxarg!*:=15;   % Maximum args in Standard Lisp;

% Requires REDIO and SORT support.

deflist('((anlfn procstat) (crflapo procstat)),'stat);

flag('(anlfn crflapo),'compile);

comment  EXPAND flag on these forces expansion of MACROS;

expand!* := '(for foreach repeat while);

nolist!* := nconc(deflist(slfns!*,'number!-of!-args),nolist!*)$

nolist!* := append('(and cond endmodule lambda list max min module or
                     plus prog prog2 progn times),
                   nolist!*);

flag ('(plus times and or lambda progn max min cond prog case list),
       'naryargs);

dclglb!*:='(!*comp emsg!* !*raise);

if not getd 'begin then
  flag('(rds deflist flag fluid global remprop remflag unfluid
           setq crefoff),'eval);

symbolic procedure crefon;
  begin scalar a,ocrfil,crfil;
        btime!*:=time();
        dfprint!* := 'refprint;
        !*defn := t;
        if not !*algebraics then put('algebraic,'newnam,'symbolic);
        flag(nolist!*,'nolist);
        flag(expand!*,'expand);
        flag(dclglb!*,'dclglb);
%  Global lists;
        entpts!*:=nil;  % Entry points to package;
        undefns!*:=nil; % Functions undefined in package;
        seen!*:=nil;    % List of all encountered functions;
        tseen!*:=nil;   % List of all encountered types not flagged
                        % FUNCTION;
        gseen!*:=nil;   % All encountered globals;
        pfiles!*:=nil;  % Processed files;
        undefg!*:=nil;  % Undeclared globals encountered;
        curlin!*:=nil;  % Position in file(s) of current command ;
        pretitl!*:=nil; % T if error or questionables found ;
% Usages in specific function under analysis;
        globs!*:=nil;   % Globals refered to in this ;
        calls!*:=nil;   % Functions called by this;
        locls!*:=nil;   % Defined local variables in this ;
        toplv!*:=t;     % NIL if inside function body ;
        curfun!*:=nil;  % Current function beeing analysed;
        op!*!*:=nil;    % Current op. in LAP code;
        setpage("  Errors or questionables",nil);
        if getd 'begin then return nil; % In REDUCE;
% The following loop is used when running in bare LISP;
  ndf:  if not (a eq !$eof!$) then go lop;
        crfil:=nil;
        if null ocrfil then go lop;
        crfil:=caar ocrfil;
        rds cdar ocrfil;
        ocrfil:=cdr ocrfil;
  lop:  a:=errorset('(!%nexttyi),t,!*backtrace);
        if atom a then go ndf;
        cloc!*:=if crfil then crfil . pgline() else nil;
        a:=errorset('(read),t,!*backtrace);
        if atom a then go ndf;
        a:=car a;
        if not pairp a then go lop;
        if car a eq 'dskin then
           <<ocrfil:=(crfil.rds open(cdr a,'input)).ocrfil;
             crfil:=cdr a; go lop>>;
        errorset(list('refprint,mkquote a),t,!*backtrace);
        if flagp(car a,'eval) and
           (car a neq 'setq or caddr a memq '(t nil) or
            constantp caddr a or eqcar(caddr a,'quote))
          then errorset(a,t,!*backtrace);
        if !*defn then go lop
  end;

symbolic procedure undefdchk fn;
 if not flagp(fn,'defd) then undefns!* := fn . undefns!*;

symbolic procedure princng u;
 princn getes u;

symbolic procedure crefoff;
% main call, sets up, alphabetizes and prints;
   begin  scalar tim,x;
        dfprint!* := nil;
        !*defn:=nil;
        if not !*algebraics
          then remprop('algebraic,'newnam);     %back to normal;
        tim:=time()-btime!*;
        for each fn in seen!* do
         <<if null get(fn,'calledby) then entpts!*:=fn . entpts!*;
           undefdchk fn>>;
        tseen!*:=for each z in idsort tseen!* collect
         <<remprop(z,'tseen);
           for each fn in (x:=get(z,'funs)) do
            <<undefdchk fn; remprop(fn,'rccnam)>>;
           z.x>>;
        for each z in gseen!* do
         if get(z,'usedunby) then undefg!*:=z . undefg!*;
        setpage("  Summary",nil);
        newpage();
        pfiles!*:=punused("Crossreference listing for files:",
                          for each z in pfiles!* collect cdr z);
        entpts!*:=punused("Entry Points:",entpts!*);
        undefns!*:=punused("Undefined Functions:",undefns!*);
        undefg!*:=punused("Undeclared Global Variables:",undefg!*);
        gseen!*:=punused("Global variables:",gseen!*);
        seen!*:=punused("Functions:",seen!*);
        for each z in tseen!* do
          <<rplacd(z,punused(list(car z," procedures:"),cdr z));
            x:='!( . nconc(explode car z,list '!));
            for each fn in cdr z do
             <<fn:=getes fn; rplacd(fn,append(x,cdr fn));
               rplaca(fn,length cdr fn)>> >>;
        if !*crefsummary then goto xy;
        if !*globals and gseen!* then
              <<setpage("  Global Variable Usage",1);
                newpage();
                for each z in gseen!* do cref6 z>>;
        if seen!* then cref52("  Function Usage",seen!*);
        for each z in tseen!* do
           cref52(list("  ",car z," procedures"),cdr z);
        setpage("  Toplevel calls:",nil);
        x:=t;
        for each z in pfiles!* do
         if get(z,'calls) or get(z,'globs) then
           <<if x then <<newpage(); x:=nil>>;
             newline 0; newline 0; princng z;
             spaces!-to 15; underline2 (linelength(nil)-10);
             cref51(z,'calls,"Calls:");
             if !*globals then cref51(z,'globs,"Globals:")>>;
  xy:   if !*saveprops then goto xx;
        rempropss(seen!*,'(gall calls globs calledby alsois sameas));
        remflagss(seen!*,'(seen cinthis defd));
        rempropss(gseen!*,'(usedby usedunby boundby setby));
        remflagss(gseen!*,'(dclglb gseen glb2rf glb2bd glb2st));
        for each z in tseen!* do remprop(car z,'funs);
%       for each z in haveargs!* do remprop(z,'number!-of!-args);
        haveargs!* := gseen!* := seen!* := tseen!* := nil;
  xx:   newline 2;
        if not !*creftime then return;
        btime!*:=time()-btime!*;
        setpage(" Timing Information",nil);
        newpage(); newline 0;
        prtatm " Total Time="; prtnum btime!*;
        prtatm " (ms)";
        newline 0;
        prtatm " Analysis Time="; prtnum tim;
        newline 0;
        prtatm " Sorting Time="; prtnum (btime!*-tim);
        newline 0; newline 0
  end;

symbolic procedure punused(x,y);
 if y then
  <<newline 2; prtlst x; newline 0;
    lprint(y := idsort y,8); newline 0; y>>;

symbolic procedure cref52(x,y);
 <<setpage(x,1); newpage(); for each z in y do cref5 z>>;

symbolic procedure cref5 fn;
% Print single entry;
   begin scalar x,y;
        newline 0; newline 0;
        prin1 fn; spaces!-to 15; 
        y:=get(fn,'gall);
        if y then <<prin1 cdr y; x:=car y>>
         else prin2 "Undefined";
        spaces!-to 25;
        if flagp(fn,'naryargs) then prin2 "  Nary Args  "
         else if (y:=get(fn,'number!-of!-args)) then
          <<prin2 "  "; prin2 y; prin2 " Args  ">>;
        underline2 (linelength(nil)-10);
        if x then
          <<newline 15; prtatm "Line:"; spaces!-to 27;
            prtnum cddr x; prtatm '!/; prtnum cadr x;
            prtatm " in "; prtatm car x>>;
        cref51(fn,'calledby,"Called by:");
        cref51(fn,'calls,"Calls:");
        cref51(fn,'alsois,"Is also:");
        cref51(fn,'sameas,"Same as:");
        if !*globals then cref51(fn,'globs,"Globals:")
   end;

symbolic procedure cref51(x,y,z);
 if (x:=get(x,y)) then <<newline 15; prtatm z; lprint(idsort x,27)>>;

symbolic procedure cref6 glb;
% print single global usage entry;
      <<newline 0; prin1 glb; spaces!-to 15;
        notuse!*:=t;
        cref61(glb,'usedby,"Global in:");
        cref61(glb,'usedunby,"Undeclared:");
        cref61(glb,'boundby,"Bound in:");
        cref61(glb,'setby,"Set by:");
        if notuse!* then prtatm "*** Not Used ***">>;

symbolic procedure cref61(x,y,z);
   if (x:=get(x,y)) then
     <<if not notuse!* then newline 15 else notuse!*:=nil;
       prtatm z; lprint(idsort x,27)>>;

%  Analyse bodies of LISP functions for
%  functions called, and globals used, undefined.

smacro procedure flag1(u,v); flag(list u,v);

smacro procedure remflag1(u,v); remflag(list u,v);

smacro procedure isglob u;
 flagp(u,'dclglb);

smacro procedure chkseen s;
% Has this name been encountered already?;
        if not flagp(s,'seen) then
          <<flag1(s,'seen); seen!*:=s . seen!*>>;

smacro procedure globref u;
  if not flagp(u,'glb2rf)
   then <<flag1(u,'glb2rf); globs!*:=u . globs!*>>;

smacro procedure anatom u;
% Global seen before local..ie detect extended from this;
   if !*globals and u and not(u eq 't)
      and idp u and not assoc(u,locls!*)
     then globref u;

smacro procedure chkgseen g;
 if not flagp(g,'gseen) then <<gseen!*:=g . gseen!*;
                            flag1(g,'gseen)>>;

symbolic procedure do!-global l;
% Catch global defns;
% Distinguish FLUID from GLOBAL later;
   if pairp(l:=qcrf car l) and !*globals and toplv!* then
     <<for each v in l do chkgseen v; flag(l,'dclglb)>>;

put('global,'anlfn,'do!-global);

put('fluid,'anlfn,'do!-global);

symbolic anlfn procedure unfluid l;
   if pairp(l:=qcrf car l) and !*globals and toplv!* then
     <<for each v in l do chkgseen v; remflag(l,'dclglb)>>;

symbolic procedure add2locs ll;
  begin scalar oldloc;
   if !*globals then for each gg in ll do
      <<oldloc:=assoc(gg,locls!*);
        if not null oldloc then <<
           qerline 0;
           prin2 "*** Variable ";
           prin1 gg;
           prin2 " nested declaration in ";
           princng curfun!*;
           newline 0;
           rplacd(oldloc,nil.oldloc)>>
         else locls!*:=(gg . list nil) . locls!*;
        if isglob(gg) or flagp(gg,'glb2rf) then globind gg;
        if flagp(gg,'seen) then
          <<qerline 0;
            prin2 "*** Function ";
            princng gg;
            prin2 " used as variable in ";
            princng curfun!*;
            newline 0>> >>
  end;

symbolic procedure globind gg;
  <<flag1(gg,'glb2bd); globref gg>>;

symbolic procedure remlocs lln;
   begin scalar oldloc;
    if !*globals then for each ll in lln do
      <<oldloc:=assoc(ll,locls!*);
        if null oldloc then
          if getd 'begin then rederr list(" Lvar confused",ll)
           else error(0,list(" Lvar confused",ll));
        if cddr oldloc then rplacd(oldloc,cddr oldloc)
         else locls!*:=efface1(oldloc,locls!*)>>
   end;

symbolic procedure add2calls fn;
% Update local CALLS!*;
   if not(flagp(fn,'nolist) or flagp(fn,'cinthis))
    then <<calls!*:=fn . calls!*; flag1(fn,'cinthis)>>;

symbolic procedure anform u;
        if atom u then anatom u
         else anform1 u;

symbolic procedure anforml l;
   begin
        while not atom l do <<anform car l; l:=cdr l>>;
        if l then anatom l
   end;

symbolic procedure anform1 u;
   begin scalar fn,x;
        fn:=car u; u:=cdr u;
        if not atom fn then return <<anform1 fn; anforml u>>;
        if not idp fn then return nil
         else if isglob fn then <<globref fn; return anforml u>>
         else if assoc(fn,locls!*) then return anforml u;
        add2calls fn;
        checkargcount(fn,length u);
        if flagp(fn,'noanl) then nil
         else if x:=get(fn,'anlfn) then apply(x,list u)
         else anforml u
   end;

symbolic anlfn procedure lambda u;
 <<add2locs car u; anforml cdr u; remlocs car u>>;

symbolic procedure anlsetq u;
 <<anforml u;
   if !*globals and flagp(u:=car u,'glb2rf) then flag1(u,'glb2st)>>;

put('setq,'anlfn,'anlsetq);

symbolic anlfn procedure cond u;
 for each x in u do anforml x;

symbolic anlfn procedure prog u;
 <<add2locs car u;
   for each x in cdr u do
    if not atom x then anform1 x;
   remlocs car u>>;

symbolic anlfn procedure function u;
 if pairp(u:=car u) then anform1 u
  else if isglob u then globref u
  else if null assoc(u,locls!*) then add2calls u;

flag('(quote go),'noanl);

symbolic anlfn procedure errorset u;
 begin scalar fn,x;
  anforml cdr u;
  if eqcar(u:=car u,'quote) then return ersanform cadr u
   else if not((eqcar(u,'cons) or (x:=eqcar(u,'list)))
               and quotp(fn:=cadr u))
    then return anform u;
  anforml cddr u;
  if pairp(fn:=cadr fn) then anform1 fn
   else if flagp(fn,'glb2rf) then nil
   else if isglob fn then globref fn
   else <<add2calls fn; if x then checkargcount(fn,length cddr u)>>
 end;

symbolic procedure ersanform u;
 begin scalar locls!*;
  return anform u
 end;

symbolic procedure anlmap u;
 <<anforml cdr u;
   if quotp(u:=caddr u) and idp(u:=cadr u)
      and not isglobl u and not assoc(u,locls!*)
     then checkargcount(u,1)>>;

for each x in '(map mapc maplist mapcar mapcon mapcan) do
 put(x,'anlfn,'anlmap);

symbolic anlfn procedure apply u;
 begin scalar fn;
  anforml cdr u;
  if quotp(fn:=cadr u) and idp(fn:=cadr fn) and eqcar(u:=caddr u,'list)
    then checkargcount(fn,length cdr u)
 end;

symbolic procedure quotp u; eqcar(u,'quote) or eqcar(u,'function);

put('cref ,'simpfg ,'((t (crefon)) (nil (crefoff))));

symbolic procedure outref(s,varlis,body,type);
 begin scalar curfun!*,calls!*,globs!*,locls!*,toplv!*,a;
  a:=if varlis memq '(anp!!atom anp!!idb anp!!eq anp!!unknown)
       then nil
      else length varlis;
  s := outrdefun(s,type,if a then a else get(body,'number!-of!-args));
  if a then <<add2locs varlis; anform(body); remlocs varlis>>
   else if null body or not idp body then nil
   else if varlis eq 'anp!!eq
    then <<put(s,'sameas,list body); traput(body,'alsois,s)>>
   else add2calls body;
  outrefend s
 end;

symbolic procedure traput(u,v,w);
 begin scalar a;
  if a:=get(u,v) then
    (if not(toplv!* or w memq a) then rplacd(a,w . cdr a))
   else put(u,v,list w)
 end;

smacro procedure toput(u,v,w);
 if w then put(u,v,if toplv!* then union(w,get(u,v)) else w);

symbolic procedure union(x,y);
   if null x then y
    else union(cdr x,if car x member y then y else car x . y);

symbolic procedure outrefend s;
  <<toput(s,'calls,calls!*);
    for each x in calls!* do
     <<remflag1(x,'cinthis);
        if not x eq s then <<chkseen x; traput(x,'calledby,s)>> >>;
    toput(s,'globs,globs!*);
    for each x in globs!* do
        <<traput(x,if isglob x then 'usedby
                    else <<chkgseen x; 'usedunby>>,s);
          remflag1(x,'glb2rf);
          if flagp(x,'glb2bd)
            then <<remflag1(x,'glb2bd); traput(x,'boundby,s)>>;
          if flagp(x,'glb2st)
            then <<remflag1(x,'glb2st); traput(x,'setby,s)>> >> >>;

symbolic procedure recref(s,type);
          <<qerline 2;
            prtatm "*** Redefinition to ";
            prin1 type;
            prtatm " procedure, of:";
            cref5 s;
            rempropss(list s,'(calls globs sameas));
            newline 2>>;

symbolic procedure outrdefun(s,type,v);
  begin
    s:=qtypnm(s,type);
    if flagp(s,'defd) then recref(s,type)
     else flag1(s,'defd);
    if flagp(type,'function) and (isglob s or assoc(s,locls!*)) then
      <<qerline 0;
        prin2 "**** Variable ";
        princng s;
        prin2 " defined as function";
        newline 0>>;
    if v and not flagp(type,'naryarg) then defineargs(s,v);
    put(s,'gall,curlin!* . type);
    globs!*:=nil;
    calls!*:=nil;
    return curfun!*:=s
  end;

flag('(macro fexpr),'naryarg);

symbolic procedure qtypnm(s,type);
 if flagp(type,'function) then <<chkseen s; s>>
  else begin scalar x,y,z;
        if (y:=get(type,'tseen)) and (x:=atsoc(s,cdr y))
          then return cdr x;
        if null y then
          <<y:=list ('!( . nconc(explode type,list '!)));
            put(type,'tseen,y); tseen!* := type . tseen!*>>;
        x := compress (z := explode s);
        rplacd(y,(s . x) . cdr y);
        y := append(car y,z);
        put(x,'rccnam,length y . y);
        traput(type,'funs,x);
        return x
       end;

symbolic procedure defineargs(name,n);
  begin scalar calledwith,x;
    calledwith:=get(name,'number!-of!-args);
    if null calledwith then return hasarg(name,n);
    if n=calledwith then return nil;
    if x := get(name,'calledby) then instdof(name,n,calledwith,x);
    hasarg(name,n)
  end;

symbolic procedure instdof(name,n,m,fnlst);
  <<qerline 0;
    prin2 "***** ";
    prin1 name;
    prin2 " called with ";
    prin2 m;
    prin2 " instead of ";
    prin2 n;
    prin2 " arguments in:";
    lprint(idsort fnlst,posn()+1);
    newline 0>>;

symbolic procedure hasarg(name,n);
  <<haveargs!*:=name . haveargs!*;
    if n>maxarg!* then
           <<qerline 0;
             prin2 "**** "; prin1 name;
             prin2 " has "; prin2 n;
             prin2 " arguments";
             newline 0 >>;
    put(name,'number!-of!-args,n)>>;

symbolic procedure checkargcount(name,n);
  begin scalar correctn;
    if flagp(name,'naryargs) then return nil;
    correctn:=get(name,'number!-of!-args);
    if null correctn then return hasarg(name,n);
    if not correctn=n then instdof(name,correctn,n,list curfun!*)
  end;

symbolic procedure refprint u;
 begin scalar x,y;
% x:=if cloc!* then filemk car cloc!* else "*ttyinput*";
  x:=if cloc!* then car cloc!* else "*TTYINPUT*";
  if (curfun!*:=assoc(x,pfiles!*)) then
    <<x:=car curfun!*; curfun!*:=cdr curfun!*>>
   else <<pfiles!*:=(x.(curfun!*:=gensym())).pfiles!*;
          y:=reversip cdr reversip cdr explode x;
          put(curfun!*,'rccnam,length y . y)>>;
  curlin!*:=if cloc!* and cdr cloc!* then x . cdr cloc!* else nil;
  calls!*:=globs!*:=locls!*:=nil;
  anform u;
  outrefend curfun!*
 end;

symbolic procedure filemk u;
   % Convert a file specification from lisp format to a string.
   % This is essentially the inverse of MKFILE;
 begin scalar dev,name,flg,flg2;
  if null u then return nil
   else if atom u then name := explode2 u
   else for each x in u do
    if x eq 'dir!: then flg := t
     else if atom x then
      if flg then dev := '!< . nconc(explode2 x,list '!>)
       else if x eq 'dsk!: then dev:=nil
       else if !%devp x then dev := explode2 x
       else name := explode2 x
     else if atom cdr x then
      name := nconc(explode2 car x,'!. . explode2 cdr x)
     else <<flg2 := t;
            dev := '![ . nconc(explode2 car x,
                               '!, . nconc(explode2 cadr x,list '!]))>>;
  u := if flg2 then nconc(name,dev)
        else nconc(dev,name);
  return compress('!" . nconc(u,'(!")))
 end;

flag('(smacro nmacro),'cref);

symbolic anlfn procedure put u;
 if toplv!* and qcputx cadr u then anputx u
  else anforml u;

put('putc,'anlfn,get('put,'anlfn));

symbolic procedure qcputx u;
 eqcar(u,'quote) and (flagp(cadr u,'cref) or flagp(cadr u,'compile));

symbolic procedure anputx u;
 begin scalar nam,typ,body;
  nam:=qcrf car u;
  typ:=qcrf cadr u;
  u:=caddr u;
  if atom u then <<body:=qcrf u; u:='anp!!atom>>
   else if car u memq '(quote function) then
    if eqcar(u:=cadr u,'lambda) then <<body:=caddr u; u:=cadr u>>
     else if idp u then <<body:=u; u:='anp!!idb>>
     else return nil
   else if car u eq 'cdr and eqcar(cadr u,'getd) then
    <<body:=qcrf cadadr u; u:='anp!!eq>>
   else if car u eq 'get and qcputx caddr u then
    <<body:=qtypnm(qcrf cadr u,cadr caddr u); u:='anp!!eq>>
   else if car u eq 'mkcode then
    <<anform cadr u; u:=qcrf caddr u; body:=nil>>
   else <<body:=qcrf u; u:='anp!!unknown>>;
  outref(nam,u,body,typ)
 end;

symbolic anlfn procedure putd u;
 if toplv!* then anputx u else anforml u;

symbolic anlfn procedure de u;
 outdefr(u,'expr);

symbolic anlfn procedure df u;
 outdefr(u,'fexpr);

symbolic anlfn procedure dm u;
 outdefr(u,'macro);

symbolic anlfn procedure dn u;   % PSL function
 outdefr(u,'macro);

symbolic anlfn procedure ds u;   % PSL function
 outdefr(u,'smacro);

symbolic procedure outdefr(u,type);
 outref(car u,cadr u,caddr u,type);

symbolic procedure qcrf u;
 if null u or u eq t then u
  else if eqcar(u,'quote) then cadr u
  else <<anform u; compress explode '!?value!?!?>>;

flag('(expr fexpr macro smacro nmacro),'function);

symbolic anlfn procedure lap u;
   if pairp(u:=qcrf car u) then
    begin scalar globs!*,locls!*,calls!*,curfun!*,toplv!*,x;
     while u do
      <<if pairp car u then
          if x:=get(op!*!*:=caar u,'crflapo) then apply(x,list u)
           else if !*globals then for each y in cdar u do anlapev y;
        u:=cdr u>>;
     qoutrefe()
    end;

symbolic crflapo procedure !*entry u;
 <<qoutrefe(); u:=cdar u; outrdefun(car u,cadr u,caddr u)>>;

symbolic procedure qoutrefe;
 begin
  if null curfun!* then
    if globs!* or calls!* then
      <<curfun!*:=compress explode '!?lap!?!?; chkseen curfun!*>>
     else return;
  outrefend curfun!*
 end;

symbolic crflapo procedure !*lambind u;
 for each x in caddar u do globind car x;

symbolic crflapo procedure !*progbind u;
 for each x in cadar u do globind car x;

symbolic procedure lincall u;
 <<add2calls car (u:=cdar u); checkargcount(car u,caddr u)>>;

put('!*link,'crflapo,'lincall);

put('!*linke,'crflapo,'lincall);

symbolic procedure anlapev u;
 if pairp u then
   if car u memq '(global fluid) then
     <<u:=cadr u; globref u;
       if flagp(op!*!*,'store) then put(u,'glb2st,'t)>>
    else <<anlapev car u; anlapev cdr u>>;

flag('(!*store),'store);

symbolic procedure qerline u;
 if pretitl!* then newline u
  else <<pretitl!*:=t; newpage()>>;

% These functions defined to be able to run in bare LISP;

symbolic procedure eqcar(u,v);
 pairp u and car u eq v;

symbolic procedure mkquote u; list('quote,u);

symbolic procedure efface1(u,v);
 if null v then nil
  else if u eq car v then cdr v
  else rplacd(v,efface1(u,cdr v));


% DECSystem 10/20 dependent part;

flag('(pop movem setzm hrrzm),'store);

symbolic procedure lapcallf u;
 begin scalar fn;
  return
   if eqcar(cadr (u:=cdar u),'e) then
     <<add2calls(fn:=cadadr u); checkargcount(fn,car u)>>
    else if !*globals then anlapev cadr u
 end;

put('jcall,'crflapo,'lapcallf);

put('callf,'crflapo,'lapcallf);

put('jcallf,'crflapo,'lapcallf);

symbolic crflapo procedure call u;
 if not(caddar u = '(e !*lambind!*)) then lapcallf u
  else while ((u:=cdr u) and pairp car u and caar u = 0) do
        globind cadr caddar u;

endmodule;


end;

Added r33/rend.red version [0f45790d17].





























































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
module rend; % Cray and Sun 4 PSL REDUCE "back-end".

% Authors: Martin L. Griss, Anthony C. Hearn and Winfried Neun.

% Except where noted, this works with both PSL 3.2 and PSL 3.4.

fluid '(!*break
        !*eolinstringok
        !*gc
        !*int
        !*mode
        !*usermode
        currentreadmacroindicator!*
        currentscantable!*
%       current!-modulus
        errout!*
        lispscantable!*
        promptstring!*
        rlispscantable!*);

global '(!$eol!$
         !*echo
         !*extraecho
         !*loadversion
         !*raise
         !*rlisp2
         crchar!*
         date!*
         esc!*
         e!-value!*
	 ft!-tolerance!*
         ifl!*
         ipl!*
	 largest!-small!-modulus
         ofl!*
         pi!-value!*
         spare!*
         statcounter
         systemname!*);

switch break,gc,usermode,verboseload;

!*fastcar := t;   % Since REDUCE doesn't use car and cdr on atoms.

% One inessential reference to REVERSIP in this module (left unchanged).

% This file defines the system dependent code necessary to run REDUCE
% under PSL.

Comment The following functions, which are referenced in the basic
REDUCE source (RLISP, ALG1, ALG2, MATR and PHYS) should be defined to
complete the definition of REDUCE:

        BYE
        DELCP
        ERROR1
        FILETYPE
        MKFIL
        ORDERP
        QUIT
        SEPRP
        SETPCHAR.

Prototypical descriptions of these functions are as follows;

remprop('bye,'stat);

symbolic procedure bye;
   %Returns control to the computer's operating system command level.
   %The current REDUCE job cannot be restarted;
   <<close!-output!-files(); exitlisp()>>;

deflist('((bye endstat)),'stat);

symbolic procedure delcp u;
   %Returns true if U is a semicolon, dollar sign, or other delimiter.
   %This definition replaces one in the BOOT file;
   u eq '!; or u eq '!$;

symbolic procedure seprp u;
   %returns true if U is a blank or other separator (eg, tab or ff).
   %This definition replaces one in the BOOT file;
   u eq '!  or u eq '!	 or u eq !$eol!$;

symbolic procedure error1;
   %This is the simplest error return, without a message printed. It can
   %be defined as ERROR(99,NIL) if necessary;
   throw('!$error!$,99);

symbolic procedure filetype u;
   %determines if string U has a specific file type.
   begin scalar v,w;
      v := cdr explode u;
      while v and not(car v eq '!.) do
        <<if car v eq '!< then while not(car v eq '!>) do v := cdr v;
          v := cdr v>>;
      if null v then return nil;
      v := cdr v;
      while v and not(car v eq '!") do <<w := car v . w; v := cdr v>>;
      return intern compress reversip w
   end;

symbolic procedure mkfil u;
   %converts file descriptor U into valid system filename;
   if stringp u then u
    else if not idp u then typerr(u,"file name")
    else string!-downcase id2string u;

% The following is a pretty crude definition, but since it isn't used
% very much, its performance doesn't really matter.

symbolic procedure string!-downcase u;
   begin scalar z;
      if not stringp u then u := id2string u;
      for each x in explode u do
	 if x memq
	      '(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)
		  then z := cdr atsoc(x,
		      '((A . !a) (B . !b) (C . !c) (D . !d) (E . !e)
		       (F . !f) (G . !g) (H . !h) (I . !i) (J . !j)
		       (K . !k) (L . !l) (M . !m) (N . !n) (O . !o)
		       (P . !p) (Q . !q) (R . !r) (S . !s) (T . !t)
		       (U . !u) (V . !v) (W . !w) (X . !x) (Y . !y)
		       (Z . !z))) . z
	  else z := x . z;
      return compress reverse z
   end;

symbolic procedure orderp(u,v);
   % Returns true if U has same or higher order than id V by some
   % consistent convention (eg unique position in memory).
   wleq(inf u,inf v);       % PSL 3.4 form.
%  id2int u <= id2int v;    % PSL 3.2 form.

procedure setpchar c;
   % Set prompt, return old one.
   begin scalar oldprompt;
    oldprompt := promptstring!*;
    promptstring!* := if stringp c then c
                      else if idp c then copystring id2string c
                      else bldmsg("%W", c);
    return oldprompt
   end;


Comment The following functions are only referenced if various flags are
set, or the functions are actually defined. They are defined in another
module, which is not needed to build the basic system. The name of the
flag follows the function name, enclosed in parentheses:

        BFQUOTIENT!: (BIGFLOAT)
        CEDIT (?)
        COMPD (COMP)
        EDIT1   This function provides a link to an editor. However, a
                definition is not necessary, since REDUCE checks to see
                if it has a function value.
        EMBFN (?)
        EZGCDF (EZGCD)
        FACTORF (FACTOR)
        LOAD!-MODULE (defined in prolog)
        PRETTYPRINT (DEFN --- also called by DFPRINT)
                This function is used in particular for output of RLISP
                expressions in LISP syntax. If that feature is needed,
                and the prettyprint module is not available, then it
                should be defined as PRINT
        RPRINT (PRET)
        TEXPT!: (BIGFLOAT)
        TEXPT!:ANY (BIGFLOAT)
        TIME (TIME) returns elapsed time from some arbitrary initial
                    point in milliseconds;


Comment The FACTOR module also requires a definition for GCTIME. Since
this is currently undefined in PSL, we provide the following definition;

symbolic procedure gctime; gctime!*;


Comment The following operator is used to save a REDUCE session as a
file for later use;

symbolic procedure savesession u;
   savesystem("Saved session",u,nil);

flag('(savesession),'opfn);

flag('(savesession),'noval);


Comment make "cd" and "system" available as operators;

flag('(cd system),'opfn);

flag('(cd system),'noval);


Comment The current REDUCE model allows for the availability of fast
arithmetical operations on small integers (called "inums").  All modern
LISPs provide such support.  However, the program will still run without
these constructs.  The relevant functions that should be defined for
this purpose are as follows;

remflag('(iplus itimes),'lose);

remprop('iplus,'infix);   % to allow for redefinition.

remprop('itimes,'infix);

symbolic macro procedure iplus u; expand(cdr u,'iplus2);

symbolic macro procedure itimes u; expand(cdr u,'itimes2);

flag('(iplus itimes iplus2 itimes2 iadd1 isub1 iminus iminusp
       idifference iquotient iremainder ilessp igreaterp), 'lose);

Comment There are also a number of system constants required for each
implementation. In systems that don't support inums, the equivalent
single precision integers should be used;

% E!-VALUE and PI!-VALUE are values for these constants that fit in
% the single precision floating point range of the machine.
% FT!-TOLERANCE is the tolerance of floating point calculations.
% LARGEST!-SMALL!-MODULUS is the largest power of two that can
% fit in the fast arithmetic (inum) range of the implementation.
% These four are constant for the life of the system and could be
% compiled in-line if the compiler permits it.

e!-value!* := 2.718282;

pi!-value!* := 3.141593;

ft!-tolerance!* := 0.000001;

largest!-small!-modulus := 2**23;

% If the (small) modular arithmetic is always limited to LARGEST-SMALL-
% MODULUS, it all fits in the inum range of the machine, with the
% exception of modular-times, that needs to use generic arithmetic for
% the multiplication.  However, on some machines (e.g., the VAX), it is
% possible to 'borrow' the extra precision needed, so that the following
% definition works.  This will not work of course for non-inums.

% remflag('(modular!-times),'lose);

% smacro procedure modular!-times(u,v);
%    iremainder(itimes2(u,v),current!-modulus);

% flag('(modular!-times),'lose);


% The following two definitions are commented out as they lead to
% unchecked vector ranges;

% symbolic smacro procedure getv(a,b); igetv(a,b);

% symbolic smacro procedure putv(a,b,c); iputv(a,b,c);

flag('(intersection),'lose);


Comment PSL Specific patches;

Comment We need to define a function BEGIN, which acts as the top-level
call to REDUCE, and sets the appropriate variables;

% global '(startuproutine!* toploopread!* toploopeval!* toploopprint!*
%          toploopname!*);

remflag('(begin),'go);

symbolic procedure begin;
   begin
        !*echo := not !*int;
        !*extraecho := t;
        ifl!* := ipl!* := ofl!* := nil;
        if null date!* then go to a;
        if !*loadversion then errorset('(load entry),nil,nil);
        !*gc := nil;
        !*usermode := nil;
        linelength if !*int then 80 else 115;
        prin2 "REDUCE 3.3, ";
        prin2 date!*;
        prin2t " ...";
        !*mode := if getd 'addsq then 'algebraic else 'symbolic;
        if !*mode eq 'algebraic then !*break := nil;
           %since most REDUCE users won't use LISP
        date!* := nil;
a:      crchar!* := '! ;
        if errorp errorset('(begin1),nil,nil) then go to a;
           %until PSL fixed
        prin2t "Entering LISP ... "
 end;

flag('(begin),'go);


Comment Initial setups for REDUCE;

spare!* := 11;   % We need this for bootstrapping.

symbolic procedure initreduce;
  % Initial declarations for REDUCE
  <<statcounter := 0;
    spare!* := 11;
    !*int := t;
    !*eolinstringok := t;  % we don't want the "string continued" msg.
    remd 'main;
    copyd('main,'rlispmain);
    date!* := date()>>;

symbolic procedure rlispmain;
  begin scalar l;
    rlispscantable!* := mkvect 128;
    l := '(17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11
           11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11
           11 11 13 11 11 11 20 11 00 01 02 03 04 05 06 07 08 09 13 11
           13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
           10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10
           10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
           10 10 10 11 11 11 11 11 rlispdipthong);
    for i:=0:128 do <<putv(rlispscantable!*,i,car l); l := cdr l>>;
    currentreadmacroindicator!* := 'rlispreadmacro;
    currentscantable!* := rlispscantable!*;
    errout!* := 1;  % Errors to standard output, not special stream;
    eval '(begin);
    currentscantable!* := lispscantable!*; % But Slisp should use same
                                           % syntax as RLISP?
    standardlisp()
  end;

flag('(dskin savesystem reclaim),'opfn);

flag('(dskin savesystem),'noval);

flag('(load),'noform);

deflist('((load rlis)),'stat);

flag('(tr trst untr untrst),'noform);

deflist('((tr rlis) (trst rlis) (untr rlis) (untrst rlis)),'stat);

% The following is PSL 3.4 specific.

switch fulltrace;   % Prevents node renaming in trace output.

!*fulltrace := t;   % Since we usually want it this way.

Comment The global variable ESC* is used by the interactive string
editor (defined in CEDIT) as a terminator for input strings.  In PSL
we use the escape character;

esc!* := '!;


Comment The following declarations are needed to build various modules;

flag('(nth pnth spaces subla),'lose);   % used in ALG1

flag('(explode2 explode21),'lose);      % used in RPRINT

flag('(flag1 remflag1),'lose);          % used in RCREF


Comment The following are only needed for PSL 3.2;

% symbolic fexpr procedure definebop u; u;

% symbolic fexpr procedure definerop u; u;


Comment Specific Optimizations for Cray and Sun 4 version;

remflag('(quotdd),'lose);

symbolic procedure quotdd(u,v);
   % U and V are domain elements.  Value is U/V if division is exact,
   % NIL otherwise.
   if atom u then if atom v
          %%%        then if remainder(u,v)=0 then u/v else nil
                     then (if cdr div = 0 then car div else NIL)
                                   where div = divide (u,v)
                    else quotdd(apply1(get(car v,'i2d),u),v)
   else if atom v then quotdd(u,apply1(get(car u,'i2d),v))
        else dcombine(u,v,'quotient);

flag('(quotdd),'lose);

remflag('(mchk),'lose);

symbolic procedure mchk(u,v);
   IF u eq v then cons(nil,nil)
    else mchk!-aux (u,v);

symbolic procedure mchk!-aux(U,V);
   if not idp u and not idp v and u=v then cons(nil,nil)
    else if atom v
	 then if v memq frlis!* then list list (v . u) else nil
    else if atom u      %special check for negative number match;
     then if numberp u and u<0 then mchk!-aux(list('minus,-u),v)
	 else nil
    else if car u eq car v then mcharg(cdr u,cdr v,car u)
    else nil;

flag('(mchk),'lose);

remflag('(update!-pline),'lose);

symbolic procedure update!-pline(x,y,pline);
   for each j in pline collect
       ((iplus2(caaar j,x) . iplus2(cdaar j,x))
                                 . iplus2(cdar j ,y)) . cdr j;

flag('(update!-pline),'lose);

remflag('(peq ordpp noncomp),'lose);

symbolic smacro procedure peq(u,v);
   %tests for equality of powers U and V;
  (( eq(cdu1,cdu2) and
     if eq(cu1,cu2) then t
        else if atom cu1 or atom cu2 then NIL
                else equal(cu1,cu2)
   ) where cu1 = car u1,cu2 = car u2,cdu1 = cdr u1,cdu2 = cdr u2
  ) where u1 = u,u2 = v;

symbolic smacro procedure ordpp(uu,vv);
   % This used to check (incorrectly) for NCMP!*;
 ((if caru eq carv then igreaterp(cdru,cdrv) else ordop(caru,carv)
  ) where caru = car u, carv = car v, cdru = cdr u, cdrv = cdr v
 )where u=uu,v=vv;

symbolic smacro procedure noncomp uu;
  ( pairp u and ((idp caru and flagp(caru,'noncom)
                )where caru = car u)) where u = uu;

flag('(peq ordpp noncomp),'lose);


Comment Now set the system name;

systemname!* := 'sparc;

endmodule;

end;

Added r33/rlisp.red version [8bdc4a17ce].





























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
% module module; % Support for module use.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*mode);

global '(exportslist!* importslist!* module!-name!* old!-mode!*);

!*mode := 'symbolic;   % initial value.

symbolic procedure exports u;
   begin exportslist!* := union(u,exportslist!*); end;

symbolic procedure imports u;
   begin importslist!* := union(u,importslist!*); end;

symbolic procedure module u;
   %Sets up a module definition;
   begin
      if null module!-name!* then old!-mode!* := !*mode;
      module!-name!* := car u . module!-name!*;
      !*mode := 'symbolic
   end;

symbolic procedure endmodule;
   begin
      if null module!-name!*
        then rederr  "ENDMODULE called outside module";
      exportslist!* := nil;
      importslist!* := nil;
      module!-name!* := cdr module!-name!*;
      if module!-name!* then return nil;
      !*mode := old!-mode!*;
      old!-mode!* := nil
   end;

deflist('((exports rlis) (imports rlis) (module rlis)),'stat);

put('endmodule,'stat,'rlis); % Done this way for bootstrapping purposes.

flag('(endmodule),'go);

% endmodule;


module newtok;  % Functions for introducing infix tokens to the system.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*redeflg!*);

global '(!*msg preclis!*);

%Several operators in REDUCE are used in an infix form  (e.g.,
%+,- ). The internal alphanumeric names associated with these
%operators are introduced by the function NEWTOK defined below.
%This association, and the precedence of each infix operator, is
%initialized in this section. We also associate printing characters
%with each internal alphanumeric name as well;

preclis!*:= '(or and not member memq equal neq eq geq greaterp leq
              lessp freeof plus difference times quotient expt cons);

deflist ('(
   (not not)
   (plus plus)
   (difference minus)
   (minus minus)
   (times times)
   (quotient recip)
   (recip recip)
 ), 'unary);

flag ('(and or !*comma!* plus times),'nary);

flag ('(cons setq plus times),'right);

deflist ('((minus plus) (recip times)),'alt);

symbolic procedure mkprec;
   begin scalar x,y,z;
        x := 'where . ('!*comma!* . ('setq . preclis!*));
        y := 1;
    a:  if null x then return nil;
        put(car x,'infix,y);
        put(car x,'op,list list(y,y));   %for RPRINT;
        if z := get(car x,'unary) then put(z,'infix,y);
        if and(z,null flagp(z,'nary)) then put(z,'op,list(nil,y));
        x := cdr x;
        y := add1 y;
        go to a
   end;

mkprec();

symbolic procedure newtok u;
   begin scalar !*redeflg!*,x,y;
      if atom u or atom car u or null idp caar u
        then typerr(u,"NEWTOK argument");
      % set up SWITCH* property.
      put(caar u,'switch!*,
          cdr newtok1(car u,cadr u,get(caar u,'switch!*)));
      % set up PRTCH property.
      y := intern compress consescc car u;
      if !*redeflg!* then lprim list(y,"redefined");
      put(cadr u,'prtch,y);
      if x := get(cadr u,'unary) then put(x,'prtch,y)
   end;

symbolic procedure newtok1(charlist,name,propy);
      if null propy then lstchr(charlist,name)
       else if null cdr charlist
        then begin
                if cdr propy and !*msg then !*redeflg!* := t;
                return list(car charlist,car propy,name)
             end
       else car charlist . newtok2(cdr charlist,name,car propy)
                         . cdr propy;

symbolic procedure newtok2(charlist,name,assoclist);
   if null assoclist then list lstchr(charlist,name)
    else if car charlist eq caar assoclist
     then newtok1(charlist,name,cdar assoclist) . cdr assoclist
    else car assoclist . newtok2(charlist,name,cdr assoclist);

symbolic procedure consescc u;
   if null u then nil else '!! . car u . consescc cdr u;

symbolic procedure lstchr(u,v);
   if null cdr u then list(car u,nil,v)
    else list(car u,list lstchr(cdr u,v));

newtok '((!$) !*semicol!*);
newtok '((!;) !*semicol!*);
newtok '((!+) plus);
newtok '((!-) difference);
newtok '((!*) times);
newtok '((!^) expt);
newtok '((!* !*) expt);
newtok '((!/) quotient);
newtok '((!=) equal);
newtok '((!,) !*comma!*);
newtok '((!() !*lpar!*);
newtok '((!)) !*rpar!*);
newtok '((!:) !*colon!*);
newtok '((!: !=) setq);
newtok '((!.) cons);
newtok '((!<) lessp);
newtok '((!< !=) leq);
newtok '((!< !<) !*lsqb!*);
newtok '((!>) greaterp);
newtok '((!> !=) geq);
newtok '((!> !>) !*rsqb!*);

put('expt,'prtch,'!*!*);   % To ensure that FORTRAN output is correct.

flag('(difference minus plus setq),'spaced);

flag('(newtok),'eval);

endmodule;


module support;   % Basic functions needed to support RLISP and REDUCE.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

symbolic procedure aconc(u,v);
   %adds element v to the tail of u. u is destroyed in process;
   nconc(u,list v);

symbolic procedure arrayp u; get(u,'rtype) eq 'array;

symbolic procedure atsoc(u,v);
   if null v then nil
    else if u eq caar v then car v
    else atsoc(u,cdr v);

symbolic procedure eqcar(u,v); null atom u and car u eq v;

symbolic procedure flagpcar(u,v);
   null atom u and idp car u and flagp(car u,v);

symbolic procedure idlistp u;
   % True if u is a list of id's.
   null u or null atom u and idp car u and idlistp cdr u;

symbolic procedure mkprog(u,v); 'prog . (u . v);

symbolic procedure mkquote u; list('quote,u);

symbolic procedure mksetq(u,v); list('setq,u,v);

symbolic procedure pairvars(u,vars,mode);
   % Sets up pairings of parameters and modes.
   begin scalar x;
   a: if null u then return append(reversip!* x,vars)
       else if null idp car u then symerr("Invalid parameter",nil);
      x := (car u . mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure prin2t u; progn(prin2 u, terpri(), u);

symbolic procedure reversip u;
   begin scalar x,y;
    a:  if null u then return y;
        x := cdr u; y := rplacd(u,y); u := x;
        go to a
   end;

symbolic procedure smemq(u,v);
   %true if id U is a member of V at any level (excluding
   %quoted expressions);
   if atom v then u eq v
    else if car v eq 'quote then nil
    else smemq(u,car v) or smemq(u,cdr v);

symbolic procedure union(x,y);
   if null x then y
    else union(cdr x,if car x member y then y else car x . y);

symbolic procedure xn(u,v);
   if null u then nil
    else if car u member v then car u . xn(cdr u,delete(car u,v))
    else xn(cdr u,v);

symbolic procedure u>=v; null(u<v);

symbolic procedure u<=v; null(u>v);

symbolic procedure u neq v; null(u=v);

symbolic procedure setdiff(u,v);
   if null v then u else setdiff(delete(car v,u),cdr v);

% symbolic smacro procedure u>=v; null(u<v);

% symbolic smacro procedure u<=v; null(u>v);

% symbolic smacro procedure u neq v; null(u=v);

% List changing alternates (may also be defined as copying functions)

symbolic procedure aconc!*(u,v); nconc(u,list v);  % append(u,list v);

symbolic procedure nconc!*(u,v); nconc(u,v);       % append(u,v);

symbolic procedure reversip!* u; reversip u;       % reverse u;

symbolic procedure rplaca!*(u,v); rplaca(u,v);     % v . cdr u;

symbolic procedure rplacd!*(u,v); rplacd(u,v);     % car u . v;

% The following functions should be provided in the compiler for
% efficient coding.

symbolic procedure apply1(u,v); apply(u,list v);

symbolic procedure apply2(u,v,w); apply(u,list(v,w));

symbolic procedure apply3(u,v,w,x); apply(u,list(v,w,x));

% The following function is needed by several modules. It is more
% REDUCE-specific than other functions in this module, but since it
% needs to be defined early on, it might as well go here.

symbolic procedure gettype u;
   % Returns a REDUCE-related type for the expression U.
   % It needs to be more table driven than the current definition.
   if numberp u then 'number
    else if null atom u or null u or null idp u then 'form
    else if get(u,'simpfn) then 'operator
    else if get(u,'avalue) then 'variable
    else if getd u then 'procedure
    else if globalp u then 'global
    else if fluidp u then 'fluid
    else if flagp(u,'parm) then 'parameter
    else get(u,'rtype);

endmodule;


module slfns;  % Complete list of Standard LISP functions.

% Author: Anthony C. Hearn.

global '(!*argnochk slfns!*);

slfns!* := '(
        (abs 1)
        (add1 1)
        (append 2)
        (apply 2)
        (assoc 2)
        (atom 1)
        (car 1)
        (cdr 1)
        (caar 1)
        (cadr 1)
        (cdar 1)
        (cddr 1)
        (caaar 1)
        (caadr 1)
        (cadar 1)
        (caddr 1)
        (cdaar 1)
        (cdadr 1)
        (cddar 1)
        (cdddr 1)
        (caaaar 1)
        (caaadr 1)
        (caadar 1)
        (caaddr 1)
        (cadaar 1)
        (cadadr 1)
        (caddar 1)
        (cadddr 1)
        (cdaaar 1)
        (cdaadr 1)
        (cdadar 1)
        (cdaddr 1)
        (cddaar 1)
        (cddadr 1)
        (cdddar 1)
        (cddddr 1)
        (close 1)
        (codep 1)
        (compress 1)
        (cons 2)
        (constantp 1)
        (de 3)
        (deflist 2)
        (delete 2)
%       (DF 3)                     conflicts with algebraic operator DF
        (difference 2)
        (digit 1)
        (divide 2)
        (dm 3)
        (dn 3)
        (ds 3)
        (eject 0)
        (eq 2)
        (eqn 2)
        (equal 2)
        (error 2)
        (errorset 3)
        (eval 1)
        (evlis 1)
        (expand 2)
        (explode 1)
        (expt 2)
        (fix 1)
        (fixp 1)
        (flag 2)
        (flagp 2)
        (float 1)
        (floatp 1)
        (fluid 1)
        (fluidp 1)
        (function 1)
        (gensym 0)
        (get 2)
        (getd 1)
        (getv 2)
        (global 1)
        (globalp 1)
        (go 1)
        (greaterp 2)
        (idp 1)
        (intern 1)
        (length 1)
        (lessp 2)
        (linelength 1)
        (liter 1)
        (lposn 0)
        (map 2)
        (mapc 2)
        (mapcan 2)
        (mapcar 2)
        (mapcon 2)
        (maplist 2)
        (max2 2)
        (member 2)
        (memq 2)
        (minus 1)
        (minusp 1)
        (min2 2)
        (mkvect 1)
        (nconc 2)
        (not 1)
        (null 1)
        (numberp 1)
        (onep 1)
        (open 2)
        (pagelength 1)
        (pair 2)
        (pairp 1)
        (plus2 2)
        (posn 0)
        (print 1)
        (prin1 1)
        (prin2 1)
        (prog2 2)
        (put 3)
        (putd 3)
        (putv 3)
        (quote 1)
        (quotient 2)
        (rds 1)
        (read 0)
        (readch 0)
        (remainder 2)
        (remd 1)
        (remflag 2)
        (remob 1)
        (remprop 2)
        (return 1)
        (reverse 1)
        (rplaca 2)
        (rplacd 2)
        (sassoc 3)
        (set 2)
        (setq 2)
        (stringp 1)
        (sublis 2)
        (subst 3)
        (sub1 1)
        (terpri 0)
        (times2 2)
        (unfluid 1)
        (upbv 1)
        (vectorp 1)
        (wrs 1)
        (zerop 1)
        );

if !*argnochk then deflist(slfns!*,'number!-of!-args);

endmodule;


module superv; % REDUCE supervisory functions.

% Author: Anthony C. Hearn.

% Modified by: Jed B. Marti.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*backtrace
        !*defn
        !*errcont
        !*int
        !*mode
        !*slin
        !*time
        dfprint!*
        lreadfn!*
        semic!*
        tslin!*);

global '(!$eof!$
         !*byeflag!*
         !*demo
         !*echo
         !*extraecho
         !*lessspace
         !*micro!-version
         !*nosave!*
         !*output
         !*pret
         !*rlisp2
         !*strind
         !*struct
         cloc!*
         cmsg!*
         crbuf!*
         crbuflis!*
         crbuf1!*
         cursym!*
         eof!*
         erfg!*
         ifl!*
         ipl!*
         initl!*
         inputbuflis!*
         key!*
         ofl!*
         opl!*
         ogctime!*
         otime!*
         program!*
         programl!*
         promptexp!*
         resultbuflis!*
         st!*
         statcounter
         symchar!*
         tok!*
         ttype!*
         ws);

!*output := t;
eof!* := 0;
initl!* := '(fname!* outl!*);
statcounter := 0;

% The true REDUCE supervisory function is BEGIN, again defined in the
% system dependent part of this program.  However, most of the work is
% done by BEGIN1, which is called by BEGIN for every file encountered
% on input;

symbolic procedure errorp u;
   %returns true if U is an ERRORSET error format;
   atom u or cdr u;

symbolic procedure flagp!*!*(u,v); idp u and flagp(u,v);

symbolic procedure printprompt u;
   %Prints the prompt expression for input;
   progn(ofl!* and wrs nil, prin2 u, ofl!* and wrs cdr ofl!*);

symbolic procedure setcloc!*;
   % Used to set for file input a global variable CLOC!* to dotted pair
   % of file name and dotted pair of line and page being read.
   % Currently a place holder for system specific function, since not
   % supported in Standard LISP.  CLOC!* is used in the INTER and RCREF
   % modules.
   cloc!* := if null ifl!* then nil else car ifl!* . nil;

symbolic procedure command;
   begin scalar x;
        if !*demo and (x := ifl!*)
          then progn(terpri(),rds nil,readch(),rds cadr x);
        if null !*slin 
         then if !*rlisp2
                then progn(s!&(),
                           key!* := tok!*,
                           m!-metarlisp(),
                           (if st!* then x := car st!* else x := nil),
                           st!* := nil)
               else progn(scan(), setcloc!*(), key!* := cursym!*,
                          x := xread1 nil)
         else progn(key!* := (semic!* := '!;),
                    setcloc!*(),
                    x := (if lreadfn!* then apply(lreadfn!*,nil)
                          else read()),
                    if key!* eq '!;
                      then key!* := if atom x then x else car x);
        if !*struct then x := structchk x;
        if !*pret then progn(terpri(),rprint x);
        if null !*slin then x := form x;
        return x
   end;

symbolic procedure begin1;
   begin scalar mode,parserr,result,x;
        if !*rlisp2 then prolog 'm!-metarlisp;
        otime!* := time();
        % the next line is that way for bootstrapping purposes.
        if getd 'gctime then ogctime!* := gctime() else ogctime!* := 0;
    a0: cursym!* := '!*semicol!*;
    a:  if null terminalp() or !*nosave!* then go to b
         else if statcounter>0 then add2buflis();
        statcounter := statcounter + 1;
        crbuf1!* := nil;   % For input string editor.
        !*strind := 0;     % Used by some versions of input editor.
        promptexp!* :=
           compress('!! . append(explode statcounter,
                       explode if null symchar!* or !*mode eq 'algebraic
                                 then '!:!  else '!*! ));
        setpchar promptexp!*;
    b:  parserr := nil;
        !*nosave!* := nil;
        if !*time then eval '(showtime);   %Since a STAT;
        if !*output and null ofl!* and terminalp() and null !*defn
           and null !*lessspace
          then terpri();
        if tslin!*
          then progn(!*slin := car tslin!*,
                     lreadfn!* := cdr tslin!*,
                     tslin!* := nil);
        mapcar(initl!*,function sinitl);
        if !*int then erfg!* := nil;    %to make editing work properly;
        if null !*rlisp2 and cursym!* eq 'end
          then progn(comm1 'end, return nil)
         else if terminalp() and (!*rlisp2 or null(key!* eq 'ed))
          then printprompt promptexp!*;
        program!* := errorset('(command),t,!*backtrace);
        if !*rlisp2
          then if tok!* eq '!*semic!* then semic!* := '!;
                else semic!* := '!$;
        condterpri();
        if errorp program!* then go to err1;
        program!* := car program!*;
        if eofcheck() then go to c else eof!* := 0;
        if !*rlisp2 then if program!* = '(end) then return nil else nil
          else if cursym!* eq 'end
           then if !*micro!-version and terminalp() then go to a0
                 else progn(comm1 'end, return nil)
         else if eqcar(program!*,'retry) then program!* := programl!*;
        %The following section decides what the target mode should be.
        %That mode is also assumed to be the printing mode;
        if flagp!*!*(key!*,'modefn) then mode := key!*
         else if null atom program!* % and null !*micro!-version
          and null(car program!* eq 'quote)
           and (null(idp car program!* 
                   and (flagp(car program!*,'nochange)
                         or flagp(car program!*,'intfn)
                         or car program!* eq 'list))
             or car program!* memq '(setq setel setf)
                     and eqcar(caddr program!*,'quote))
          then mode := 'symbolic
         else if key!* eq 'input
            and (x := rassoc!*(program!*,inputbuflis!*))
          then mode := cddr x
         else mode := !*mode;
        program!* := convertmode1(program!*,nil,'symbolic,mode);
        add2inputbuf(program!*,!*mode);
           % This used to be MODE, but then ED n wouldn't work.
        if null !*rlisp2 and null atom program!*
            and car program!* memq '(bye quit)
          then if getd 'bye then progn(eval program!*, go to b)
                else progn(!*byeflag!* := t, return nil)
         else if null !*rlisp2 and eqcar(program!*,'ed)
          then progn((if getd 'cedit and terminalp()
                        then cedit cdr program!*
                       else lprim "ED not supported"),
                     go to b)
         else if !*defn
          then if erfg!* then go to a
                else if null flagp!*!*(key!*,'ignore)
                  and null eqcar(program!*,'quote)
                 then go to d;
    b1: if !*output and ifl!* and !*echo and null !*lessspace
          then terpri();
        result := errorset((if mode eq 'symbolic then program!*
                            else list('assgneval,mkquote program!*)),
                           t,!*backtrace);
        if errorp result or erfg!*
          then progn(programl!* := program!*,go to err2)
         else if !*defn then go to a;
        if null(mode eq 'symbolic)
         then progn(program!* := cdar result,
                    result := list caar result); 
        add2resultbuf(car result,mode);
        if null !*output then go to a
         else if (null !*rlisp2 and semic!* eq '!;)
           or (!*rlisp2 and tok!* eq '!*semic!*)
          then if mode eq 'symbolic
                then if null car result and null(!*mode eq 'symbolic)
                       then nil
                 else begin
                    terpri();
                    result := errorset(list('print,mkquote car result),
                                       t,!*backtrace)
                      end
         else if car result
          then result := errorset(list('varpri,mkquote car result,
                                     mkquote program!*,
                                     mkquote 'only),
                        t,!*backtrace);
        if errorp result then go to err3 else go to a;
    c:  if crbuf1!* then
          progn(lprim "Closing object improperly removed. Redo edit.",
                  crbuf1!* := nil, go to a)
          else if eof!*>4
           then progn(lprim "End-of-file read", return eval '(bye))
         else if terminalp() then progn(crbuf!* := nil, go to b)
         else return nil;
    d:  if program!* then dfprint program!*;
        if null flagp!*!*(key!*,'eval) then go to a else go to b1;
    err1:
        if eofcheck() or eof!*>0 then go to c
         else if program!*="BEGIN invalid" then go to a;
        parserr := t;
    err2:
        resetparser();  %in case parser needs to be modified;
    err3:
        erfg!* := t;
        if null !*int and null !*errcont
          then progn(!*defn := t,
                     !*echo := t,
                     (if null cmsg!*
                        then lprie "Continuing with parsing only ..."),
                     cmsg!* := t)
         else if null !*errcont
          then progn(result := pause1 parserr,
                     (if result then return null eval result),
                     erfg!* := nil)
         else erfg!* := nil;
        go to a
   end;

flag ('(deflist flag fluid global remflag remprop unfluid),'eval);

symbolic procedure assgneval u; 
   % Evaluate (possible) assignment statements and return results in a
   % form that allows required printing of such assignments.
   begin scalar x,y;
   a: if atom u then go to b
       else if car u eq 'setq then x := ('setq . cadr u) . x
       else if car u eq 'setel 
        then x := ('setel . mkquote eval cadr u) . x
       else if car u eq 'setk
        then x := ('setk . mkquote if atom (y := eval cadr u) then y 
                                    else car y . revlis cdr y) . x
       else go to b;
      u := caddr u;
      go to a;
   b: u := mkquote eval u;
   c: if null x then return(eval u . u);
      u := list(caar x,cdar x,u);
      x := cdr x;
      go to c
   end;

symbolic procedure rassoc!*(u,v);
   % Finds term in which U is the first term in the right part of a term
   % in the association list V, or NIL if term is not found;
   if null v then nil
    else if u = cadar v then car v
    else rassoc!*(u,cdr v);

symbolic procedure close!-input!-files;
   % Close all input files currently open;
   begin
      if ifl!* then progn(rds nil,ifl!* := nil);
  aa: if null ipl!* then return nil;
      close cdar ipl!*;
      ipl!* := cdr ipl!*;
      go to aa
   end;

symbolic procedure close!-output!-files;
   % Close all output files currently open;
   begin
      if ofl!* then progn(wrs nil,ofl!* := nil);
  aa: if null opl!* then return nil;
      close cdar opl!*;
      opl!* := cdr opl!*;
      go to aa
   end;

symbolic procedure add2buflis;
   begin
      if null crbuf!* then return nil;
      crbuf!* := reversip crbuf!*;   %put in right order;
   a: if seprp car crbuf!* then progn(crbuf!* := cdr crbuf!*, go to a);
      crbuflis!* := (statcounter . crbuf!*) . crbuflis!*;
      crbuf!* := nil
   end;

symbolic procedure add2inputbuf(u,mode);
   begin
      if null terminalp() or !*nosave!* then return nil;
      inputbuflis!* := (statcounter . u . mode) . inputbuflis!*
   end;

symbolic procedure add2resultbuf(u,mode);
   begin
      if mode eq 'symbolic or null u or !*nosave!* then return nil;
      ws := u;
      if terminalp()
        then resultbuflis!* := (statcounter . u) . resultbuflis!*
   end;

symbolic procedure condterpri;
   !*output and !*echo and !*extraecho and (null !*int or ifl!*)
        and null !*defn and terpri();

symbolic procedure eofcheck;
   % true if an end-of-file has been read in current input sequence;
   program!* eq !$eof!$ and ttype!*=3 and (eof!* := eof!*+1);

symbolic procedure resetparser;
   %resets the parser after an error;
   if null !*slin then comm1 t;

symbolic procedure terminalp;
   %true if input is coming from an interactive terminal;
   !*int and null ifl!*;

symbolic procedure dfprint u;
   %Looks for special action on a form, otherwise prettyprints it;
   if dfprint!* then apply(dfprint!*,list u)
    else if cmsg!* then nil
    else if null eqcar(u,'progn) then prettyprint u
    else begin
            a:  u := cdr u;
                if null u then return nil;
                dfprint car u;
                go to a
         end;

symbolic procedure showtime;
   begin scalar x,y;
      x := otime!*;
      otime!* := time();
      x := otime!*-x;
      y := ogctime!*;
      ogctime!* := gctime();
      y := ogctime!* - y;
      x := x - y;
      terpri();
      prin2 "Time: "; prin2 x; prin2 " ms";
      if y = 0 then return terpri();
      prin2 "  plus GC time: "; prin2 y; prin2 " ms"
   end;

symbolic procedure sinitl u;
   set(u,get(u,'initl));

endmodule;


module tok; % Identifier and reserved character reading.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(semic!*);

global '(!$eof!$
         !$eol!$
         !*quotenewnam
         !*raise
         crbuf!*
         crbuf1!*
         crchar!*
         curline!*
         cursym!*
         eof!*
         ifl!*
         nxtsym!*
         outl!*
         ttype!*);

!*quotenewnam := t;

crchar!* := '! ;

curline!* := 1;

% The function TOKEN defined below is used for reading identifiers
% and reserved characters (such as parentheses and infix operators).
% It is called by the function SCAN, which translates reserved
% characters into their internal name, and sets up the output of the
% input line.  The following definitions of TOKEN and SCAN are quite
% general, but also inefficient.  The reading process can often be
% speeded up considerably if these functions (especially token) are
% written in terms of the explicit LISP used.

symbolic procedure prin2x u;
  outl!* := u . outl!*;

symbolic procedure mkstrng u;
   %converts the uninterned id U into a string;
   %if strings are not constants, this should be replaced by
   %list('string,u);
   u;

symbolic procedure readch1;
   begin scalar x;
      if null terminalp()
        then progn(x := readch(),
                   x eq !$eol!$ and (curline!* := curline!*+1),
                   return x)
       else if crbuf1!*
        then begin x := car crbuf1!*; crbuf1!* := cdr crbuf1!* end
       else x := readch();
      crbuf!* := x . crbuf!*;
      return x
   end;

symbolic procedure token1;
   begin scalar x,y,z;
        x := crchar!*;
    a:  if seprp x then progn(x := readch1(), go to a)
         else if digit x then go to number
         else if liter x then go to letter
         else if x eq '!% then go to coment
         else if x eq '!! then go to escape
         else if x eq '!'
          then progn(crchar!* := readch1(),
                     nxtsym!* := mkquote rread(),
                     ttype!* := 4,
                     return nxtsym!*)
         else if x eq '!" then go to string;
        ttype!* := 3;
        if x eq !$eof!$ then prog2(crchar!* := '! ,filenderr());
        nxtsym!* := x;
    a1: if delcp x then crchar!*:= '!  else crchar!*:= readch1();
        go to c;
    escape: 
        begin scalar raise;
           raise := !*raise;
           !*raise := nil;
           y := x . y;
           x := readch1();
           !*raise := raise
        end;
    letter:
        ttype!* := 0;
    let1:
        y := x . y;
        if digit (x := readch1()) or liter x then go to let1
         else if x eq '!! then go to escape;
        nxtsym!* := intern compress reversip!* y;
    b:  crchar!* := x;
    c:  return nxtsym!*;
    number:     
        ttype!* := 2;
    num1:
        y := x . y;
        z := x;
        if digit (x := readch1()) 
           or x eq '!.
           or x eq 'e
           or z eq 'e
          then go to num1;
        nxtsym!* := compress reversip!* y;
        go to b;
    string:
        begin scalar raise;
           raise := !*raise;
           !*raise := nil;
       strinx:
           y := x . y;
           if null((x := readch1()) eq '!") then go to strinx;
           y := x . y;
           nxtsym!* := mkstrng compress reversip!* y;
           !*raise := raise
         end;
        ttype!* := 1;
        go to a1;
    coment:
        if null(readch1() eq !$eol!$) then go to coment;
        x := readch1();
        go to a
   end;

symbolic procedure token;
   %This provides a hook for a faster TOKEN;
   token1();

symbolic procedure filenderr;
   begin 
      eof!* := eof!*+1;
      if terminalp() then error1()
       else error(99,if ifl!*
                       then list("End-of-file read in file",car ifl!*)
                      else "End-of-file read")
   end;

symbolic procedure ptoken;
   begin scalar x;
        x := token();
        if x eq '!) and eqcar(outl!*,'! ) then outl!*:= cdr outl!*;
           %an explicit reference to OUTL!* used here;
        prin2x x;
        if null ((x eq '!() or (x eq '!))) then prin2x '! ;
        return x
   end;

symbolic procedure rread1;
   % Modified to use QUOTENEWNAM's for ids.
   begin scalar x,y;
        x := ptoken();
        if null (ttype!*=3) 
          then return if null idp x 
                         or null !*quotenewnam 
                         or null(y := get(x,'quotenewnam))
                        then x
                       else y
         else if x eq '!( then return rrdls()
         else if null (x eq '!+ or x eq '!-) then return x;
        y := ptoken();
        if null numberp y
          then progn(nxtsym!* := " ",
                     symerr("Syntax error: improper number",nil))
         else if x eq '!- then y := apply('minus,list y);
           %we need this construct for bootstrapping purposes;
        return y
   end;

symbolic procedure rrdls;
   begin scalar x,y,z;
    a:  x := rread1();
        if null (ttype!*=3) then go to b
         else if x eq '!) then return z
         else if null (x eq '!.) then go to b;
        x := rread1();
        y := ptoken();
        if null (ttype!*=3) or null (y eq '!))
          then progn(nxtsym!* := " ",symerr("Invalid S-expression",nil))
         else return nconc(z,x);
    b: z := nconc(z,list x);
       go to a
   end;

symbolic procedure rread;
   progn(prin2x " '",rread1());

symbolic procedure scan;
   begin scalar x,y;
        if null (cursym!* eq '!*semicol!*) then go to b;
    a:  nxtsym!* := token();
    b:  if null atom nxtsym!* then go to q1
         else if nxtsym!* eq 'else or cursym!* eq '!*semicol!*
         then outl!* := nil;
        prin2x nxtsym!*;
    c:  if null idp nxtsym!* then go to l
         else if (x:=get(nxtsym!*,'newnam)) and
                        (null (x=nxtsym!*)) then go to new
         else if nxtsym!* eq 'comment OR NXTSYM!* EQ '!% AND TTYPE!*=3
          THEN GO TO COMM
         ELSE IF NULL(TTYPE!* = 3) THEN GO TO L
         ELSE IF NXTSYM!* EQ !$eof!$ then return filenderr()
         else if nxtsym!* eq '!' then go to quote
         else if null (x:= get(nxtsym!*,'switch!*)) then go to l
         else if eqcar(cdr x,'!*semicol!*) then go to delim;
   sw1: nxtsym!* := token();
        if null(ttype!* = 3) then go to sw2
         else if nxtsym!* eq !$eof!$ then return filenderr()
         else if car x then go to sw3;
   sw2: cursym!*:=cadr x;
        if cursym!* eq '!*rpar!* then go to l2
         else return cursym!*;
   sw3: if null (y:= atsoc(nxtsym!*,car x)) then go to sw2;
        prin2x nxtsym!*;
        x := cdr y;
        go to sw1;
  comm: if delcp crchar!* then go to com1;
        crchar!* := readch();
        go to comm;
  com1: crchar!* := '! ;
        condterpri();
        go to a;
  delim:
        semic!*:=nxtsym!*;
        return (cursym!*:='!*semicol!*);
  new:  nxtsym!* := x;
        if stringp x then go to l
        else if atom x then go to c
        else go to l;
  quote:
        nxtsym!* := mkquote rread1();
        go to l;
  q1:   if null (car nxtsym!* eq 'string) then go to l;
        prin2x " ";
        prin2x cadr(nxtsym!* := mkquote cadr nxtsym!*);
  l:    cursym!*:=nxtsym!*;
  l1:   nxtsym!* := token();
        if nxtsym!* eq !$eof!$ and ttype!* = 3 then return filenderr();
  l2:   if numberp nxtsym!*
           or (atom nxtsym!* and null get(nxtsym!*,'switch!*))
          then prin2x " ";
        return cursym!*
   end;

endmodule;


module xread; % Routines for parsing REDUCE input.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*blockp);

global '(cursym!* nxtsym!*);

% The conversion of a REDUCE expression to LISP prefix form is carried
% out by the function XREAD.  This function initiates the scanning
% process, and then calls the auxiliary function XREAD1 to perform the
% actual parsing.  Both XREAD and XREAD1 are used by many functions
% whenever an expression must be read;

flag ('(end !*colon!* !*semicol!*),'delim);

symbolic procedure chknewnam u;
   % Check to see if U has a newnam, and return it else return U.
   begin scalar x;
      return if null(x := get(u,'newnam)) or x eq u then u
              else if idp x then chknewnam x
              else x
   end;

symbolic procedure mkvar(u,v); u;

symbolic procedure remcomma u;
   if eqcar(u,'!*comma!*) then cdr u else list u;

symbolic procedure xread1 u;
   begin scalar v,w,x,y,z,z1,z2;
        % v: expression being built
        % w: prefix operator stack
        % x: infix operator stack
        % y: infix value or stat property
        % z: current symbol
        % z1: next symbol
        % z2: temporary storage;
  a:    z := cursym!*;
  a1:   if null idp z then nil
         else if z eq '!*lpar!* then go to lparen
         else if z eq '!*rpar!* then go to rparen
         else if y := get(z,'infix) then go to infx
         % The next line now commented out was intended to allow a STAT
         % to be used as a label. However, it prevents the definition of
         % a diphthong whose first character is a colon.
%        else if nxtsym!* eq '!: then nil
         else if flagp(z,'delim) then go to delimit
         else if y := get(z,'stat) then go to stat;
  a2:   y := nil;
  a3:   w := z . w;
        if numberp z
           and idp (z1 := chknewnam nxtsym!*)
           and null flagp(z1,'delim)
           and null(get(z1,'switch!*) and null(z1 eq '!())
           and null get(z1,'infix)
         then progn(cursym!* := 'times, go to a);
           % allow for implicit * after a number.
  next: z := scan();
        go to a1;
  lparen:
        y := nil;
        if scan() eq '!*rpar!* then go to lp1    % no args
         else if flagpcar(w,'struct) then z := xread1 car w
         else z := xread1 'paren;
        if flagp(u,'struct) then progn(z := remcomma z, go to a3)
         else if null eqcar(z,'!*comma!*) then go to a3
         else if null w
           then (if u eq 'lambda then go to a3
                 else symerr("Improper delimiter",nil))
         else w := (car w . cdr z) . cdr w;
        go to next;
  lp1:  if w then w := list car w . cdr w;  %function of no args;
        go to next;
  rparen:
        if null u or u eq 'group or u eq 'proc
          then symerr("Too many right parentheses",nil)
         else go to end1;
  infx: if z eq '!*comma!* or null atom (z1 := scan())
                or numberp z1 then go to in1
         else if z1 eq '!*rpar!*%infix operator used as variable;
                or z1 eq '!*comma!*
                or flagp(z1,'delim)
          then go to in2
         else if z1 eq '!*lpar!*%infix operator in prefix position;
                    and null atom(z1 := xread 'paren)
                    and car z1 eq '!*comma!*
                    and (z := z . cdr z1)
          then go to a1;
  in1:  if w then go to unwind
         else if null(z := get(z,'unary))
          then symerr("Redundant operator",nil);
        v := '!*!*un!*!* . v;
        go to pr1;
  in2:  y := nil;
        w := z . w;
  in3:  z := z1;
        go to a1;
  unwind:
        z2 := mkvar(car w,z);
  un1:  w:= cdr w;
        if null w then go to un2
         else if numberp car w then symerr("Missing operator",nil);
        z2 := list(car w,z2);
        go to un1;
  un2:  v:= z2 . v;
  preced:
        if null x then if y=0 then go to end2 else nil
         else if y<caar x
           or (y=caar x
               and ((z eq cdar x and null flagp(z,'nary)
                                 and null flagp(z,'right))
                             or get(cdar x,'alt)))
          then go to pr2;
  pr1:  x:= (y . z) . x;
        if null(z eq '!*comma!*) then go to in3
         else if cdr x or null u or u memq '(lambda paren)
            or flagp(u,'struct)
          then go to next
         else go to end2;
  pr2:  %if cdar x eq 'setq then go to assign else;
        if cadr v eq '!*!*un!*!*
          then (if car v eq '!*!*un!*!* then go to pr1
                else z2 := list(cdar x,car v))
         else z2 := cdar x .
                     if eqcar(car v,cdar x) and flagp(cdar x,'nary)
                       then (cadr v . cdar v)
                      else list(cadr v,car v);
        x:= cdr x;
        v := z2 . cddr v;
        go to preced;
  stat: if null(flagp(z,'go)
           or null(u eq 'proc) and (flagp(y,'endstat)
                or (null delcp nxtsym!* and null (nxtsym!* eq '!,))))
          then go to a2;
        w := apply(y,nil) . w;
        y := nil;
        go to a;
  delimit:
        if z eq '!*colon!* and null(u eq 'for)
              and (null !*blockp or null w or null atom car w or cdr w)
           or flagp(z,'nodel)
              and (null u 
                   or u eq 'group and null z memq '(!*rsqb!* !*rcbkt!*))
          then symerr("Improper delimiter",nil)
         else if idp u and (u eq 'paren or flagp(u,'struct))
          then symerr("Too few right parentheses",nil);
  end1: if y then symerr("Improper delimiter",nil)
         else if null v and null w and null x then return nil;
        y := 0;
        go to unwind;
  end2: if null cdr v then return car v
         else symerr("Improper delimiter",nil)
   end;

%symbolic procedure getels u;
%   getel(car u . !*evlis cdr u);

%symbolic procedure !*evlis u;
%   mapcar(u,function eval);

flag ('(endstat retstat),'endstat);

flag ('(else until),'nodel);

flag ('(begin),'go);

symbolic procedure xread u;
   progn(scan(),xread1 u);

flag('(xread),'opfn);   %to make it an operator;

endmodule;


module lpri; % Functions for printing diagnostic and error messages.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*defn !*int);

global '(!*echo !*fort !*msg !*nat !*rlisp2 cursym!* erfg!* ofl!*
         outl!*);

symbolic procedure lpri u;
   begin
    a:  if null u then return nil;
        prin2 car u;
        prin2 " ";
        u := cdr u;
        go to a
   end;

symbolic procedure lpriw (u,v);
   begin scalar x;
        u := u . if v and atom v then list v else v;
        if ofl!* and (!*fort or not !*nat or !*defn) then go to c;
        terpri();
    a:  lpri u;
        terpri();
        if null x then go to b;
        wrs cdr x;
        return nil;
    b:  if null ofl!* then return nil;
    c:  x := ofl!*;
        wrs nil;
        go to a
   end;

symbolic procedure lprim u;
   !*msg and lpriw("***",u);

symbolic procedure lprie u;
   begin scalar x;
        if !*int then go to a;
        x:= !*defn;
        !*defn := nil;
    a:  erfg!* := t;
        lpriw ("*****",u);
        if null !*int then !*defn := x
   end;

symbolic procedure printty u;
   begin scalar ofl;
        if null !*fort and !*nat then print u;
        if null ofl!* then return nil;
        ofl := ofl!*;
        wrs nil;
        print u;
        wrs cdr ofl
   end;

symbolic procedure rederr u;
   begin lprie u; error1() end;

symbolic procedure symerr(u,v);
   begin scalar x;
        erfg!* := t;
        if numberp cursym!* or not(x := get(cursym!*,'prtch))
          then x := cursym!*;
        terpri();
        if !*echo then terpri();
        outl!*:=car outl!* . '!$!$!$ . cdr outl!*;
        comm1 t;
        mapcar(reversip!* outl!*,function prin2);
        terpri();
        outl!* := nil;
        if null v then rederr u
         else rederr(x . ("invalid" .
                     (if u then list("in",u,"statement") else nil)))
   end;

symbolic procedure typerr(u,v); rederr list(u,"invalid as",v);

endmodule;


module parser;  % Functions for parsing RLISP expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*backtrace !*mode);

global '(cursym!* letl!* nxtsym!*);

%With the exception of assignment statements, which are handled by
%XREAD, statements in REDUCE are introduced by a key-word, which
%initiates a reading process peculiar to that statement.  The key-word
%is recognized (in XREAD1) by the indicator STAT on its property list.
%The corresponding property is the name of the function (of no
%arguments) which carries out the reading sequence.

% ***** COMMENTS *****

symbolic procedure comm1 u;
   begin scalar bool;
        if u eq 'end then go to b;
  a:    if cursym!* eq '!*semicol!*
           or u eq 'end
                and cursym!* memq
                   '(end else then until !*rpar!* !*rsqb!*)
          then return nil
         else if u eq 'end and null bool
          then progn(lprim list("END-COMMENT NO LONGER SUPPORTED"),
                     bool := t);
  b:    scan();
        go to a
   end;


% ***** CONDITIONAL STATEMENT *****

symbolic procedure ifstat;
   begin scalar condx,condit;
    a:  condx := xread t;
        if not cursym!* eq 'then then symerr('if,t);
        condit := aconc!*(condit,list(condx,xread t));
        if not cursym!* eq 'else then nil
         else if scan() eq 'if then go to a
         else condit := aconc!*(condit,list(t,xread1 t));
        return ('cond . condit)
   end;

put('if,'stat,'ifstat);

flag ('(then else),'delim);


% ***** LAMBDA STATEMENT *****

symbolic procedure lamstat;
   begin scalar x,y;
        x:= xread 'lambda;
%       x := flagtype(if null x then nil else remcomma x,'scalar);
        if x then x := remcomma x;
        y := list('lambda,x,xread t);
%       remtype x;
        return y
   end;

put ('lambda,'stat,'lamstat);


% ***** GROUP STATEMENT *****

symbolic procedure mkprogn;
   %Expects a list of statements terminated by a >>;
   begin scalar lst;
    a:  lst := aconc!*(lst,xread 'group);
        if null(cursym!* eq '!*rsqb!*) then go to a;
        scan();
        return ('progn . lst)
   end;

put('!*lsqb!*,'stat,'mkprogn);

flag('(!*rsqb!*),'delim);

flag('(!*rsqb!*),'nodel);


% ***** END STATEMENT *****

symbolic procedure endstat;
  %This procedure can also be used for any key-words  which  take  no
  %arguments;
   begin scalar x; x := cursym!*; comm1 'end; return list x end;

put('end,'stat,'endstat);

put('endmodule,'stat,'endstat);

put('bye,'stat,'endstat);

put('quit,'stat,'endstat);

flag('(bye quit),'eval);

put('showtime,'stat,'endstat);

endmodule;


module block;   % Block statement and related operators.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*blockp);

global '(!*vars!* cursym!* nxtsym!*);

% ***** GO statement *****

symbolic procedure gostat;
   begin scalar var;
        var := if eq(scan(),'to) then scan() else cursym!*;
        scan();
        return list('go,var)
   end;

put('go,'stat,'gostat);

put('goto,'newnam,'go);


% ***** Declaration Statement *****

symbolic procedure decl u;
   begin scalar varlis,w;
    a:  if cursym!* eq '!*semicol!* then go to c
         else if not flagp!*!*(cursym!*,'type) then return varlis
         else if cursym!* eq 'dcl then go to dclr;
        w := cursym!*;
        if scan() eq 'procedure then return procstat1 w;
        varlis := append(varlis,pairvars(remcomma xread1 nil,nil,w));
    b:  if not cursym!* eq '!*semicol!* then symerr(nil,t)
         else if null u then return list('dcl,mkquote varlis);
                %top level declaration;
    c:  scan();
        go to a;
    dclr: varlis := append(varlis,dclstat1());
        go to b
   end;

flag ('(dcl real integer scalar),'type);

symbolic procedure dclstat; list('dcl,mkquote dclstat1());

symbolic procedure dclstat1;
   begin scalar x,y;
    a:  x := xread nil;
        if not cursym!* eq '!*colon!* then symerr('dcl,t);
        y := append(y,pairvars(remcomma x,nil,scan()));
        if scan() eq '!*semicol!* then return y
         else if not cursym!* eq '!*comma!* then symerr('dcl,t)
         else go to a
   end;

symbolic procedure dcl u;
   %U is a list of (id, mode) pairs, which are declared as global vars;
   begin scalar x;
      !*vars!* := append(u,!*vars!*);
      x := mapcar(u,function car);
      global x;
      flag(x,'share);
   a: if null u then return nil;
      set(caar u,get(cdar u,'initvalue));
      u := cdr u;
      go to a
   end;

put('integer,'initvalue,0);

put('dcl,'stat,'dclstat);

symbolic procedure decstat;
   %only called if a declaration occurs at the top level or not first
   %in a block;
   begin scalar x,y,z;
      if !*blockp then symerr('block,t);
      x := cursym!*;
      y := nxtsym!*;
      z := decl nil;
      if y neq 'procedure then rederr list(x,"invalid outside block");
      return z
   end;

put('integer,'stat,'decstat);

put('real,'stat,'decstat);

put('scalar,'stat,'decstat);


% ***** Block Statement *****

symbolic procedure blockstat;
   begin scalar hold,varlis,x,!*blockp;
        !*blockp := t;
        scan();
        if cursym!* memq '(nil !*rpar!*) then rederr "BEGIN invalid";
        varlis := decl t;
    a:  if cursym!* eq 'end and not nxtsym!* eq '!: then go to b;
        x := xread1 nil;
        if eqcar(x,'end) then go to c;
        not cursym!* eq 'end and scan();
        if x then hold := aconc!*(hold,x);
        go to a;
    b:  comm1 'end;
    c:  return mkblock(varlis,hold)
   end;

symbolic procedure mkblock(u,v); 'block . (u . v);

putd('block,'macro,
 '(lambda (u) (cons 'prog
                 (cons (mapcar (cadr u) (function car)) (cddr u)))));

symbolic procedure formblock(u,vars,mode);
   'prog . append(initprogvars cadr u,
              formprog1(cddr u,append(cadr u,vars),mode));

symbolic procedure initprogvars u;
   begin scalar x,y,z;
    a: if null u then return(reversip!* x . reversip!* y)
       else if z := get(cdar u,'initvalue)
        then y := mksetq(caar u,z) . y;
      x := caar u . x;
      u := cdr u;
      go to a
   end;

symbolic procedure formprog(u,vars,mode);
   'prog . cadr u . formprog1(cddr u,pairvars(cadr u,vars,mode),mode);

symbolic procedure formprog1(u,vars,mode);
   if null u then nil
    else if atom car u then car u . formprog1(cdr u,vars,mode)
    else if idp caar u and flagp(caar u,'modefn)
     then formc(cadar u,vars,caar u) . formprog1(cdr u,vars,mode)
    else formc(car u,vars,mode) . formprog1(cdr u,vars,mode);

put('block,'formfn,'formblock);

put('prog,'formfn,'formprog);

put('begin,'stat,'blockstat);


% ***** Return Statement *****

symbolic procedure retstat;
   if not !*blockp then symerr(nil,t)
    else list('return,
              if flagp!*!*(scan(),'delim) then nil else xread1 t);

put('return,'stat,'retstat);

endmodule;


module form;  % Performs a mode analysis of parsed forms.

% Author: Anthony C. Hearn.

% Modifications by: Jed Marti.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*!*a2sfn !*cref !*defn !*mode current!-modulus);

global '(!*argnochk !*composites !*force !*micro!-version !*vars!*);

!*!*a2sfn := 'aeval;

flag('(algebraic symbolic),'modefn);

symbolic procedure formcond(u,vars,mode);
   'cond . formcond1(cdr u,vars,mode);

symbolic procedure formcond1(u,vars,mode);
   if null u then nil
    else list(formbool(caar u,vars,mode),form1(cadar u,vars,mode))
       % FORMC here would add REVAL
              . formcond1(cdr u,vars,mode);

put('cond,'formfn,'formcond);

symbolic procedure formlamb(u,vars,mode);
   list('lambda,cadr u,form1(caddr u,pairvars(cadr u,vars,mode),mode));

put('lambda,'formfn,'formlamb);

symbolic procedure formprogn(u,vars,mode);
   'progn . formclis(cdr u,vars,mode);

put('progn,'formfn,'formprogn);

symbolic procedure expdrmacro u;
   %returns the macro form for U if expansion is permitted;
   begin scalar x;
      if null(x := getrmacro u) or flagp(u,'noexpand) then return nil
       else if null !*cref and (null !*defn or car x eq 'smacro)
          or flagp(u,'expand) or !*force
        then return x
       else return nil
   end;

symbolic procedure getrmacro u;
   %returns a Reduce macro definition for U, if one exists,
   %in GETD format;
   begin scalar x;
      return if not idp u then nil
       else if (x := getd u) and car x eq 'macro then x
       else if (x := get(u,'smacro)) then 'smacro . x
%       else if (x := get(u,'nmacro)) then 'nmacro . x;
       else nil
   end;

symbolic procedure applmacro(u,v,w); apply1(u,w . v);

%symbolic procedure applnmacro(u,v,w);
%   apply(u,if flagp(w,'nospread) then list v else v);

% symbolic procedure applsmacro(u,v,w);
%  %We could use an atom sublis here, eg SUBLA;
%  sublis(pair(cadr u,v),caddr u);

put('macro,'macrofn,'applmacro);

%put('nmacro,'macrofn,'applnmacro);

put('smacro,'macrofn,'applsmacro);

flag('(ed go quote),'noform);

symbolic procedure set!-global!-mode u;
   begin !*mode := u end;

symbolic procedure form1(u,vars,mode);
   begin scalar x,y;
      if atom u
        then return if not idp u then u
                     else if u eq 'ed then list u
                     else if flagp(u,'modefn) then set!-global!-mode u
                     else if x:= get(mode,'idfn)
                      then apply2(x,u,vars)
                     else u
       else if not atom car u 
        then if caar u eq 'lambda then return formlis(u,vars,mode)
              else typerr(car u,"operator")
       else if not idp car u then typerr(car u,"operator")
       else if get(car u, 'localfnname)
        then return form1(get(car u,'localfnname) . cdr u,vars,mode)
       else if flagp(car u,'noform) then return u
       else if arrayp car u
          and (mode eq 'symbolic or intexprlisp(cdr u,vars))
        then return list('getel,intargfn(u,vars,mode))
       else if flagp(car u,'modefn)
        then return convertmode(cadr u,vars,mode,car u)
       else if (x := get(car u,'formfn))
        then return macrochk(apply(x,list(u,vars,mode)),mode)
       else if get(car u,'stat) eq 'rlis
        then return macrochk(formrlis(u,vars,mode),mode)
%      else if (x := getd car u) and eqcar(x, 'macro) and
%              not(mode eq 'algebraic) then
%            return << x := apply(cdr x, list(u, vars, mode));
%                      formc(x, vars, mode) >>
        ;
      argnochk u;
      x := formlis(cdr u,vars,mode);
      y := if x=cdr u then u else car u . x;
      return if mode eq 'symbolic
              or get(car u,'stat)
              or cdr u and eqcar(cadr u,'quote)
                       and null !*micro!-version
              or intexprnp(y,vars) and null !*composites
                 and null current!-modulus
               then macrochk(y,mode)
              else if not(mode eq 'algebraic)
               then convertmode(y,vars,mode,'algebraic)
              else ('list . algid(car u,vars) . x)
   end;

symbolic procedure argnochk u;
   begin scalar x;
      if null !*argnochk then nil
       else if (x := argsofopr car u) and x neq length cdr u
        then rederr list(car u,"called with",
                         length cdr u,
                         if length cdr u=1 then "argument"
                          else "arguments",
                         "instead of",x)
   end;

symbolic procedure argsofopr u;
   % This function may be optimizable in various implementations.
   get(u,'number!-of!-args);

symbolic procedure intexprnp(u,vars);
   %determines if U is an integer expression;
    if atom u then if numberp u then fixp u
                   else if (u := atsoc(u,vars)) then cdr u eq 'integer
                   else nil
     else idp car u and flagp(car u,'intfn) and intexprlisp(cdr u,vars);

symbolic procedure intexprlisp(u,vars);
   null u or intexprnp(car u,vars) and intexprlisp(cdr u,vars);

flag('(difference minus plus times),'intfn);
   % EXPT is not included in this list, because a negative exponent can
   % cause problems (i.e., result can be rational);

symbolic procedure formlis(u,vars,mode);
   mapcar(u,function (lambda x; form1(x,vars,mode)));

symbolic procedure formclis(u,vars,mode);
   mapcar(u,function (lambda x; formc(x,vars,mode)));

symbolic procedure form u; form1(u,!*vars!*,!*mode);

symbolic procedure macrochk(u,mode);
   begin scalar y;
   %expands U if CAR U is a macro and expansion allowed;
      if atom u then return u
       else if (y := expdrmacro car u)
        and (mode eq 'symbolic or idp car u and flagp(car u,'opfn))
        then return apply(get(car y,'macrofn),list(cdr y,cdr u,car u))
       else return u
   end;

put('symbolic,'idfn,'symbid);

symbolic procedure symbid(u,vars); u;
%   if atsoc(u,vars) or fluidp u or globalp u or u memq '(nil t)
%       or flagp(u,'share) then u
%    else <<lprim list(u,"Non-Local Identifier");% u>>;

put('algebraic,'idfn,'algid);

symbolic procedure algid(u,vars);
   if atsoc(u,vars) or flagp(u,'share) then u else mkquote u;

put('integer,'idfn,'intid);

symbolic procedure intid(u,vars);
   begin scalar x,y;
      return if (x := atsoc(u,vars))
        then if cdr x eq 'integer then u
               else if y := get(cdr x,'integer)
                then apply2(y,u,vars)
               else if cdr x eq 'scalar then !*!*a2i(u,vars)
               else rederr list(cdr x,"not convertable to INTEGER")
      else !*!*a2i(mkquote u,vars)
   end;

symbolic procedure convertmode(exprn,vars,target,source);
   convertmode1(form1(exprn,vars,source),vars,target,source);

symbolic procedure convertmode1(exprn,vars,target,source);
   begin scalar x;
      if source eq 'real then source := 'algebraic;
      if target eq 'real then target := 'algebraic;
      if target eq source then return exprn
       else if idp exprn and (x := atsoc(exprn,vars))
          and not(cdr x memq '(integer scalar real))
          and not(cdr x eq source)
        then return convertmode(exprn,vars,target,cdr x)
       else if not (x := get(source,target))
        then typerr(source,target)
       else return apply2(x,exprn,vars)
   end;

put('algebraic,'symbolic,'!*!*a2s);

put('symbolic,'algebraic,'!*!*s2a);

symbolic procedure !*!*a2s(u,vars);
   % It would be nice if we could include the ATSOC(U,VARS) line,
   % since in many cases that would save recomputation. However,
   % in any sequential process, assignments or subsititution rules
   % can change the value of a variable, so we have to check its
   % value again.  More comprehensive analysis could certainly
   % optimize this.
   if u = '(quote nil) then nil
    else if null u or constantp u and null fixp u
      or intexprnp(u,vars) and null !*composites
                 and null current!-modulus
      or not atom u and idp car u
         and flagp(car u,'nochange) and not(car u eq 'getel)
%     or atsoc(u,vars)      % means it was already evaluated
     then u
    else list(!*!*a2sfn,u);

symbolic procedure !*!*s2a(u,vars); u;

symbolic procedure formc(u,vars,mode);
   %this needs to be generalized;
   if mode eq 'algebraic and intexprnp(u,vars) then u
    else convertmode(u,vars,'symbolic,mode);

symbolic procedure intargfn(u,vars,mode);
   % transforms array element U into expression with integer arguments.
   % Array name is treated as an algebraic variable;
   'list . form1(car u,vars,'algebraic) . 
       mapcar(cdr u,
              function (lambda x;
                        convertmode(x,vars,'integer,mode)));

put('algebraic,'integer,'!*!*a2i);

symbolic procedure !*!*a2i(u,vars);
   if intexprnp(u,vars) then u else list('ieval,u);

symbolic procedure ieval u; !*s2i reval u;

flag('(ieval),'opfn);   % To make it a symbolic operator.

flag('(ieval),'nochange);

put('symbolic,'integer,'!*!*s2i);

symbolic procedure !*!*s2i(u,vars);
   if fixp u then u else list('!*s2i,u);

symbolic procedure !*s2i u;
   if fixp u then u else typerr(u,"integer");

put('integer,'symbolic,'identity);

symbolic procedure identity(u,vars); u;

symbolic procedure formbool(u,vars,mode);
   if mode eq 'symbolic then form1(u,vars,mode)
    else if atom u then if not idp u or atsoc(u,vars) or u eq 't
           then u
          else formc!*(u,vars,mode)
    else if intexprlisp(cdr u,vars) and get(car u,'boolfn) then u
    else if idp car u and get(car u,'boolfn)
     then get(car u,'boolfn) . formclis(cdr u,vars,mode)
    else if idp car u and flagp(car u,'boolean)
        then car u .
          mapcar(cdr u,function (lambda x;
            if flagp(car u,'boolargs)
                      then formbool(x,vars,mode)
                     else formc!*(x,vars,mode)))
    else formc!*(u,vars,mode);

symbolic procedure formc!*(u,vars,mode);
   begin scalar !*!*a2sfn;
      !*!*a2sfn := 'reval;
      return formc(u,vars,mode)
   end;

% Functions with side effects must be handled carefully in this model,
% otherwise they are not always evaluated within blocks.

symbolic procedure formrederr(u,vars,mode);
   begin scalar x;
      x := formc!*(cadr u,vars,mode);
      return list('rederr,x)
   end;

put('rederr,'formfn,'formrederr);

symbolic procedure formreturn(u,vars,mode);
   begin scalar x;
      x := form1(cadr u,vars,mode);  % FORMC here would add REVAL
      if not(mode memq '(symbolic integer real))
         and eqcar(x,'setq)             % Should this be more general?
        then x := list(!*!*a2sfn,x);
      return list('return,x)
   end;

put('return,'formfn,'formreturn);

symbolic procedure formsetq(u,vars,mode);
   begin scalar target,x,y;
     u := cdr u;
     if eqcar(cadr u,'quote) then mode := 'symbolic;
      if idp car u
           and (y := atsoc(car u,vars)) and not(cdr y eq 'scalar)
        then target :=  'symbolic   % used to be CDR Y
      else target := 'symbolic;
      % Make target always SYMBOLIC so that algebraic expressions
      % are evaluated before being stored.
      x := convertmode(cadr u,vars,target,mode);
      return if not atom car u
        then if not idp caar u then typerr(car u,"assignment")
          else if arrayp caar u
           then list('setel,intargfn(car u,vars,mode),x)
          else if y := get(caar u,'setqfn) 
           then form1((y . append(cdar u,cdr u)),vars,mode)
%         else if y := get(caar u, 'access)
%          then list('m!-setf,
%                    list(caar u, form1(cadar u, vars, mode)),
%                    x)
          else list('setk,form1(car u,vars,'algebraic),x)
             % algebraic needed above, since SETK expects it.
    else if not idp car u then typerr(car u,"assignment")
    else if mode eq 'symbolic or y or flagp(car u,'share)
         or eqcar(x,'quote)
     then mksetq(car u,x)
    else list('setk,mkquote car u,x)
   end;

put('car,'setqfn,'rplaca);

put('cdr,'setqfn,'rplacd);

put('setq,'formfn,'formsetq);

symbolic procedure formfunc(u,vars,mode);
   if idp cadr u then if getrmacro cadr u
     then rederr list("Macro",cadr u,"Used as Function")
        else list('function,cadr u)
    else list('function,form1(cadr u,vars,mode));

put('function,'formfn,'formfunc);

% RLIS is a parser function that reads a list of arguments and returns
% this list as one argument.  It needs to be defined in this module for
% bootstrapping purposes since this definition only works with its form
% function.

symbolic procedure rlis;
   begin scalar x;
        x := cursym!*;
        return if flagp!*!*(scan(),'delim) then list(x,nil)
                else x . remcomma xread1 'lambda
   end;

symbolic procedure flagop u; begin flag(u,'flagop); rlistat u end;

symbolic procedure rlistat u;
   begin
    a:  if null u then return nil;
        put(car u,'stat,'rlis);
        u := cdr u;
        go to a
   end;

rlistat '(flagop);

symbolic procedure formrlis(u,vars,mode);
   if not flagp(car u,'flagop)
        then list(car u,'list . formlis(cdr u,vars,'algebraic))
    else if not idlistp cdr u 
     then typerr('!*comma!* . cdr u,"identifier list")
    else mkprog(nil,list('flag,mkquote cdr u,mkquote car u)
                             . get(car u,'simpfg));

symbolic procedure mkarg(u,vars);
   % Returns the "unevaled" form of U.
   if null u or constantp u then u
    else if atom u then if atsoc(u,vars) then u else mkquote u
    else if car u eq 'quote then mkquote u
    else 'list . mapcar(u,function (lambda x; mkarg(x,vars)));

endmodule;


module proc;   % Procedure statement.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*backtrace);

global '(!*argnochk !*comp !*lose cursym!* erfg!* fname!* ftypes!*);

fluid '(!*defn);

!*lose := t;

ftypes!* := '(expr fexpr macro);

symbolic procedure putc(name,type,body);
   %defines a non-standard function, such as an smacro. Returns NAME;
   begin
      if !*comp and flagp(type,'compile) then compd(name,type,body)
       else put(name,type,body);
      return name
   end;

% flag('(putc),'eval);

symbolic procedure formproc(u,vars,mode);
   begin scalar body,name,type,varlis,x,y;
        u := cdr u;
        name := car u;
        if cadr u then mode := cadr u;   % overwrite previous mode
        u := cddr u;
        type := car u;
        if flagp(name,'lose) and (!*lose or null !*defn)
          then return progn(lprim list(name,
                            "not defined (LOSE flag)"),
                        nil);
        varlis := cadr u;
        u := caddr u;
        x := if eqcar(u,'block) then cadr u else nil;
        y := pairxvars(varlis,x,vars,mode);
        if x then u := car u . rplaca!*(cdr u,cdr y);
        body:= form1(u,car y,mode);   % FORMC here would add REVAL
        if type eq 'expr then body := list('de,name,varlis,body)
         else if type eq 'fexpr then body := list('df,name,varlis,body)
         else if type eq 'macro then body := list('dm,name,varlis,body)
         else if type eq 'emb then return embfn(name,varlis,body)
         else body := list('putc,
                           mkquote name,
                           mkquote type,
                           mkquote list('lambda,varlis,body));
        if not(mode eq 'symbolic)
          then body := list('progn,
                         list('flag,mkquote list name,mkquote 'opfn),
                          body);
        if !*argnochk and type memq '(expr smacro)
          then body := list('progn,
                        list('put,mkquote name,
                                  mkquote 'number!-of!-args,
                                  length varlis),
                          body);
        if !*defn and type memq '(fexpr macro smacro) then eval body;
        return body
   end;

put('procedure,'formfn,'formproc);

symbolic procedure pairxvars(u,v,vars,mode);
   %Pairs procedure variables and their modes, taking into account
   %the convention which allows a top level prog to change the mode
   %of such a variable;
   begin scalar x,y;
   a: if null u then return append(reversip!* x,vars) . v
       else if (y := atsoc(car u,v))
        then <<v := delete(y,v);
               if not(cdr y eq 'scalar) then x := (car u . cdr y) . x
                else x := (car u . mode) . x>>
       else x := (car u . mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure procstat1 mode;
   begin scalar bool,u,type,x,y,z;
        bool := erfg!*;
        if fname!* then go to b
         else if cursym!* eq 'procedure then type := 'expr
         else progn(type := cursym!*,scan());
        if not cursym!* eq 'procedure then go to c;
        x := errorset('(xread (quote proc)),nil,!*backtrace);
        if errorp x then go to a
         else if atom (x := car x) then x := list x;   %no arguments;
        fname!* := car x;   %function name;
        if idp fname!* %AND NOT(TYPE MEMQ FTYPES!*);
          then if null fname!* or (z := gettype fname!*)
                        and not z memq '(procedure operator)
                then go to d
              else if not getd fname!* then flag(list fname!*,'fnc);
           %to prevent invalid use of function name in body;
        u := cdr x;
        y := u;
        x := car x . y;
    a:  z := errorset('(xread t),nil,!*backtrace);
        if not errorp z then z := car z;
        if null erfg!* then z:=list('procedure,car x,mode,type,y,z);
        remflag(list fname!*,'fnc);
        fname!*:=nil;
        if erfg!* then progn(z := nil,if not bool then error1());
        return z;
    b:  bool := t;
    c:  errorset('(symerr (quote procedure) t),nil,!*backtrace);
        go to a;
    d:  typerr(list(z,fname!*),"procedure");
        go to a
   end;

symbolic procedure procstat; procstat1 nil;

deflist ('((procedure procstat) (expr procstat) (fexpr procstat)
           (emb procstat) (macro procstat) (smacro procstat)),
        'stat);

% Next line refers to bootstrapping process.

if get('symbolic,'stat) eq 'procstat then remprop('symbolic,'stat);

deflist('((lisp symbolic)),'newnam);

endmodule;


module forstat;   % Definition of REDUCE FOR loops.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*blockp);

global '(cursym!* foractions!*);

comment the syntax of the FOR statement is as follows:

                 {step i3 until}
        {i := i1 {             } i2 }
        {        {      :      }    }
   for  {                           } <action> <expr>
        {        { in }             }
        { each i {    }  <list>     }
                 { on }

In all cases, the <expr> is evaluated algebraically within the scope of
the current value of i.  If <action> is DO, then nothing else happens.
In other cases, <action> is a binary operator that causes a result to be
built up and returned by FOR.  In each case, the loop is initialized to
a default value.  The test for the end condition is made before any
action is taken.

The effect of the definition here is to replace all for loops by
semantically equivalent blocks.  As a result, none of the mapping
functions are needed in REDUCE.

To declare a set of actions, one says;

foractions!* := '(do collect conc product sum);

remflag(foractions!*,'delim);    % For bootstrapping purposes.

% To associate a binary function with an action, one says:

deflist('((product times) (sum plus)),'bin);

% And to give these an initial value in a loop:

deflist('((product 1) (sum 0)),'initval);

% NB:  We need to reset for and let delims if an error occurs.  It's
% probably best to do this in the begin1 loop.

flag('(for),'nochange);

symbolic procedure forstat;
   begin scalar !*blockp;
      return if scan() eq 'all then forallstat()
              else if cursym!* eq 'each then foreachstat()
              else forloop()
   end;

put('for,'stat,'forstat);

symbolic procedure forloop;
   begin scalar action,bool,incr,var,x;
      flag('(step),'delim);
      x := errorset('(xread1 'for),t,t);
      remflag('(step),'delim);
      if errorp x then error1() else x := car x;
      if not eqcar(x,'setq) or not idp(var := cadr x)
        then symerr('for,t);
      x := caddr x;
      if cursym!* eq 'step
        then <<flag('(until),'delim);
               incr := xread t;
               remflag('(until),'delim);
               if not cursym!* eq 'until then symerr('for,t)>>
       else if cursym!* eq '!*colon!* then incr := 1
       else symerr('for,t);
      if flagp(car foractions!*,'delim) then bool := t % nested loop
       else flag(foractions!*,'delim);
      incr := list(x,incr,xread t);
      if null bool then remflag(foractions!*,'delim);
      if not((action := cursym!*) memq foractions!*)
        then symerr('for,t);
      return list('for,var,incr,action,xread t)
   end;

symbolic procedure formfor(u,vars,mode);
   begin scalar action,algp,body,endval,incr,initval,var,x;
        %ALGP is used to determine if the loop calculation must be
        %done algebraically or not;
      var := cadr u;
      incr := caddr u;
      incr := list(formc(car incr,vars,mode),
                   formc(cadr incr,vars,mode),
                   formc(caddr incr,vars,mode));
      if intexprnp(car incr,vars) and intexprnp(cadr incr,vars)
         and not atsoc(var,vars)
        then vars := (var . 'integer) . vars;
      action := cadddr u;
      body :=
         formc(car cddddr u,
               (var .
                if intexprlisp(caddr u,vars) then 'integer else mode)
                   . vars,mode);
      algp := algmodep car incr or algmodep cadr incr
                 or algmodep caddr incr;
      initval := car incr;
      endval := caddr incr;
      incr := cadr incr;
      x := if algp then list('list,''difference,endval,var)
            else list('difference,endval,var);
      if incr neq 1
        then x := if algp then list('list,''times,incr,x)
                   else list('times,incr,x);
      % We could consider simplifying X here (via reval).
      x := if algp then list('aminusp!:,x) else list('minusp,x);
      return forformat(action,body,initval,x,
                       list('plus2,incr),var,vars,mode)
   end;

put('for,'formfn,'formfor);

symbolic procedure algmodep u; eqcar(u,'aeval);

symbolic procedure aminusp!: u;
   begin scalar x;
      u := aeval u;
      x := u;
      if fixp x then return minusp x
       else if not eqcar(x,'!*sq)
        then msgpri(nil,reval u,"invalid in FOR statement",nil,t);
      x := cadr x;
      if fixp car x and fixp cdr x then return minusp car x
       else if not cdr x = 1
             or not (atom(x := car x) or atom car x)
         % Should be DOMAINP, but SMACROs not yet defined.
        then msgpri(nil,reval u,"invalid in FOR statement",nil,t)
       else return apply('!:minusp,list x)
   end;

symbolic procedure foreachstat;
   begin scalar w,x,y,z;
        if not idp(x := scan()) or not (y := scan()) memq '(in on)
          then symerr("FOR EACH",t)
         else if flagp(car foractions!*,'delim) then w := t
         else flag(foractions!*,'delim);
        z := xread t;
        if null w then remflag(foractions!*,'delim);
        w := cursym!*;
        if not w memq foractions!* then symerr("FOR EACH",t);
        return list('foreach,x,y,z,w,xread t)
   end;

put('foreach,'stat,'foreachstat);

symbolic procedure formforeach(u,vars,mode);
   begin scalar action,body,lst,mod,var;
        var := cadr u; u := cddr u;
        mod := car u; u := cdr u;
        lst := formc(car u,vars,mode); u := cdr u;
        if not(mode eq 'symbolic) then lst := list('getrlist,lst);
        action := car u; u := cdr u;
        body := formc(car u,(var . mode) . vars,mode);
        if mod eq 'in
          then body := list(list('lambda,list var,body),list('car,var))
         else if not(mode eq 'symbolic) then typerr(mod,'action);
        return forformat(action,body,lst,
                         list('null,var),list 'cdr,var,vars,mode)
   end;

put('foreach,'formfn,'formforeach);

symbolic procedure forformat(action,body,initval,
                             testexp,updform,var,vars,mode);
   begin scalar result;
      result := gensym();
      return
         sublis(list('body2 .
                if mode eq 'symbolic or intexprnp(body,vars)
                  then list(get(action,'bin),body,result)
                 else list('aeval,list('list,mkquote get(action,'bin),
                            body,result)),
               'body3 .
                   if mode eq 'symbolic then body
                      else list('getrlist,body),
               'body . body,
               'initval . initval,
               'nillist . if mode eq 'symbolic then nil else ''(list),
               'result . result,
               'initresult . get(action,'initval),
               'resultlist . if mode eq 'symbolic then result
                              else list('cons,''list,result),
               'testexp . testexp,
               'updfn . car updform,
               'updval . cdr updform,
               'var . var),
          if action eq 'do
            then '(prog (var)
                  (setq var initval)
              lab (cond (testexp (return nil)))
                  body
                  (setq var (updfn var . updval))
                  (go lab))
           else if action eq 'collect
            then '(prog (var result endptr)
                  (setq var initval)
                  (cond (testexp (return nillist)))
                  (setq result (setq endptr (cons body nil)))
                looplabel
                  (setq var (updfn var . updval))
                  (cond (testexp (return resultlist)))
                  (rplacd endptr (cons body nil))
                  (setq endptr (cdr endptr))
                  (go looplabel))
           else if action eq 'conc
            then '(prog (var result endptr)
                  (setq var initval)
               startover
                  (cond (testexp (return nillist)))
                  (setq result body)
                  (setq endptr (lastpair resultlist))
                  (setq var (updfn var . updval))
                  (cond ((atom endptr) (go startover)))
                looplabel
                  (cond (testexp (return result)))
                  (rplacd endptr body3)
                  (setq endptr (lastpair endptr))
                  (setq var (updfn var . updval))
                  (go looplabel))
           else '(prog (var result)
                 (setq var initval)
                 (setq result initresult)
              lab1
                 (cond (testexp (return result)))
                 (setq result body2)
                 (setq var (updfn var . updval))
                 (go lab1)))
   end;

symbolic procedure lastpair u;
   % Return the last pair of the list u.
   if atom u or atom cdr u then u else lastpair cdr u;

put('join,'newnam,'conc);   % alternative for CONC

endmodule;


module loops;  % Looping forms other than the FOR statement.
                
% Author: Anthony C. Hearn

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*blockp);

global '(cursym!*);


% ***** REPEAT STATEMENT *****

symbolic procedure repeatstat;
  begin scalar body,!*blockp;
        flag('(until),'delim);
        body:= xread t;
        remflag('(until),'delim);
        if not cursym!* eq 'until then symerr('repeat,t);
        return list('repeat,body,xread t);
   end;

symbolic macro procedure repeat u;
   begin scalar body,bool,lab;
        body := cadr u; bool := caddr u;
        lab := gensym();
        return mkprog(nil,list(lab,body,
                list('cond,list(list('not,bool),list('go,lab)))))
   end;

put('repeat,'stat,'repeatstat);

flag('(repeat),'nochange);

symbolic procedure formrepeat(u,vars,mode);
   list('repeat,formc(cadr u,vars,mode),formbool(caddr u,vars,mode));

put('repeat,'formfn,'formrepeat);


% ***** WHILE STATEMENT *****

symbolic procedure whilstat;
   begin scalar bool,!*blockp;
        flag('(do),'delim);
        bool := xread t;
        remflag('(do),'delim);
        if not cursym!* eq 'do then symerr('while,t);
        return list('while,bool,xread t)
   end;

symbolic macro procedure while u;
   begin scalar body,bool,lab;
        bool := cadr u; body := caddr u;
        lab := gensym();
        return mkprog(nil,list(lab,list('cond,list(list('not,bool),
                list('return,nil))),body,list('go,lab)))
   end;

put('while,'stat,'whilstat);

flag('(while),'nochange);

symbolic procedure formwhile(u,vars,mode);
   list('while,formbool(cadr u,vars,mode),formc(caddr u,vars,mode));

put('while,'formfn,'formwhile);

endmodule;


module write;  % Miscellaneous statement definitions.
                
% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% ***** DEFINE STATEMENT *****

remprop('define,'stat);

symbolic procedure define u;
   for each x in u do
      if not eqcar(x,'equal) or not idp cadr x
        then typerr(x,"DEFINE declaration")
       else put(cadr x,'newnam,caddr x);

put('define,'stat,'rlis);

flag('(define),'eval);

% ***** WRITE STATEMENT *****

symbolic procedure formwrite(u,vars,mode);
   begin scalar bool1,bool2,x,z;
      u := cdr u;
      bool1 := mode eq 'symbolic;
      while u do 
        <<x := formc(car u,vars,mode);
          z := (if bool1 then list('prin2,x) 
                      else list('writepri,mkarg1(x,vars),
          if not cdr u then if not bool2 then ''only else ''last
           else if not bool2 then ''first else nil)) .
                             z;
          bool2 := t;
          u := cdr u>>;
        return mkprog(nil,reversip!* z)
   end;

symbolic procedure writepri(u,v);
   begin scalar x; x := assgneval u; return varpri(car x,cdr x,v) end;

symbolic procedure mkarg1(u,vars);
   % Returns the "unevaled" form of U for the WRITE command.
   if null u or constantp u then u
    else if atom u then if atsoc(u,vars) 
     then list('mkquote,u) else mkquote u
    else if car u eq 'quote then mkquote u
    else if car u eq 'setq 
     then list('list,''setq,mkquote cadr u,mkarg1(caddr u,vars))
    else 'list . mapcar(u,function (lambda x; mkarg1(x,vars)));

put('write,'stat,'rlis);

put('write,'formfn,'formwrite);

endmodule;


module smacro;  % Support for SMACRO expansion.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

symbolic procedure applsmacro(u,vals,name);
   % U is smacro body of form (lambda <varlist> <body>), VALS is
   % argument list, NAME is name of smacro.
   begin scalar body,remvars,varlist,w;
      varlist := cadr u;
      body := caddr u;
      if length varlist neq length vals 
        then rederr list("Argument mismatch for SMACRO",name);
      if no!-side!-effect!-listp vals or one!-entry!-listp(varlist,body)
        then return subla!-q(pair(varlist,vals),body)
       else if length varlist>1
        then <<w := for each x in varlist collect (x . gensym());
               body := subla!-q(w,body);
               varlist := for each x in w collect cdr x>>;
      for each x in vals do
         <<if no!-side!-effectp x or one!-entryp(car varlist,body)
             then body := subla!-q(list(car varlist . x),body)
            else remvars := aconc(remvars,car varlist . x);
           varlist := cdr varlist>>;
      if null remvars then return body
       else <<w := list('lambda,
                         for each x in remvars collect car x,
                         body) .
                    for each x in remvars collect cdr x;
%             IF NOT EQCAR(CADR W,'SETQ)
%               THEN <<PRIN2 "*** SMACRO: "; PRINT CDR W>>;
              return w>>
   end;

symbolic procedure no!-side!-effectp u;
   if atom u then numberp u or idp u and not(fluidp u or globalp u)
    else if car u eq 'quote then t
    else if flagp!*!*(car u,'nosideeffects)
     then no!-side!-effect!-listp u
    else nil;

symbolic procedure no!-side!-effect!-listp u;
   null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u;

flag('(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
       cddar cdddr cons),'nosideeffects);

symbolic procedure one!-entryp(u,v);
   % determines if id U occurs less than twice in V.
   if atom v then t
    else if smemq(u,car v)
     then if smemq(u,cdr v) then nil else one!-entryp(u,car v)
    else one!-entryp(u,cdr v);

symbolic procedure one!-entry!-listp(u,v);
   null u or one!-entryp(car u,v) and one!-entry!-listp(cdr u,v);

symbolic procedure subla!-q(u,v);
   begin scalar x;
        if null u or null v then return v
         else if atom v
                 then return if x:= atsoc(v,u) then cdr x else v
         else if car v eq 'quote then return v
         else return(subla!-q(u,car v) . subla!-q(u,cdr v))
   end;

endmodule;


module infix; % Functions for introducing new infix operators.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*mode);

global '(preclis!*);

symbolic procedure infix x;
   begin scalar y;
    a: if null x then go to b;
      y := car x;
      if !*mode eq 'algebraic then mkop y;
      if not(y member preclis!*) then preclis!* := y . preclis!*;
      x := cdr x;
      go to a;
    b: mkprec()
   end;

symbolic procedure precedence u;
   begin scalar x,y,z;
      preclis!* := delete(car u,preclis!*);
      y := cadr u;
      x := preclis!*;
   a: if null x then rederr list (y,"not found")
       else if y eq car x
        then <<preclis!* :=
                  nconc!*(reversip!* z,car x . (car u . cdr x));
               mkprec();
               return nil>>;
      z := car x . z;
      x := cdr x;
      go to a
   end;

deflist('((infix rlis) (precedence rlis)),'stat);

flag('(infix precedence),'eval);

endmodule;


module where;  % Support for a where construct.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

symbolic procedure formwhere(u,vars,mode);
   begin scalar expn,equivs,y,z;
     expn := cadr u;
     equivs := caddr u;
     if eqcar(equivs,'!*comma!*) then equivs := cdr equivs
      else equivs := list equivs;
     for each x in equivs do
        if not atom x and car x memq '(equal setq)
          then <<y := caddr x . y; z := cadr x . z>>
         else rederr list(x,"invalid in WHERE statement");
     return formc(list('lambda,reversip z,expn) . reversip y,
                  vars,mode)
   end;

put('where,'formfn,'formwhere);

% infix where;   % We do this explicitly to avoid changing preclis*.

deflist('((where 1)),'infix);

put('where,'op,'((1 1)));

endmodule;


module list; % Define a list as a list of expressions in curly brackets.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

global '(cursym!* orig!* posn!*);

% Add to system table.

put('list,'tag,'list);

put('list,'rtypefn,'(lambda (x) 'list));

% Parsing interface.

symbolic procedure xreadlist;
   % expects a list of expressions enclosed by {, }.
   % also allows expressions separated by ; --- treats these as progn.
   begin scalar cursym,delim,lst;
        if scan() eq '!*rcbkt!* then <<scan(); return list 'list>>;
    a:  lst := aconc(lst,xread1 'group);
        cursym := cursym!*;
        scan();
        if cursym eq '!*rcbkt!*
          then return if delim eq '!*semicol!* then 'progn . lst
                       else 'list . lst
         else if null delim then delim := cursym
         else if not(delim eq cursym)
          then symerr("syntax error: mixed , and ; in list",nil);
        go to a
   end;

put('!*lcbkt!*,'stat,'xreadlist);

newtok '((!{) !*lcbkt!*);

newtok '((!}) !*rcbkt!*);

flag('(!*rcbkt!*),'delim);

flag('(!*rcbkt!*),'nodel);

% Evaluation interface.

put('list,'evfn,'listeval);

symbolic procedure getrlist u;
   if eqcar(u,'list) then cdr u
    else typerr(if eqcar(u,'!*sq) then prepsq cadr u else u,"list");

symbolic procedure listeval(u,v);
   if atom u then listeval(get(u,'rvalue),v)
    else car u . for each j in cdr u collect reval1(j,v);

% Length interface.

put('list,'lengthfn,'(lambda (x) (length (cdr x))));


% Printing interface.

put('list,'prifn,'listpri);

symbolic procedure listpri l;
   % This definition is basically that of INPRINT, except that it
   % decides when to split at the comma by looking at the size of
   % the argument.
   begin scalar orig,split,u;
      u := l;
      l := cdr l;
      prin2!* get('!*lcbkt!*,'prtch);
         % Do it this way so table can change.
      orig := orig!*;
      orig!* := if posn!*<18 then posn!* else orig!*+3;
      if null l then go to b;
      split := treesizep(l,40);   % 40 is arbitrary choice.
   a: maprint(negnumberchk car l,0);
      l := cdr l;
      if null l then go to b;
      oprin '!*comma!*;
      if split then terpri!* t;
      go to a;
   b: prin2!* get('!*rcbkt!*,'prtch);
%     terpri!* nil;
      orig!* := orig;
      return u
   end;

symbolic procedure treesizep(u,n);
   % true if u has recursively more pairs than n.
   treesizep1(u,n)=0;

symbolic procedure treesizep1(u,n);
   if atom u then n-1
    else if (n := treesizep1(car u,n))>0 then treesizep1(cdr u,n)
    else 0;

% Definitions of operations on lists

symbolic procedure rfirst u;
   <<argnochk ('first . u);
     if null(getrtype(u := reval car u) eq 'list)
       then typerr(u,"list")
      else if null cdr u then parterr(u,1)
      else cadr u>>;

put('first,'psopfn,'rfirst);

symbolic procedure parterr(u,v);
   msgpri("Expression",u,"does not have part",v,t);

symbolic procedure rsecond u;
   <<argnochk ('second . u);
     if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list")
      else if null cdr u or null cddr u then parterr(u,2)
      else caddr u>>;

put('second,'psopfn,'rsecond);

symbolic procedure rthird u;
   <<argnochk ('third . u);
     if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list")
      else if null cdr u or null cddr u or null cdddr u
       then parterr(u,3)
      else cadddr u>>;

put('third,'psopfn,'rthird);

symbolic procedure rrest u;
   <<argnochk ('rest . u);
     if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list")
      else if null cdr u then typerr(u,"non-empty list")
      else 'list . cddr u>>;

put('rest,'psopfn,'rrest);

symbolic procedure rappend u;
   begin scalar x,y;
      argnochk ('append . u);
      if null(getrtype(x := reval car u) eq 'list)
        then typerr(x,"list")
      else if null(getrtype(y := reval cadr u) eq 'list)
       then typerr(y,"list")
      else return 'list .append(cdr x,cdr y)
   end;

put('append,'psopfn,'rappend);

symbolic procedure rcons u;
   begin scalar x,y;
      argnochk ('cons . u);
      if (y := getrtype(x := reval cadr u)) eq 'vector
        then return prepsq simpdot u
       else if not(y eq 'list) then typerr(x,"list")
       else return 'list . reval car u . cdr x
   end;

put('cons,'psopfn,'rcons);

symbolic procedure rreverse u;
   <<argnochk ('reverse . u);
     if null(getrtype(u := reval car u) eq 'list) then typerr(u,"list")
      else 'list . reverse cdr u>>;

put('reverse,'psopfn,'rreverse);

endmodule;


module array; % Array statement.

% Author: Anthony C. Hearn.
% Modifications by: Nancy Kirkwood.

% These definitions are very careful about bounds checking. Appropriate
% optimizations in a given system might really speed things up.

global '(erfg!*);

symbolic procedure getel u;
   % Returns the value of the array element U.
   getel1(get(car u,'rvalue),cdr u,get(car u,'dimension));

symbolic procedure getel1(u,v,dims);
   if length v neq length dims
     then rederr "Incorrect array reference"
    else if null v then u
    else if car v geq car dims then rederr "Array out of bounds"
    else getel1(getv(u,car v),cdr v,cdr dims);

symbolic procedure setel(u,v);
   % Sets array element U to V and returns V.
   setel1(get(car u,'rvalue),cdr u,v,get(car u,'dimension));

symbolic procedure setel1(u,v,w,dims);
   if length v neq length dims then rederr "Incorrect array reference"
     else if car v geq car dims then rederr "Array out of bounds"
     else if null cdr v then putv(u,car v,w)
     else setel1(getv(u,car v),cdr v,w,cdr dims);

symbolic procedure dimension u; get(u,'dimension);


comment further support for REDUCE arrays;

symbolic procedure typechk(u,v);
   begin scalar x;
      if (x := gettype u) eq v or x eq 'parameter
        then lprim list(v,u,"REDEFINED")
       else if x then typerr(list(x,u),v)
   end;

symbolic procedure arrayfn(u,v);
   % U is the defining mode, V a list of lists, assumed syntactically
   % correct. ARRAYFN declares each element as an array unless a
   % semantic mismatch occurs.
   begin scalar y;
      for each x in v do
         <<typechk(car x,'array);
           y := add1lis for each z in cdr x collect eval z;
           if null erfg!*
             then <<put(car x,'rtype,'array);
                    put(car x,'rvalue,mkarray(y,u));
                    put(car x,'dimension,y)>>>>
   end;

symbolic procedure add1lis u;
   if null u then nil else (car u+1) . add1lis cdr u;

symbolic procedure mkarray(u,v);
   %U is a list of positive integers representing array bounds, V
   %the defining mode. Value is an array structure;
   if null u then if v eq 'symbolic then nil else 0
    else begin integer n; scalar x;
      n := car u-1;
      x := mkvect n;
      for i:=0:n do putv(x,i,mkarray(cdr u,v));
      return x
   end;

rlistat '(array);

flag ('(array arrayfn),'eval);

symbolic procedure formarray(u,vars,mode);
   begin scalar x;
      x := cdr u;
      while x do <<if atom x then typerr(x,"Array List")
                  else if atom car x or not idp caar x
                         or not listp cdar x
                  then typerr(car x,"Array declaration");
                   x := cdr x>>;
      u := for each z in cdr u collect intargfn(z,vars,mode);
      %ARRAY arguments must be returned as quoted structures;
      return list('arrayfn,mkquote mode,'list . u)
   end;

symbolic procedure listp u;
   % Returns T if U is a top level list.
   null u or not atom u and listp cdr u;

put('array,'formfn,'formarray);

put('array,'rtypefn,'arraychk);

symbolic procedure arraychk u;
   % If arraychk receives NIL, it means that array name is being used
   % as an identifier. We no longer permit this.
   if null u then 'array else nil;
%  nil;

put('array,'evfn,'arrayeval);

symbolic procedure arrayeval(u,v);
   % Eventually we'll support this.
   rederr "Array arithmetic not defined";

put('array,'lengthfn,'arraylength);

symbolic procedure arraylength u; 'list . get(u,'dimension);

endmodule;


module switch;  % Support for switches and ON and OFF statements.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

global '(!*switchcheck switchlist!*);

% No references to RPLAC-based functions in this module.

symbolic procedure on u; onoff(u,t);

symbolic procedure off u; onoff(u,nil);

symbolic procedure onoff(u,bool);
   for each j in u do
      begin scalar x,y;
         if not idp j then typerr(j,"switch")
          else if not flagp(j,'switch)
           then if !*switchcheck
                  then rederr list(j,"not defined as switch")
                 else lpriw("*****",list(j,"not defined as switch"));
         x := intern compress append(explode '!*,explode j);
         if !*switchcheck and eval x eq bool then return nil
          else if y := atsoc(bool,get(j,'simpfg))
           then eval mkprog(nil,cdr y);
          set(x,bool)
      end;

symbolic procedure switch u;
   % Declare list u as switches.
   for each x in u do
      begin scalar y;
         if not idp x then typerr(x,"switch");
         if not u memq switchlist!*
           then switchlist!* := x . switchlist!*;
         flag(list x,'switch);
         y := intern compress append(explode '!*,explode x);
         if not fluidp y and not globalp y then fluid list y
      end;

deflist('((switch rlis)),'stat);   % we use deflist since it's flagged
                                   % eval
rlistat '(off on);

flag ('(off on),'ignore);

% Symbolic mode switches:

switch backtrace,comp,defn,demo,echo,errcont,int,msg,output,pret,
       quotenewnam,raise,time;    % switchcheck.

% The following are compiler switches that may not be supported in all
% versions:

switch pgwd,plap,pwrds;

% flag('(switch),'eval);

endmodule;


module io; % Reduce functions for handling input and output of files.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*backtrace !*int semic!*);

global '(!*echo contl!* curline!* ifl!* ipl!* linelist!* ofl!* opl!*
         techo!*);

symbolic procedure file!-transform(u,v);
   % Performs a transformation on the file u.  V is name of function
   % used for the transformation;
   begin scalar echo,ichan,oldichan,val;
      echo := !*echo;
      !*echo := nil;
      ichan := open(u,'input);
      oldichan := rds ichan;
      val := errorset(list v,t,!*backtrace);
      !*echo := echo;
      close ichan;
      rds oldichan;
      if not errorp val then return car val
   end;

symbolic procedure infile u;
   % loads the single file u into REDUCE without echoing;
   begin scalar !*int;
   return file!-transform(u,function begin1)
   end;

symbolic procedure in u;
   begin scalar chan,echo,echop,type;
    echop := semic!* eq '!;;   %record echo character from input;
    echo := !*echo;   %save current echo status;
    if null ifl!* then techo!* := !*echo;   %terminal echo status;
    for each fl in u do
      <<if fl eq 't then fl := nil;
        if null fl then <<!*echo := techo!*; rds nil; ifl!* := nil>>
         else <<chan := open(fl := mkfil fl,'input);
                rds chan;
%               if assoc(fl,linelist!*) then nil;
                curline!* := 1;
                ifl!* := list(fl,chan,1)>>;
        ipl!* := ifl!* . ipl!*;  %add to input file stack;
        !*echo := echop;
        type := filetype fl;
        if type and (type := get(type,'action)) then eval list type
         else begin1();
        if chan then close chan;
        if fl eq caar ipl!* then ipl!* := cdr ipl!*
         else errach list("FILE STACK CONFUSION",fl,ipl!*)>>;
    !*echo := echo;   %restore echo status;
    if ipl!* and null contl!* then ifl!* := car ipl!*
     else ifl!* := nil;
    if ifl!* then <<rds cadr ifl!*; curline!* := caddr ifl!*>>
     else rds nil
   end;

symbolic procedure out u;
   %U is a list of one file;
   begin integer n; scalar chan,fl,x;
        n := linelength nil;
        if null u then return nil
         else if car u eq 't then return <<wrs(ofl!* := nil); nil>>;
        fl := mkfil car u;
        if not (x := assoc(fl,opl!*))
          then <<chan := open(fl,'output);
                 if chan
                   then <<ofl!*:= fl . chan; opl!*:= ofl!* . opl!*>>>>
         else ofl!* := x;
        wrs cdr ofl!*;
        linelength n
   end;

symbolic procedure shut u;
   %U is a list of names of files to be shut;
   begin scalar fl1;
      for each fl in u do
       <<if fl1 := assoc((fl := mkfil fl),opl!*) 
           then <<opl!* := delete(fl1,opl!*);
                  if fl1=ofl!* then <<ofl!* := nil; wrs nil>>;
                  close cdr fl1>>
         else if not (fl1 := assoc(fl,ipl!*))
          then rederr list(fl,"not open")
         else if fl1 neq ifl!*
          then <<close cadr fl1; ipl!* := delete(fl1,ipl!*)>>
         else rederr list("Cannot shut current input file",car fl1)>>
   end;

deflist ('((in rlis) (out rlis) (shut rlis)),'stat);

flag ('(in out shut),'eval);

flag ('(in out shut),'ignore);

endmodule;


module inter; % Functions for interactive support.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*int);

global '(!$eof!$
         !*echo
         !*lessspace
         cloc!*
         contl!*
         curline!*
         edit!*
         eof!*
         erfg!*
         flg!*
         ifl!*
         ipl!*
         key!*
         ofl!*
         opl!*
         techo!*);

symbolic procedure pause;
   %Must appear at the top-most level;
   if null !*int then nil
    else if key!* eq 'pause then pause1 nil
    else %typerr('pause,"lower level command");
         pause1 nil;   %Allow at lower level for now;

symbolic procedure pause1 bool;
   begin
      if bool then
        if getd 'edit1 and erfg!* and cloc!* and yesp "Edit?"
          then return <<contl!* := nil;
           if ofl!* then <<lprim list(car ofl!*,'shut);
                           close cdr ofl!*;
                           opl!* := delete(ofl!*,opl!*);
                           ofl!* := nil>>;
           edit1(cloc!*,nil)>>
         else if flg!* then return (edit!* := nil);
      if null ifl!* or yesp "Cont?" then return nil;
      ifl!* := list(car ifl!*,cadr ifl!*,curline!*);
      contl!* := ifl!* . !*echo . contl!*;
      rds (ifl!* := nil);
      !*echo := techo!*
   end;

symbolic procedure yesp u;
   begin scalar bool,ifl,ofl,x,y,z;
        if ifl!*
          then <<ifl := ifl!* := list(car ifl!*,cadr ifl!*,curline!*);
                 rds nil>>;
        if ofl!* then <<ofl:= ofl!*; wrs nil>>;
        if null !*lessspace then terpri();
        if atom u then prin2 u else lpri u;
        prin2t " (Y or N)";
        if null !*lessspace then terpri();
        z := setpchar '!?;
    a:  x := read();
        % Assume an end-of-file is the same as "yes".
        if (y := x eq 'y or x eq !$eof!$) or x eq 'n then go to b;
        if null bool then prin2t "TYPE Y OR N";
        bool := t;
        go to a;
    b:  setpchar z;
        if ofl then wrs cdr ofl;
        if ifl then rds cadr ifl;
        cursym!* := '!*semicol!*;
        return y
   end;

symbolic procedure cont;
   begin scalar fl,techo;
        if ifl!* then return nil   %CONT only active from terminal;
         else if null contl!* then rederr "No file open";
        fl := car contl!*;
        techo := cadr contl!*;
        contl!* := cddr contl!*;
        if car fl=caar ipl!* and cadr fl=cadar ipl!*
          then <<ifl!* := fl;
                 if fl then <<rds cadr fl; curline!* := caddr fl>>
                  else rds nil;
                 !*echo := techo>>
         else <<eof!* := 1; lprim list(fl,"not open"); error1()>>
   end;

deflist ('((cont endstat) (pause endstat) (retry endstat)),'stat);

flag ('(cont),'ignore);

endmodule;


end;

Added r33/rsltnt.red version [36bcb268c1].











































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
module resultant;

% Author: Eberhard Schruefer.

%**********************************************************************
%                                                                     *
% The resultant function defined here has the following properties:   *
%                                                                     *
%                           degr(p1,x)*degr(p2,x)                     *
%  resultant(p1,p2,x) = (-1)                     *resultant(p2,p1,x)  *
%                                                                     *
%                         degr(p2,x)                                  *
%  resultant(p1,p2,x) = p1             if p1 free of x                *
%                                                                     *
%  resultant(p1,p2,x) = 1  if p1 free of x and p2 free of x           *
%                                                                     *
%**********************************************************************

%exports resultant;

%imports reorder,setkorder,degr,addf,negf,multf,multpf;

fluid '(!*exp kord!*);

symbolic procedure resultant(u,v,w);
   %u and v are standard forms. Result is resultant of u and v
   %w.r.t. kernel w. Method is Bezout's determinant using exterior
   %multiplication for its calculation.
   begin scalar ap,ep,uh,ut,vh,vt;
         integer n,nm;
     if domainp u and domainp v then return 1;
     kord!* := w . kord!*;
     if null domainp u and null(mvar u eq w) then u := reorder u;
     if null domainp v and null(mvar v eq w) then v := reorder v;
     if domainp u or null(mvar u eq w)
        then <<setkorder cdr kord!*;
               return if not domainp v and mvar v eq w
                        then exptf(u,ldeg v)
                       else 1>>
      else if domainp v or null(mvar v eq w)
        then <<setkorder cdr kord!*;
               return if mvar u eq w then exptf(v,ldeg u)
                       else 1>>;
      n := ldeg u - ldeg v;
      ep := 1;
      if n<0 then
          <<for j := (-n-1) step -1 until 1 do
              ep := b!:extmult(!*sf2exb(multpf(w to j,u),w),ep);
              ep := b!:extmult(!*sf2exb(multd((-1)**(-n*ldeg u),u),
                                        w),
                               ep)>>
       else if n>0 then
            <<for j := (n-1) step -1 until 1 do
                ep := b!:extmult(!*sf2exb(multpf(w to j,v),w),ep);
              ep := b!:extmult(!*sf2exb(v,w),ep)>>;
     nm := max(ldeg u,ldeg v);
     uh := lc u;
     vh := lc v;
     ut := if n<0 then multpf(w to -n,red u)
           else red u;
     vt := if n>0 then multpf(w to n,red v)
            else red v;
     ap := addf(multf(uh,vt),negf multf(vh,ut));
     ep := if null ep then !*sf2exb(ap,w)
        else b!:extmult(!*sf2exb(ap,w),ep);
     for j := (nm - 1) step -1 until (abs n + 1) do
        <<if degr(ut,w) = j then
         <<uh := addf(lc ut,multf(!*k2f w,uh));
                   ut := red ut>>
       else    uh := multf(!*k2f w,uh);
          if degr(vt,w) = j then
         <<vh := addf(lc vt,multf(!*k2f w,vh));
                   vt := red vt>>
       else    vh := multf(!*k2f w,vh);
      ep := b!:extmult(!*sf2exb(addf(multf(uh,vt),
                    negf multf(vh,ut)),w),ep)>>;
     setkorder cdr kord!*;
     return if null ep then nil else lc ep
   end;

put('resultant,'simpfn,'simpresultant);

symbolic procedure simpresultant u;
   begin scalar !*exp;
     if length u neq 3
       then rederr "RESULTANT called with wrong number of arguments";
     !*exp := t;
     return resultant(!*q2f simp!* car u,
                      !*q2f simp!* cadr u,
                      !*a2k caddr u) ./ 1
   end;

symbolic procedure !*sf2exb(u,v);
   %distributes s.f. u with respect to powers in v.
   if degr(u,v)=0 then if null u then nil
                        else list 0 .* u .+ nil
    else list ldeg u .* lc u .+ !*sf2exb(red u,v);

%**** Support for exterior multiplication ****
% Data structure is lpow ::= list of degrees in exterior product
%                   lc   ::= standard form

symbolic procedure b!:extmult(u,v);
   %Special exterior multiplication routine. Degree of form v is
   %arbitrary, u is a one-form.
   if null u or null v then  nil
    else if v = 1 then u
    else (if x then cdr x .* (if car x then negf multf(lc u,lc v)
                   else multf(lc u,lc v))
              .+ b!:extadd(b!:extmult(!*t2f lt u,red v),
                    b!:extmult(red u,v))
       else b!:extadd(b!:extmult(red u,v),
              b!:extmult(!*t2f lt u,red v)))
      where x = b!:ordexn(car lpow u,lpow v);

symbolic procedure b!:extadd(u,v);
   if null u then v
    else if null v then u
    else if lpow u = lpow v then
            (lambda x,y; if null x then y else lpow u .* x .+ y)
        (addf(lc u,lc v),b!:extadd(red u,red v))
    else if b!:ordexp(lpow u,lpow v) then lt u .+ b!:extadd(red u,v)
    else lt v .+ b!:extadd(u,red v);

symbolic procedure b!:ordexp(u,v);
   if null u then t
    else if car u > car v then t
    else if car u = car v then b!:ordexp(cdr u,cdr v)
    else nil;

symbolic procedure b!:ordexn(u,v);
   %u is a single integer, v a list. Returns nil if u is a member
   %of v or a dotted pair of a permutation indicator and the ordered
   %list of u merged into v.
   begin scalar s,x;
     a: if null v then return(s . reverse(u . x))
     else if u = car v then return nil
     else if u and u > car v then
                 return(s . append(reverse(u . x),v))
         else  <<x := car v . x;
                 v := cdr v;
                 s := not s>>;
         go to a
   end;

endmodule;


end;

Added r33/solve.red version [fa45947530].





















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
module solve;   % Solve one or more algebraic equations.

% Author: David R. Stoutemyer.
% Modifications by: Anthony C. Hearn and Donald R. Morrison.

fluid '(!*exp asymplis!*);

global '(!!arbint
         !!gcd
         !*allbranch
         !*micro!-version
         !*nonlnr
         !*ppsoln
         !*solveinterval
         !*solvesingular
         multiplicities!*);

switch allbranch,solvesingular;   % solveinterval.

flag('(multiplicities!*),'share);

% ***** Global Declarations *****

array !!cf(12), !!interval(10,2), !!exact(10);

!*allbranch     := t;  % Returns all branches of solutions if T;
%!*solveinterval = nil;% Attempts to isolate insoluble, real roots if T;
!*solvesingular := t;  % Default value.
%  !!gcd     SOLVECOEFF returns GCD of powers of its arg in this
%  !!cf    : Array of coeffs from SOLVECOEFF

algebraic operator arbint, arbreal, intervl, list;

% algebraic operator arbcomplex;

% Done this way since it's also defined in the glmat module.

deflist('((arbcomplex simpiden)),'simpfn);

% ***** Utility Functions *****

symbolic procedure freeofl(u,v);
   null v or freeof(u,car v) and freeofl(u,cdr v);

symbolic procedure ratnump x;
   % Returns T iff any prefix expression x is a rational number.
   atom numr(x := simp!* x) and atom denr x;

flag ('(ratnump), 'direct);

symbolic procedure allkern elst;
   % Returns list of all top-level kernels in the list of standard
   % forms elst.
   if null elst then nil
    else union(kernels car numr elst, allkern cdr elst);

symbolic procedure topkern(u,x);
   % Returns list of top level kernels in the standard form u that
   % contain the kernel x;
   for each j in kernels u conc if not freeof(j,x) then list j else nil;

symbolic procedure coeflis ex;
   % Ex is a standard form.  Returns a list of the coefficients of the
   % main variable in ex in the form ((expon . coeff) (expon . coeff)
   % ... ), where the expon's occur in increasing order, and entries do
   % not occur of zero coefficients.
   begin scalar ans,var;
      if domainp(ex) then return (0 . ex);
      var := mvar(ex);
      while (not domainp(ex)) and mvar(ex)=var do 
        <<ans := (ldeg(ex) . lc(ex)) . ans; ex := red(ex) >>;
      if ex then ans := (0 . ex) . ans;
      return ans
   end;


% ***** Evaluation Interface *****

symbolic procedure solveeval u;
    begin scalar arglist;  integer nargs;
        arglist := u;
        nargs := length(arglist);       
        u := if nargs=1 then solve0(car arglist,nil)
              else if nargs=2
               then solve0(car arglist, cadr arglist)
             else solve0(car arglist,'list . cdr arglist);
      return !*solvelist2solveeqlist u
    end;

put('solve,'psopfn,'solveeval);

symbolic procedure !*solvelist2solveeqlist u;
   begin scalar x,y,z;
      for each j in u do
         <<if caddr j=0 then rederr "zero multiplicity"
            else if null cadr j
             then  x := for each k in car j collect
                                               list('equal,mk!*sq k,0)
            else x := for each k in pair(cadr j,car j)
                          collect list('equal,car k,mk!*sq cdr k);
           if length x > 1 then z := ('list . x) . z
            else z := car x . z;
           y := caddr j . y>>;
      multiplicities!* := 'list . y;
      return 'list . z
   end;

% ***** Fundamental SOLVE Procedures *****

comment these procedures return the solution of a list of equations as a
   list of elements with three fields: the solutions, the variables (or
   NIL if the equations could not be solved) and the multiplicity;

symbolic procedure solve0(elst, xlst);
   % elst is any prefix expression, including the kernel named LST with
   % any number of arguments.  XLST is a kernel, perhaps named LIST with
   % any number of arguments.  Solves eqns in ELST for vars in XLST,
   % returning either a list of solutions, or a single solution;
   begin scalar !*exp,vars;  integer neqn;
   !*exp := t;
   elst := for each j in solveargchk elst 
              collect simp!* if eqexpr j then !*eqn2a j else j;
   neqn := length elst;
   if neqn = 0 then rederr "SOLVE called with no equations";
   if null xlst 
     then <<vars := allkern elst;
            terpri();
            if null vars then nil
             else if cdr vars
              then <<prin2!* "Unknowns: "; maprin('list . vars)>>
             else <<prin2!* "Unknown: "; maprin car vars>>;
            terpri!* nil>>
    else <<xlst := solveargchk xlst;
           vars := for each j in xlst collect !*a2k j>>;
   if length vars = 0 then rederr "SOLVE called with no variables"
    else if neqn = 1
           then if null numr car elst
                  then return if !*solvesingular
                            then list list(list (makearbcomplex() ./ 1),
                                           vars,1)
                           else nil
          else if length vars=1
           then return solvesq(car elst,car vars,1);
   % more than one equation or variable.
    elst := solvesys(for each j in elst collect numr j,vars);
    return if null elst then nil
     else if null cdr elst then list list(car elst,vars,1)
     else if null !*nonlnr then rederr "Unbalanced SOLVE equations"
     else elst
   end;

symbolic procedure solveargchk u;
   if getrtype u eq 'list then cdr reval u
    else if atom u or not(car u eq 'lst) then list u
    else cdr u;


% ***** Procedures for solving a single eqn *****

symbolic procedure solvesq (ex,var,mul);
   % Attempts to find solutions for standard quotient ex with respect to
   % top level occurrences of var and kernels containing variable var.
   % Solutions containing more than one such kernel are returned
   % unsolved, and solve1 is applied to the other solutions.  Integer
   % mul is the multiplicity passed from any previous factorizations.
   % Returns a list of triplets consisting of solutions, variables and
   % multiplicity.
     begin scalar e1,x1,y,z;  integer mu;
      ex := numr ex;
      if null topkern(ex,var) then return nil;
      ex := fctrf ex;
      % now process monomial.
      if domainp car ex then ex := cdr ex 
       else ex := (car ex . 1) . cdr ex;
      for each j in ex do 
        <<e1 := car j;
          x1 := topkern(e1,var);
          mu := mul*cdr j;
          if x1
            then z := append(
             if null cdr x1 then solve1(e1,car x1,var,mu)
              else if (y := principal!-of!-powers!-soln(e1,x1,var,mu))
                          neq 'unsolved
               then y
              else if not smemq('sol,
                        (x1:=simp!* list('sol,mk!*sq(e1 ./ 1), var)))
               then solvesq(x1,var,mu)
              else list list(list(e1 ./ 1),nil,mu),
                 z)>>;
      return z
   end;

symbolic procedure principal!-of!-powers!-soln(ex,x1,var,mu);
   % Finds solutions of ex=0 by the principal of powers method, or
   % NIL if no such solutions exist.
   begin scalar z;
      if null !*ppsoln then return 'unsolved;
   a: if null x1 then return 'unsolved
       else if suitable!-expt car x1
          and not((z := pr!-pow!-soln1(ex,car x1,var,mu)) eq 'unsolved)
         then return z;
      x1 := cdr x1;
      go to a
   end;

symbolic procedure pr!-pow!-soln1(ex,y,var,mu);
   begin scalar oldkord,z;
      oldkord := setkorder list y;
      z := reorder ex;
      setkorder oldkord;
      if ldeg z neq 1 then return 'unsolved;
      z := coeflis z;
      if length z neq 2 or caar z neq 0
        then errach list("solve confused",ex,z);
      z := exptsq(quotsq(negsq(cdar z ./ 1),cdadr z ./ 1),
            caddr caddr y);
      z := solvesq(subs2 addsq(simp!* cadr y,negsq z),var,mu);
      z := check!-solutions(z,ex);
      return z
   end;

symbolic procedure check!-solutions(z,ex);
   begin scalar x,y;
      while z do
         if null cadar z then <<z := nil; x := 'unsolved>>
          else if null (y := numr subf(ex,list(caadar z .
                                               mk!*sq caaar z)))
             or null numvalue y
           then <<x := car z . x; z := cdr z>>
          else z := cdr z;
      return x
   end;

symbolic procedure numvalue u;
   % Find floating point value of sf u.
   begin scalar !*numval,x;
      !*numval := t;
      x := setdmode('float,t);
      u := numr simp prepf u;
      if x then setdmode(x,t) else setdmode('float,nil);
      return if eqcar(u,'!:ft!:) and 1000000*abs cdr u < 1 then nil
              else u
   end;

symbolic procedure suitable!-expt u;
   eqcar(u,'expt) and eqcar(caddr u,'quotient) and cadr caddr u = 1
      and fixp caddr caddr u;

symbolic procedure solve1(e1,x1,var,mu);
   comment e1 is a standard form, non-trivial in the kernel x1,
      which is itself a function of var, mu is an integer.
      Uses roots of unity, known solutions, 
      inverses, together with quadratic, cubic and quartic
      formulas, treating other cases as unsolvable.  Returns nil;
   begin scalar b,c,coeffs,hipow;  integer n;
      hipow := errorset(solvecoeff(e1, x1),nil,nil);
      if atom hipow then return list list(list(e1 . 1),nil,mu);
          % solvecoeff problem - no soln.
      hipow := car hipow;
      n:= !!gcd;   % numerical gcd of powers.
      for i := 0:hipow do
                 coeffs := nilchk getelv list('!!cf,i) . coeffs;
      if hipow = 1
        then return begin scalar lincoeff,y,z;
           b:=prepsq quotsq(negsq cadr coeffs,car coeffs);
           if n neq 1 then b := list('expt,b,list('quotient,1,n));
           % We may need to merge more solutions in the following if
           % there are repeated roots.
           for k := 0:n-1 do   % equation in power of var.
            <<lincoeff := simp!* list('times,b,
                          mkexp list('quotient,list('times,k,2,'pi),n));
              if x1=var
                then y := solnmerge(list lincoeff,list var,mu,y)
               else if not idp (z := car x1)
                then typerr(z,"solve operator")
               else if z := get(z,'solvefn) 
                then y := append(apply1(z,list(cdr x1,var,mu,lincoeff))
                                 ,y)
               else if (z := get(car x1,'inverse))   % known inverse
                then y := append(solvesq(subtrsq(simp!* cadr x1,
                                 simp!* list(z,mk!*sq lincoeff)),
                                 var,mu),y)
               else y := list(list subtrsq(simp!* x1,lincoeff),nil,mu)
                            . y>>;
      return y
    end
  else if hipow=2
   then return <<x1 := exptsq(simp!* x1,n); % allows for power variable
                 for each j in apply('solvequadratic,coeffs)
                     conc solvesq(subtrsq(x1,j),var,mu)>>
  else return begin scalar d,f,rcoeffs;
      % At this point, we cannot write down the solution directly, so
      % we look for various forms that we know how to solve.
      f:=(hipow+1)/2;
      d:=exptsq(simp!* x1,n);
      rcoeffs := reverse coeffs;
      return if solve1test1(coeffs,rcoeffs,f)  % coefficients symmetric
        then if f+f=hipow+1   % odd 
               then <<c:=addsq(d, 1 ./ 1);
                      append(solvesq(c,var,mu),
                             solvesq(quotsq(e1 ./ 1, c),var,mu))>>
              else <<setelv(list('!!cf,0),2 ./ 1);
                     setelv(list('!!cf, 1), simp!* '!!x);
                     c:=addsq(multsq(getelv(list('!!cf,f+1)),
                                     getelv(list('!!cf,1))),
                              getelv(list('!!cf,f)));
                     for j:=2:f do <<
                         setelv(list('!!cf, j),
                            subtrsq(multsq(getelv(list('!!cf,1)),
                                           getelv(list('!!cf,j-1))),
                                    getelv(list('!!cf,j-2))));
                         c:=addsq(c,multsq(getelv(list('!!cf,j)),
                                           getelv(list('!!cf,f+j))))>>;
                     for each j in solvesq(c,'!!x,mu) conc
                      solvesq(addsq(1 ./ 1,multsq(d,subtrsq(d,caar j))),
                                var,caddr j)>>
       else if solve1test2(coeffs,rcoeffs,f)
          % coefficients antisymmetric
        then <<c:=addsq(d,(-1 ./1));
               b := solvesq(c,var,mu);
               e1 := quotsq(e1 ./ 1, c);
               if f+f = hipow 
                then <<c := addsq(d,(1 ./ 1)); 
                       b := append(solvesq(c,var,mu),b);
                       e1 := quotsq(e1,c)>>;
               append(solvesq(e1,var,mu),b)>>
          % equation has no symmetry
       else if hipow=3 and null !*micro!-version
        then for each j in apply('solvecubic,coeffs)
                       conc solvesq(subtrsq(d,j),var,mu)
       else if hipow=4 and null !*micro!-version
        then for each j in apply('solvequartic,coeffs)
                       conc solvesq(subtrsq(d,j),var,mu)
       else if !*solveinterval and univariatep e1
        then solveinterval(e1,var,mu)
       else list list(list(e1 ./ 1),nil,mu)
          % We can't solve quintic and higher
      end
  end;

symbolic procedure solnmerge(u,varlist,mu,y);
   % Merge solutions in case of multiplicities. It may be that this is
   % only needed for the trivial solution x=0.
   if null y then list list(u,varlist,mu)
    else if u = caar y and varlist = cadar y
           then list(caar y,cadar y,mu+caddar y) . cdr y
    else car y . solnmerge(u,varlist,mu,cdr y);

symbolic procedure nilchk u; if null u then !*f2q u else u;

symbolic procedure solve1test1(coeffs,rcoeffs,f);
   % True if equation is symmetric in its coefficients. f is midpoint.
   begin integer j;
   a: if j>f then return t
       else if car coeffs neq car rcoeffs then return nil;
      coeffs := cdr coeffs;
      rcoeffs := cdr rcoeffs;
      j := j+1;
      go to a
   end;

symbolic procedure solve1test2(coeffs,rcoeffs,f);
   % True if equation is antisymmetric in its coefficients. f is
   %  midpoint.
   begin integer j;
   a: if j>f then return t
       else if numr addsq(car coeffs,car rcoeffs) then return nil;
      coeffs := cdr coeffs;
      rcoeffs := cdr rcoeffs;
      j := j+1;
      go to a
   end;

symbolic procedure solveabs u;
   begin scalar mu,var,lincoeff;
      var := cadr u;
      mu := caddr u;
      lincoeff := cadddr u;
      u := simp!* caar u;
      return append(solvesq(addsq(u,lincoeff),var,mu),
                    solvesq(subtrsq(u,lincoeff),var,mu))
   end;

put('abs,'solvefn,'solveabs);

symbolic procedure solveexpt u;
   begin scalar c,mu,var,lincoeff;
      var := cadr u;
      mu := caddr u;
      lincoeff := cadddr u;
      u := car u;
      return if freeof(car u,var)    % c**(...) = b.
        then <<if !*allbranch
                 then <<!!arbint:=!!arbint+1;
                        c:=list('times,2,'i,'pi,
                                list('arbint,!!arbint))>>
                else c:=0;
                solvesq(subtrsq(simp!* cadr u,
                     quotsq(addsq(simp!* list('log,mk!*sq lincoeff),
                                  simp!* c),
                            simp!* list('log,car u))),var,mu)>>
       else if freeof(cadr u,var)   %  (...)**(m/n) = b;
        then if ratnump cadr u 
               then solve!-fractional!-power(u,lincoeff,var,mu)
          else <<   %  (...)**c = b.
                 if !*allbranch 
                   then <<!!arbint:=!!arbint+1;
                          c := mkexp list('times,
                                          list('arbreal,!!arbint))>>
                  else c:=1;
                 solvesq(subtrsq(simp!* car u,
                                multsq(simp!* list('expt,
                                                   mk!*sq lincoeff,
                                                   mk!*sq invsq
                                                      simp!* cadr u),
                                       simp!* c)),var,mu)>>
        %  (...)**(...) = b : transcendental.
        else list list(list subtrsq(simp!*('expt . u),lincoeff),nil,mu)
   end;

symbolic procedure solve!-fractional!-power(u,x,var,mu);
   % attempts solution of equation car u**cadr u=x with respect to
   % kernel var and with multiplicity mu, where cadr u is a rational
   % number.
   begin scalar v,w,z;
      v := simp!* car u;
      w := simp!* cadr u;
      z := solvesq(subs2 subtrsq(exptsq(v,numr w),exptsq(x,denr w)),
                   var,mu);
      w := subtrsq(simp('expt . u),x);
      z := check!-solutions(z,numr w);
      return if z eq 'unsolved then list list(list w,nil,mu) else z
   end;

put('expt,'solvefn,'solveexpt);

symbolic procedure solvelog u;
   solvesq(subtrsq(simp!* caar u,simp!* list('expt,'e,mk!*sq cadddr u)),
          cadr u,caddr u);

put('log,'solvefn,'solvelog);

symbolic procedure solvecos u;
   begin scalar c,d,z;
      if !*allbranch 
        then <<!!arbint:=!!arbint+1;
               c:=list('times,2,'pi,list('arbint,!!arbint))>>
       else c:=0;
      c:=subtrsq(simp!* caar u,simp!* c);
      d:=simp!* list('acos,mk!*sq cadddr u);
      z := solvesq(subtrsq(c,d), cadr u,caddr u);
      if !*allbranch
        then z := append(solvesq(addsq(c,d), cadr u,caddr u),z);
      return z
   end;

put('cos,'solvefn,'solvecos);

symbolic procedure solvesin u;
   begin scalar c,d,f,z;
      if !*allbranch 
        then <<!!arbint:=!!arbint+1;
               f:=list('times,2,'pi,list('arbint,!!arbint))>>
       else f:=0;
      c:=simp!* caar u;
      d:=list('asin,mk!*sq cadddr u);
      z := solvesq(subtrsq(c,simp!* list('plus,d,f)),cadr u,caddr u);
      if !*allbranch 
        then z := append(solvesq(subtrsq(c,simp!* list('plus,'pi,
                                    mk!*sq subtrsq(simp!* f,simp!* d))),
                    cadr u,caddr u),z);
      return z
   end;

put('sin,'solvefn,'solvesin);

symbolic procedure mkexp u;
   list('plus,list('cos,x),list('times,'i,list('sin,x)))
    where x = reval u;

symbolic procedure solvecoeff(ex,var);
   % ex is a standard form and var a kernel. Puts the coefficients
   % (as standard quotients) of var in ex into the elements of !!cf,
   % with index equal to the exponent divided by the gcd of all the
   % exponents.  This GCD is put into !!GCD, and the highest power
   % divided by the gcd is put into hipow.  Returns hipow.  Note that
   % !!cf (an array), !!gcd a global.
begin scalar clist,hipow,oldkord;
   oldkord := setkorder list var;
   clist := reorder ex;
   setkorder oldkord;
   hipow := ldeg clist;
   clist := coeflis clist;
   !!gcd := caar clist;
   for each x in cdr clist do !!gcd := gcdn(car x, !!gcd);
   for i := 0:(car(dimension('!!cf))-1) do setelv(list('!!cf, i), nil);
   for each x in clist do setelv(list('!!cf, car x/!!gcd),cdr x ./ 1);
   hipow := hipow/!!gcd;
   return hipow
end;

symbolic procedure solveinterval(ex,var,mu);
   % ex is a standard form, var the relevant variable and mu the root
   % multiplicity. Isolates insoluble, real roots of EX in rational
   % intervals, returning solutions in terms of INTERVL(Lowlim,Highlim).
   begin scalar z;
      realroot(prepf ex,prepsq !*k2q mvar ex,'!!interval,'!!exact);
      for i := 1:getelv list('!!exact,0) do
         z := list(list simp!* getelv list('!!exact,i),list var,mu) . z;
      for i := 1:getelv list('!!interval,0,0) do
              z :=  list(list simp!* list('intervl,
                         getelv list('!!interval,i,1),
                         getelv list('!!interval,i,2)),
                   list var,mu). z;
      return z
   end;

symbolic procedure realroot(u,v,w,x);
   rederr("Real root finding not yet implemented");


% ***** Procedures for solving a system of eqns *****

symbolic procedure solvesys(exlist,varlis);
   % exlist is a list of standard forms, varlis a list of kernels.  If
   % the elements of varlis are linear in the elements of exlist, and
   % further the system of linear eqns so defined is non-singular, then
   % SOLVESYS returns a list of a list of standard quotients which are
   % solutions of the system, ordered as in varlis.  Otherwise an error
   % results.
   begin scalar eqtype,oldkord;
      oldkord := setkorder varlis;
      exlist := for each j in exlist collect reorder j;
      % See if equations are linear or non-linear.
      eqtype := 'solvelnrsys;
      for each ex in exlist do
         for each var in varlis do
            if not domainp ex and mvar ex=var
              then if ldeg ex>1 or not freeofl(lc ex,varlis)
                     then eqtype := 'solvenonlnrsys
             else ex := red ex;
      if eqtype eq 'solvenonlnrsys and null !*nonlnr
        then rederr "Non linear equation solving not yet implemented";
      exlist:=errorset(list(eqtype,mkquote exlist,mkquote varlis),t,t);
      setkorder oldkord;
      if errorp exlist then error1() else return car exlist
   end;

endmodule;


module glsolve; % Routines for solving a general system of linear eqns.

% Author: Eberhard Schruefer.

%**********************************************************************
%*** The number of equations and the number of unknowns are         ***
%*** arbitrary i.e. the system can be under- or overdetermined.     ***
%*** Method used is Cramer's rule, realized through exterior        ***
%*** multiplication.                                                ***
%**********************************************************************

fluid '(kord!*);

global '(!!arbint !*solvesingular);

% algebraic operator arbcomplex; % Already defined in main solve module.

symbolic procedure glsolve!-eval(u,bool);
   % This allows glsolve to be called at the user level. I'm not
   % sure this is now a good idea, since this code does not check
   % for non-linear equations and so on.
   begin scalar unknowns,equations,okord,solutions;
     if cdr u then
        unknowns := for each j in cdadr u collect !*a2k j;
           okord := setkorder append(unknowns,kord!*);
       equations := for each j in cdar u collect
                        reorder numr simp!* j;
     if null unknowns then unknowns := allkernf equations;
     solutions := glnrsolve(equations,unknowns);
     setkorder okord;
     if null solutions then return '(list); % empty list.
     solutions := nil . solutions;
     return 'list .
             for each j in unknowns collect
                 list('equal,j,mk!*sq car(solutions := cdr solutions))
   end;

symbolic procedure allkernf u;
   if null u then nil else union(kernels car u,allkernf cdr u);

put('glsolve,'psopfn,'glsolve!-eval);

symbolic procedure solvelnrsys(u,v);
   % This is hook to general solve package. u is a list of polynomials
   % (s.f.'s) linear in the kernels of list v. Result is a matrix
   % standard form for the solutions.
   list glnrsolve(u,v);

symbolic procedure glnrsolve(u,v);
   %u is a list of polynomials (s.f.'s) linear in the kernels
   %of list v. Result is an untagged list of solutions.
   begin scalar arbvars,sgn,x,y;
     x := !*sf2ex(car u,v);
     u := cdr u;
     for each j in u do
        if y := extmult(!*sf2ex(j,v),x)
           then x := y;
     if inconsistency!-chk x
       then rederr "SOLVE given inconsistent equations";
     arbvars := for each j in setdiff(v,lpow x) collect
                    j . makearbcomplex();
     if arbvars and null !*solvesingular
       then rederr "SOLVE given singular equations";
     if null red x then return
        for each j in v collect
            if y := atsoc(j,arbvars) then !*f2q cdr y else nil ./ 1;
     sgn := evenp length lpow x;
     return for each j in v collect if y := atsoc(j,arbvars)
                                       then !*f2q cdr y
                      else mkglsol(j,x,sgn := not sgn,arbvars)
   end;

symbolic procedure inconsistency!-chk u;
   null u or ((nil memq lpow u) and inconsistency!-chk red u);

symbolic procedure mkglsol(u,v,sgn,arbvars);
   begin scalar s,x,y;
     x := nil ./ 1;
     y := lpow v;
     for each j on red v do
       if s := glsolterm(u,y,j,arbvars)
          then x := addsq(cancel(s ./ lc v),x);
     return if sgn then negsq x else x
   end;

symbolic procedure glsolterm(u,v,w,arbvars);
   begin scalar x,y,sgn;
     x := lpow w;
     a: if null x then return
           if null car y then lc w
            else multf(cdr atsoc(car y,arbvars),
                       if sgn then negf lc w else lc w);
        if car x eq u then return nil
         else if car x memq v then <<x := cdr x;
                                     if y then sgn := not sgn>>
         else if y then return nil
               else <<y := list car x; x := cdr x>>;
        go to a
   end;

%**** Support for exterior multiplication ****
% Data structure is lpow ::= list of variables in exterior product
%                   lc   ::= standard form

symbolic procedure !*sf2ex(u,v);
   %Converts standardform u into a form distributed w.r.t. v
%*** Should we check here if lc is free of v?
   if null u then nil
    else if domainp u or null(mvar u memq v) then list nil .* u .+ nil
    else list mvar u .* lc u .+ !*sf2ex(red u,v);

symbolic procedure extmult(u,v);
   %Special exterior multiplication routine. Degree of form v is
   %arbitrary, u is a one-form.
   if null u or null v then  nil
    else (if x then cdr x .* (if car x then negf multf(lc u,lc v)
                               else multf(lc u,lc v))
                          .+ extadd(extmult(!*t2f lt u,red v),
                                    extmult(red u,v))
           else extadd(extmult(red u,v),extmult(!*t2f lt u,red v)))
          where x = ordexn(car lpow u,lpow v);

symbolic procedure extadd(u,v);
   if null u then v
    else if null v then u
    else if lpow u = lpow v then
            (lambda x,y; if null x then y else lpow u .* x .+ y)
                (addf(lc u,lc v),extadd(red u,red v))
    else if ordexp(lpow u,lpow v) then lt u .+ extadd(red u,v)
    else lt v .+ extadd(u,red v);

symbolic procedure ordexp(u,v);
   if null u then t
    else if car u eq car v then ordexp(cdr u,cdr v)
    else if null car u then nil
    else if null car v then t
    else ordop(car u,car v);

symbolic procedure ordexn(u,v);
   %u is a single variable, v a list. Returns nil if u is a member
   %of v or a dotted pair of a permutation indicator and the ordered
   %list of u merged into v.
   begin scalar s,x;
     a: if null v then return(s . reverse(u . x))
         else if u eq car v then return nil
         else if u and ordop(u,car v) then
                 return(s . append(reverse(u . x),v))
         else  <<x := car v . x;
                 v := cdr v;
                 s := not s>>;
         go to a
   end;

endmodule;


module quartic;  % Procedures for solving cubic, quadratic and quartic
                 % eqns.

% Author: Anthony C. Hearn.

fluid '(!*sub2);

symbolic procedure multfq(u,v);
   % Multiplies standard form U by standard quotient V.
   begin scalar x;
      x := gcdf(u,denr v);
      return multf(quotf(u,x),numr v) ./ quotf(denr v,x)
   end;

symbolic procedure quotsqf(u,v);
   % Forms quotient of standard quotient U and standard form V.
   begin scalar x;
      x := gcdf(numr u,v);
      return quotf(numr u,x) ./ multf(quotf(v,x),denr u)
   end;

symbolic procedure cubertq u;
   simpexpt list(mk!*sq subs2!* u,'(quotient 1 3));
   % SIMPRAD(U,3);

symbolic procedure sqrtq u;
   simpexpt list(mk!*sq subs2!* u,'(quotient 1 2));
   % SIMPRAD(U,2);

symbolic procedure subs2!* u; <<!*sub2 := t; subs2 u>>;

symbolic procedure solvequadratic(a2,a1,a0);
   % a2, a1 and a0 are standard quotients.
   % solves a2*x**2+a1*x+a0=0 for x.
   % returns a list of standard quotient solutions.
   begin scalar d;
      d := sqrtq subtrsq(quotsqf(exptsq(a1,2),4),multsq(a2,a0));
      a1 := quotsqf(negsq a1,2);
      return list(subs2!* quotsq(addsq(a1,d),a2),
                  subs2!* quotsq(subtrsq(a1,d),a2))
   end;
   
symbolic procedure solvecubic(a3,a2,a1,a0);
   % a3, a2, a1 and a0 are standard quotients.
   % solves a3*x**3+a2*x**2+a1*x+a0=0 for x.
   % returns a list of standard quotient solutions.
   % See Abramowitz and Stegun, Sect. 3.8.2, for details.
   begin scalar q,r,sm,sp,s1,s2,x;
      a2 := quotsq(a2,a3);
      a1 := quotsq(a1,a3);
      a0 := quotsq(a0,a3);
      q := subtrsq(quotsqf(a1,3),quotsqf(exptsq(a2,2),9));
      r := subtrsq(quotsqf(subtrsq(multsq(a1,a2),multfq(3,a0)),6),
                   quotsqf(exptsq(a2,3),27));
      x := sqrtq addsq(exptsq(q,3),exptsq(r,2));
      s1 := cubertq addsq(r,x);
      s2 := if numr s1 then negsq quotsq(q,s1)
             else cubertq subtrsq(r,x);
         % This optimization only works if s1 is non zero.
      sp := addsq(s1,s2);
      sm := quotsqf(multsq(simp '(times i (sqrt 3)),subtrsq(s1,s2)),2);
      x := subtrsq(sp,quotsqf(a2,3));
      sp := negsq addsq(quotsqf(sp,2),quotsqf(a2,3));
      return list(subs2!* x,subs2!* addsq(sp,sm),
                  subs2!* subtrsq(sp,sm))
   end;
      
symbolic procedure solvequartic(a4,a3,a2,a1,a0);
   % Solve the quartic equation a4*x**4+a3*x**3+a2*x**2+a1*x+a0 = 0,
   % where the ai are standard quotients, using technique described in
   % Section 3.8.3 of Abramowitz and Stegun;
   begin scalar x,y,z;
      % Convert equation to monomial form.
      a3 := quotsq(a3,a4);
      a2 := quotsq(a2,a4);
      a1 := quotsq(a1,a4);
      a0 := quotsq(a0,a4);
      % Build and solve the resultant cubic equation.  We select an
      % arbitrary member of its set of solutions.  Ideally we should
      % only generate one solution, which should be the simplest.
      y := subtrsq(exptsq(a3,2),multfq(4,a2));
      % note that only first cubic solution is used here. We could save
      % computation by using this fact.
      x := car solvecubic(!*f2q 1,
                      negsq a2,
                      subs2!* subtrsq(multsq(a1,a3),multfq(4,a0)),
                      subs2!* negsq addsq(exptsq(a1,2),
                                          multsq(a0,y)));
      % Now solve the two equivalent quadratic equations.
      y := sqrtq addsq(quotsqf(y,4),x);
      z := sqrtq subtrsq(quotsqf(exptsq(x,2),4),a0);
      a3 := quotsqf(a3,2);
      x := quotsqf(x,2);
      return append(solvequadratic(!*f2q 1,addsq(a3,y),subtrsq(x,z)),
                    solvequadratic(!*f2q 1,subtrsq(a3,y),addsq(x,z)))
   end;

endmodule;


module solvetab;   % Simplification rules for SOLVE.

% Author: David R. Stoutemyer.
% Modifications by: Anthony C. Hearn and Donald R. Morrison;

algebraic operator sol;

put('asin, 'inverse, 'sin);

put('acos, 'inverse, 'cos);

algebraic;

comment Rules for reducing the number of distinct kernels in an
   equation;

for all a,b,x such that ratnump c and ratnump d let
   sol(a**c-b**d, x) = a**(c*lcm(c,d)) - b**(d*lcm(c,d));

for all a,b,c,d,x such that a freeof x and c freeof x let
   sol(a**b-c**d, x) = e**(b*log a - d*log c);

for all a,b,c,d,x such that a freeof x and c freeof x let
   sol(a*log b + c*log d, x) = b**a*d**c - 1,
   sol(a*log b - c*log d, x) = b**a - d**c;

for all a,b,c,d,f,x such that a freeof x and c freeof x let
   sol(a*log b + c*log d + f, x) = sol(log(b**a*d**c) + f, x),
   sol(a*log b + c*log d - f, x) = sol(log(b**a*d**c) - f, x),
   sol(a*log b - c*log d + f, x) = sol(log(b**a/d**c) + f, x),
   sol(a*log b - c*log d - f, x) = sol(log(b**a/d**c) - f, x);

for all a,b,d,f,x such that a freeof x let
   sol(a*log b + log d + f, x) = sol(log(b**a*d) + f, x),
   sol(a*log b + log d - f, x) = sol(log(b**a*d) - f, x),
   sol(a*log b - log d + f, x) = sol(log(b**a/d) + f, x),
   sol(a*log b - log d - f, x) = sol(log(b**a/d) - f, x),
   sol(log d - a*log b + f, x) = sol(log(d/b**a) + f, x),
   sol(log d - a*log b - f, x) = sol(log(d/b**a) - f, x);

for all a,b,c,d,x such that a freeof x and c freeof x let
   sol(a*log b + c*log d, x) = b**a*d**c - 1,
   sol(a*log b - c*log d, x) = b**a - d**c;

for all a,b,d,x such that a freeof x let
   sol(a*log b + log d, x) = b**a*d - 1,
   sol(a*log b - log d, x) = b**a - d,
   sol(log d - a*log b, x) = d - b**a;

for all a,b,c,x let
   sol(log a + log b + c, x) = sol(log(a*b) + c, x),
   sol(log a - log b + c, x) = sol(log(a/b) + c, x),
   sol(log a + log b - c, x) = sol(log(a*b) - c, x),
   sol(log a - log b - c, x) = sol(log(a/b) - c, x);

for all a,c,x such that c freeof x let
   sol(log a + c, x) = a - e**c,
   sol(log a - c, x) = a - e**(-c);

for all a,b,x let
   sol(log a + log b, x) = a*b - 1,
   sol(log a - log b, x) = a - b,
   sol(cos a - sin b, x) = sol(cos a - cos(pi/2-b), x),
   sol(sin a + cos b, x) = sol(sin a - sin(b-pi/2), x),
   sol(sin a - cos b, x) = sol(sin a - sin(pi/2-b), x),
   sol(sin a + sin b, x) = sol(sin a - sin(-b), x),
   sol(sin a - sin b, x) = if !*allbranch then sin((a-b)/2)*
       cos((a+b)/2)  else a-b,
   sol(cos a + cos b, x) = if !*allbranch then cos((a+b)/2)*
       cos((a-b)/2)  else a+b,
   sol(cos a - cos b, x) = if !*allbranch then sin((a+b)/2)*
       sin((a-b)/2)  else a-b,
   sol(asin a - asin b, x) = a-b,
   sol(asin a + asin b, x) = a+b,
   sol(acos a - acos b, x) = a-b,
   sol(acos a + acos b, x) = a+b;

symbolic;

endmodule;


end;

Added r33/spde.red version [8930c2efb4].







































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
module spde;  % Determine Lie symmetries of partial differential eqns.

% Author: Fritz Schwarz.

 %*******************************************************************$
 %                                                                   $
 %       This is the  REDUCE package SPDE for determining            $
 %       Lie symmetries of partial differential equations            $
 %                Version of November 1986                           $
 %                                                                   $
 %                                                                   $
 %               Fritz Schwarz                                       $
 %               GMD Institut F1                                     $
 %               Postfach 1240                                       $
 %               5205 St. Augustin                                   $
 %               West Germany                                        $
 %                                                                   $
 %               Tel. 02241-142782                                   $
 %               EARN Id. DBNGMD21.GF1002                            $
 %*******************************************************************$

 algebraic operator x,u,xi,eta,c,xi!*,eta!*$
 algebraic operator deq,dx,du,gl,gen,sder,rule$
 share pclass,mm,nn$
 global'(pclass mm nn depl!* num!-cgen num!-dgen)$
 lisp(pclass:=mm:=nn:=num!-cgen:=num!-dgen:=0)$

 lisp(operator simpsys,result,prsys,prsys!*)$
 fluid '(!*list kord!*)$
 fluid'(uhf dfsub csub czero rdep !*rational)$
 fluid'(list!-m list!-deq list!-pq)$

%symbolic procedure prload$
%  begin
%  if not getd 'solve1 then load solve1,solvetab,quartic;
%  if not getd 'depend1 then load depend;
%  if not getd 'ratfunpri then load ratprin;
%  end$

symbolic procedure prload; nil;

 %*******************************************************************$
 %              Auxiliary RLISP procedures                           $
 %*******************************************************************$

 symbolic procedure ordp(u,v)$
 %Modified ordering function which orders kernels with CAR parts;
 %DF, ETA, XI and C ahead of anything else;
 if null u then null v else if null v then t else
 if eq(u,'df) or eq(u,'eta) and not eq(v,'df)
 or eq(u,'xi) and not(eq(v,'df) or eq(v,'eta))
 or eq(u,'c) and not(eq(v,'df) or eq(v,'eta) or eq(v,'xi)) then t else
 if eq(u,'eta) and eq(v,'df)
 or eq(u,'xi) and (eq(v,'df) or eq(v,'eta))
 or eq(u,'c) and (eq(v,'df) or eq(v,'eta) or eq(v,'xi))
 or eq(v,'df) or eq(v,'eta) or eq(v,'xi) or eq(v,'c) then nil else
 if atom u then if atom v then
 if numberp u then numberp v and not u<v else
 if numberp v then t else orderp(u,v) else nil else
 if atom v then t else
 if car u=car v then ordp(cdr u,cdr v) else ordp(car u,car v)$

 symbolic procedure makeset u$
 if not u then nil else
 if member(car u,cdr u) then makeset cdr u else
 car u . makeset cdr u$

 symbolic procedure lastmem u$
 if cdr u then lastmem cdr u else car u$

 symbolic procedure xmember(u,v)$ reverse member(u,reverse v)$

 symbolic procedure sacar(a,u)$
 if atom u then nil else
 if eq(a,car u) and cdr u then list u else
 append(sacar(a,car u),sacar(a,cdr u))$

 symbolic procedure scar(a,u)$
 if atom u then nil else if a=car u then u else
 scar(a,car u) or scar(a,cdr u)$

 symbolic procedure inter(u,v);
 if not u then nil else
 if member(car u,v) then
 (car u) . inter(cdr u,v) else inter(cdr u,v)$

 symbolic procedure compl(u,v)$
 if not u then nil else if member(car u,v) then
 compl(cdr u,v) else car u . compl(cdr u,v)$

 symbolic procedure vlist u$
 %U is list of items, returns U with all integers omitted;
 if not u then nil else
 if numberp car u then vlist cdr u else (car u) . vlist cdr u$

 symbolic procedure delnil u$
 %U is list, returns U with all occurences of nil deleted;
 if not u then nil else
 if car u then (car u) . delnil cdr u else delnil cdr u$

 symbolic procedure prlist u$
 %U is list of items, returns list of all pairs in U;
 if not u then nil else
 if pairp car u then (car u) . prlist cdr u else prlist cdr u$

 symbolic procedure appends(u,v,w)$ append(u,append(v,w))$

 symbolic procedure propa(fn,u)$
 %FN is predicate of a single argument, U a list;
 %Returns T if predicate is true for all elements of U;
   begin scalar ind;
   ind:=t;
   while ind and u do <<ind:=apply(fn,list car u); u:=cdr u>>;
   return ind;
   end$

 symbolic procedure sortx(fn,u)$
   begin scalar v,w;
   while u do<<v:=maxmem(fn,u); u:=delete(v,u); w:=v . w>>;
   return w;
   end$

 symbolic procedure maxmem(fn,u)$
 %FN is function of a single argument, U a list;
 %Returns element of U for which FN is maximal;
   begin scalar v;
   v:=car u;
   foreach x in cdr u do
   if greaterp(apply(fn,list x),apply(fn,list v)) then v:=x;
   return v;
   end$

 symbolic procedure maxl u$
 %U is list of integers, returns largest element of U;
 if not u then -10000 else max(car u,maxl cdr u)$

 symbolic procedure suml u$
 %U is list of integers, returns sum of all elements;
 if not u then 0 else plus2(car u,suml cdr u)$

 symbolic procedure spde!-subsetp(u,v)$
 %U and V are list representing sets;
 %Returns T if set U is subset of V;
 if not u then t else
 member(car u,v) and spde!-subsetp(cdr u,v)$

 symbolic procedure product!-set2(u,v)$
 %U and V are lists representing sets, returns list representing;
 %product set of sets represented by U and V;
   begin scalar w;
   foreach x in u do foreach y in v do w:=list(x,y) . w;
   return w;
   end$

 symbolic procedure leqgrt(l,i,j)$
 i leq j and eqn(l,i) or i geq add1 j$

 symbolic procedure fidep u$
 assoc(u,depl!*) and cdr assoc(u,depl!*)$

 symbolic procedure mkdep u$
 foreach x in cdr u do depend1(car u,x,t)$

 symbolic procedure rmdep u$
 <<rmsubs(); foreach x in cdr u do depend1(car u,x,nil)>>$

 symbolic procedure blanks l;
   begin scalar u;
   u := '(!");
   for k:=1:l do u:='! . u;
   return compress('!" . u)
   end$

 symbolic procedure terpri2$ <<terpri(); terpri()>>$

 %*******************************************************************$
 %    Auxiliary procedures for manipulating standard forms           $
 %*******************************************************************$

 symbolic procedure lcf u$ not domainp u and lc u$

 symbolic procedure minus!-f u$
 %U is s.f., returns T if lnc U is negative;
 minusf numr simp reval u$

 lisp operator minus!-f$

 symbolic procedure lengthn u$
 if not u then 0 else
 if numberp car u then plus(sub1 car u,lengthn cdr u) else
 plus(1,lengthn cdr u)$

 symbolic procedure degreef(u,v)$
 %U is s.f., V kernel, returns degree of V in U;
 if domainp u then 0 else
 if mvar u=v then ldeg u else
 max(degreef(lc u,v),degreef(red u,v))$

 symbolic procedure lengthf u$
 %U is prefix s.f., returns printlength for U;
 if not u then 0 else
 if atom u then flatsizec u else
 if eqcar(u,'plus)
 then plus(times(3,sub1 length cdr u),lengthf cdr u) else
 if eqcar(u,'times) or eqcar(u,'minus)
 then plus(sub1 length cdr u,lengthf cdr u) else
 if eqcar(u,'quotient) then
 if !*rational then add1 add1 max(flatsizec cadr u,flatsizec caddr u)
 else add1 plus(flatsizec cadr u,flatsizec caddr u) else
 if eqcar(u,'expt) then add1 flatsizec cadr u else
 if eqcar(u,'dx) or eqcar(u,'du) then plus(flatsizec cadr u,4) else
 if eqcar(u,'xi) or eqcar(u,'eta) or eqcar(u,'c)
 or eqcar(u,'x) or eqcar(u,'u) then times(2,length u) else
 if eqcar(u,'df) then plus(4,lengthf cadr u,lengthf cddr u) else
 plus(lengthf car u,lengthf cdr u)$

 lisp operator lengthf$

 symbolic procedure diford u$ lengthn cddr u$

 symbolic procedure adiff(u,v)$
 %U is kernel with CAR part DF, V is kernel;
 %Returns U integrated with respect to V;
 if not member(v,u) then u else
 if length u=3 and member(v,u) then cadr u else
 if not cdr member(v,u)
 or not numberp cadr member(v,u) then delete(v,u) else
 if cadr member(v,u)=2 then
 append(xmember(v,u),cddr member(v,u)) else
 append(xmember(v,u),(sub1 cadr member(v,u)) . cddr member(v,u))$

 symbolic procedure sub!-int!-df u$
 %U is kernel with CAR part INT, returns integrated kernel if CADR;
 %part of U is DF and integration variable occurs as argument of DF;
 if eqcar(cadr u,'df) and member(lastmem u,cadr u) then
 adiff(cadr u,lastmem u) else u$

 symbolic procedure subintf u$
 %U is s.f., performs all integrations which may be done;
 %by cancellation of corresponding differentiation;
   begin
   foreach x in makeset sacar('int,u) do
   u:=subst(sub!-int!-df x,x,u);
   return numr simp prepf u;
   end$

 symbolic procedure monop u$
 %Returns T if u is monomial;
 domainp u or not red u and monop lc u$

 symbolic procedure solvef(u,v)$ car solve0(prepf u,v)$

 symbolic procedure comfacn u$  lnc ckrn u$

 symbolic procedure remfacn u$ quotf(u,lnc ckrn u)$

 %*******************************************************************$
 %     Procedures for manipulating l.d.f.'s, U is always l.d.f.      $
 %                      in this section                              $
 %*******************************************************************$

 symbolic procedure ldf!-mvar u$
 %Returns function argument of mvar U;
 (if eqcar(x,'df) then cadr x else x) where x=mvar u;

 symbolic procedure ldf!-fvar u$
 %Returns all function arguments occuring in U;
 makeset foreach x in u collect ldt!-tvar x$

 symbolic procedure ldf!-fvar!-part(u,v)$
 %V is function xi(i), eta(alpha) or c(k), returns l.d.f. of those;
 %terms in U with ldt-tvar x equal to V, overall factors not removed;
   begin scalar w;
   foreach x in u do if eq(ldt!-tvar x,v) then w:=x . w;
   return reverse w;
   end$

 symbolic procedure ldf!-dep!-var u$
 %Returns all variables x(i) or u(alpha) which occur as;
 %arguments of XI, ETA or C;
   begin scalar v;
   foreach x in u do if assoc(ldt!-tvar x,depl!*) then
   v:=append(cdr assoc(ldt!-tvar x,depl!*),v);
   return makeset v;
   end$

 symbolic procedure ldf!-pow!-var u$
 %Returns all variables x(i) or u(alpha) which occur as powers;
   begin scalar v,z;
   foreach x in u do v:=append(v,kernels tc x);
   foreach y in prlist makeset v do
   if eqcar(y,'x) or eqcar(y,'u) then z:=y . z;
   return makeset z;
   end$

 symbolic procedure ldf!-deg(u,v)$
 %V is kernel x(i) or u(alpha), returns degree of U in V;
 maxl foreach x in u collect degreef(tc x,v)$

 symbolic procedure ldf!-spf!-var u$
 %Returns all variables x(i) or u(alpha) which occur as;
 %arguments of any other kernel than xi, eta or c;
   begin scalar v,z;
   foreach x in u do v:=append(v,kernels tc x);
   foreach y in prlist makeset v do
   if not eqcar(y,'x) and not eqcar(y,'u) then
   z:=appends(sacar('x,cdr y),sacar('u,cdr y),z);
   return makeset z;
   end$

 symbolic procedure ldf!-all!-var u$
 %Returns all variables x(i) or u(alpha) which occur in U;
 makeset appends(ldf!-dep!-var u,ldf!-pow!-var u,ldf!-spf!-var u)$

 symbolic procedure ldf!-sep!-var u$
 %Returns all variables w.r.t. which U may be separated;
 compl(compl(ldf!-pow!-var u,ldf!-dep!-var u),ldf!-spf!-var u)$

 symbolic procedure ldf!-int!-var u$
 %Returns all variables w.r.t. which U may be integrated;
 if eqcar(mvar u,'df) then
   begin scalar v;
   v:=ldf!-all!-var u;
   while v and u do
   <<v:=compl(v,compl(ldt!-dep car u,ldt!-dfvar car u)); u:=cdr u>>;
   return v;
   end$

 symbolic procedure ldf!-int u$
 %U is l.d.f, returns U with all possible integrations performed;
 %or unchanged if integration is not possible;
   begin scalar v,w,z,test; integer nfun;
   a:
   test:=nil;
   w:=ldf!-int!-var u;
   nfun:=find!-nfun();
   foreach x in w do
   if not smember('int,z:=caadr algebraic int(lisp prepf u,x))
   or not smember('int,z:=subintf z) then
   <<v:=!*a2k list('c,nfun:=nfun+1); test:=t;
     mkdep(v . delete(x,ldf!-all!-var u));
     u:=addf(z,!*k2f v)>>;
   if test then go to a;
   return u;
   end$

 symbolic procedure ldf!-df!-diff u$
 %Returns list of all df-kernels which may be obtained;
 %from U by differentiation or nil;
   begin scalar dfvar,dfsub,v,w,z0,z; integer n0,nmax;
   v:=compl(ldf!-dep!-var u,ldf!-spf!-var u);
   if not v then return;
   w:=foreach x in v collect list(x,add1 ldf!-deg(u,x));
   nmax:=maxl foreach x in w collect cadr x;
   while (n0:=n0+1) leq nmax and not(z0:=nil) do
   <<foreach x in w do if cadr x geq n0 then z0:=(car x) . z0;
     z:=z0 . z>>;
   z:=reverse z;
   dfvar:=foreach x in car z collect list x;
   foreach x in cdr z do dfvar:=
   append(dfvar,foreach y in dfvar collect car product!-set2(x,y));
   foreach x in dfvar do
     begin scalar p,q;
     p:=x; q:=u;
     while p and q and red q do
     <<q:=ldf!-simp numr difff(q,car p); p:=cdr p>>;
     if pairp q and not red q and eqcar(mvar q,'df) then
     dfsub:=(mvar q) . dfsub;
     end;
   return makeset dfsub;
   end$

 symbolic procedure ldf!-sub!-var u$
 %Returns function w.r.t. which U may be resolved;
   begin scalar v,w,z;
   w:=ldf!-all!-var u;
   foreach x in u do if not v and not eqcar(z:=tvar x,'df)
   and monop tc x and spde!-subsetp(w,ldt!-dep x)
   and not smember(z,delete(x,u)) then v:=z;
   return v;
   end$

 symbolic procedure ldf!-simp u$
 %Returns l.d.f. form of U;
 if not u then nil else
 if not red u then numr simp prepf !*k2f mvar u else
   begin scalar v;
   v:=numr simp prepf u;
   if not domainp v then v := quotf(v,cdr comfac v);
   return absf v
   end$

 symbolic procedure ldf!-sep u$
 %Returns list of l.d.f. into which U has been separated;
   begin scalar v; integer k;
   if not(v:=ldf!-sep!-var u) then return list u;
   foreach x in v do u:=subst(list('ux,1,k:=k+1),x,u);
   return foreach x in coeff!-all(u,'ux) collect
   ldf!-simp numr simp prepf x;
   end$

 symbolic procedure ldf!-subf0 u$
 %Returns U with CZERO substituted;
 ldf!-simp delnil foreach x in u collect ldt!-subt0 x$

 %*******************************************************************$
 %     Procedures for manipulating l.d.t.'s, U is always l.d.t.      $
 %                      in this section                              $
 %*******************************************************************$

 symbolic procedure ldt!-tvar u$
 %U is l.d.t., returns function argument of tvar U;
 (if eqcar(x,'df) then cadr x else x) where x=tvar u$

 symbolic procedure ldt!-dfvar u$
 %U is l.d.t., returns variables w.r.t. which tvar u is derived or nil;
 (if eqcar(x,'df) then vlist cddr x else nil) where x=tvar u$

 symbolic procedure ldt!-dep u$
 %U is l.d.t., returns list of variables x or y which occur as;
 %arguments LDT-tvar u;
   (if x then cdr x else nil) where x=assoc(ldt!-tvar u,depl!*)$

 symbolic procedure ldt!-subt0 u$
 %U is l.d.t., returns U if LDT-tvar u is not on czero;
 if not member(ldt!-tvar u,czero) then u else nil$

 %*******************************************************************$
 %      Procedures for constructing the determining system           $
 %*******************************************************************$

 symbolic procedure cresys u$
   begin scalar r,v,w,lgl,lsub,depl!*!*,list!-sder;
   remprop('df,'kvalue); remprop('df,'klist);
   remprop('c,'kvalue); remprop('c,'klist);
   prload();
   rmsubs();
   depl!*:=nil;
   if car u then
   list!-deq:=foreach x in u collect assoc(x,get(car x,'kvalue)) else
   list!-deq:=get('deq,'kvalue);
   if eqn(length list!-deq,1) then
     begin scalar p;
     p:=maxmem(function length,makeset sacar('u,list!-deq));
     p:=mk!*sq !*k2q p;
     list!-sder:=list list(list('sder, cadaar list!-deq),p);
     end else if car u then
   list!-sder:=foreach x in list!-deq collect
   assoc(list('sder,cadar x),get('sder,'kvalue)) else
   list!-sder:=get('sder,'kvalue);
   if not list!-deq then rederr
   "Differential equations not defined";
   if not list!-sder then rederr
   "Substitutions for derivatives not defined";
   mm:=find!-m list!-deq; nn:=find!-n list!-deq;
   list!-m:=
   makeset foreach x in sacar('u,list!-deq) collect cadr x;
   for k:=1:nn do<<w:=!*a2k list('xi,k) . w; v:=!*a2k list('x,k) . v>>;
   for k:=1:mm do if member(k,list!-m) then
   <<w:=!*a2k list('eta,k) . w; v:=!*a2k list('u,k) . v>>;
   for k:=1:nn do r:=(!*a2k list('dx,k)) . r;
   for k:=1:mm do r:=(!*a2k list('du,k)) . r;
   for k:=1:mm do depl!*!*:=(!*a2k list('eta,k) . v) . depl!*!*;
   for k:=1:nn do depl!*!*:=(!*a2k list('xi,k) . v) . depl!*!*;
   depl!*:=depl!*!*;
   kord!*:=reverse r;
   foreach x in list!-sder do
   lsub:=((mvar caadr cadr x) . prepsq caar solvef(caadr cadr assoc
   (list('deq,cadar x),list!-deq),mvar caadr cadr x)) . lsub;
   foreach x in list!-deq do
     begin scalar s,z,lx,lu;
     z:=caadr cadr x;
     lx:=makeset sacar('x,z);
     lu:=makeset sacar('u,z);
     foreach y in lx do s:=addf(s,
     multf(!*k2f !*a2k list('xi,cadr y),numr simp prepsq difff(z,y)));
     foreach y in lu do if length y=2 then
     s:=addf(s,multf
     (!*k2f !*a2k list('eta,cadr y),numr simp prepsq difff(z,y))) else
     s:=addf(s, multf(numr zeta!* cdr y,numr simp prepsq difff(z,y)));
     s:=numr subf(s,lsub);
     s:=numr subf(s,lsub);
     lgl:=append(coeff!-all(s,'u),lgl);
     end;
   uhf:=list(makeset lgl,foreach x in reverse w collect !*k2q x);
   end$

 lisp rlistat'(cresys)$

 symbolic procedure totder(u,i)$
   begin scalar z,v,w;
   v:=car difff(u,!*a2k list('x,i));
   z:=makeset sacar('u,u);
   for k:=1:mm do if member(k,list!-m) then
   z:=(!*a2k list('u,k)) . z;
   foreach x in makeset z do w:=addf(w,
   multf(!*k2f !*a2k append(x,list i),car difff(u,x)));
   return numr simp prepf addf(v,w);
   end$

 symbolic procedure zeta!* u$
 if not get('deq,'kvalue) and (eqn(mm,0) or eqn(nn,0)) then
 rederr"Number of variables not defined" else
 if length u geq 3 then
   begin scalar v,w;
   prload();
   if eqn(nn,0) then nn:=find!-n list!-deq;
   v:=totder(numr zeta!* reverse cdr reverse u,car reverse u);
   for s:=1:nn do w:=addf(w,
   multf(!*k2f !*a2k('u . append(reverse cdr reverse u,list s)),
   totder(!*k2f !*a2k list('xi,s),car reverse u)));
   return simp prepsq(addf(v,negf w) ./ 1);
   end else
   begin scalar v,w;
   prload();
   if eqn(nn,0) then
   <<nn :=find!-n list!-deq; mm:=find!-m list!-deq>> else
     begin scalar p,z;
     for k:=1:mm do z:=cons(k,z);
     for k:=1:nn do p:=(!*a2k list('x,k)) . p;
     for k:=1:mm do p:=(!*a2k list('u,k)) . p;
     for k:=1:nn do mkdep((!*a2k list('xi,k)) . p);
     for k:=1:mm do mkdep((!*a2k list('eta,k)) . p);
     list!-m:=z;
     end;
   v:=totder(!*k2f !*a2k list('eta,car u),cadr u);
   for s:=1:nn do w:=addf(w,
   multf(!*k2f !*a2k list('u,car u,s),
   totder(!*k2f !*a2k list('xi,s),car reverse u)));
   return simp prepsq(addf(v,negf w) ./ 1);
   end$

 symbolic procedure simpu u$
 !*p2q mksp(('u . (car u . reverse ordn cdr u)),1)$

 put('u,'simpfn,'simpu)$
 put('zeta,'simpfn,'zeta!*)$

 symbolic procedure coeff!-all(u,v)$
   begin scalar z;
   list!-pq:=nil;
   splitrec(u,v,1,nil);
   foreach x in list!-pq do
   z:=(ldf!-simp numr simp prepf cdr x) . z;
   return makeset z;
   end$

 symbolic procedure splitrec(u,v,p,q)$
 if domainp u then
   begin scalar y;
   p:=multf(u,p);
   if y:=assoc(q,list!-pq) then
   rplacd(y,addf(cdr y,p)) else list!-pq:=(q . p) . list!-pq;
   end else
   begin
   if eqcar(mvar u,v) and length mvar u greaterp 2
   then splitrec(lc u,v,p,(lpow u) . q)
   else splitrec(lc u,v,!*t2f(lpow(u) .* p),q);
   if red u then splitrec(red u,v,p,q);
   end$

 symbolic procedure find!-m u$
 maxl makeset foreach x in sacar('u,u) collect cadr x$

 symbolic procedure find!-n u$
   begin scalar vx,vu,wx,wu;
   vx:=makeset sacar('x,u);
   vu:=makeset sacar('u,u);
   foreach x in vx do wx:=(cadr x) . wx;
   foreach x in vu do if length x geq 3 then
   wu:=append(cddr x,wu);
   return max(maxl wx,maxl wu);
   end$

 %*******************************************************************$
 %           Procedures for solving the determining system           $
 %*******************************************************************$

 symbolic procedure rule0$
 %Searches for equations of the form C(I)=0 and stores them on CZERO;
 if uhf then foreach x in car uhf do
 if not red x and not eqcar(mvar x,'df)
 then czero:=(mvar x) . czero$

 symbolic procedure rule1$
 %Searches for equations of the form DF(function,variable)=0;
 %and stores it on the list RDEP;
 if uhf and car uhf then
   begin scalar dfsub;
   foreach x in car uhf do
   if not red x and eqcar(mvar x,'df) and eqn(diford mvar x,1)
   then rdep:=(mvar x) . rdep;
   if rdep then return t;
   end$

 symbolic procedure rule1!-diff$
 %Searches for equations of the form DF(function,variable)=0;
 %which may be obtained by a single differentiation and stores it on;
 %the list RDEP;
 if uhf and car uhf then
   begin scalar u,v,z;
   foreach x in car uhf do if(z:=ldf!-df!-diff x) then
   u:=append(z,u);
   foreach x in u do if eqn(diford x,1) then v:=x . v;
   rdep:=makeset v;
   if rdep then return t;
   end$

 symbolic procedure rulec l$
 %Searches for equations of length L which may be solved for a;
 %function and stores the corresponding rules on CSUB;
 if uhf and car uhf then
   begin scalar v;
   foreach u in car uhf do if leqgrt(length u,l,4)
   and (v:=ldf!-sub!-var u) and not smember(v,csub)
   and not inter(foreach x in csub collect car x,ldf!-fvar u)
   then csub:=(v . prepsq caar solvef(u,v)) . csub;
   if csub then return t;
   end$

 symbolic procedure ruledf l$
 %Searches for equations of the form DF(function,derivative list)=0;
 %the derivative beeing of order L and stores the resulting;
 %substitution polynomial on CSUB;
 if uhf and car uhf then
   begin scalar dfsub;
   foreach x in car uhf do
   if not red x and eqcar(mvar x,'df) and eqn(diford mvar x,l)
   and not smember(ldf!-mvar x,dfsub) then dfsub:=(mvar x) . dfsub;
   csub:=foreach x in dfsub collect(cadr x) . crepol x;
   if csub then return t;
   end$

 symbolic procedure ruledf!-diff l$
 %Searches for all equations of the form;
 %DF(function,derivative list)=0 which may be obtained by;
 %differentiation, picks out those of order L and stores;
 %the corresponding substitution polynomial on CSUB;
 if uhf and car uhf then
   begin scalar v,dfsub;
   foreach u in car uhf do v:=append(v,ldf!-df!-diff u);
   if not(v:=makeset v) then return;
   foreach x in v do if eqn(diford x,l) then dfsub:=x . dfsub;
   if not dfsub then return;
   csub:=((cadar dfsub) . crepol car dfsub) . csub;
   if csub then return t;
   end$

 symbolic procedure rule!-int l$
 %Searches for an equation of length L which may be solved for a;
 %function after beeing integrated and stores the corresponding;
 %rule on CSUB;
 if uhf and car uhf then
   begin scalar v,w;
   foreach u in car uhf do if not csub and leqgrt(length u,l,4)
   and (v:=ldf!-sub!-var(w:=ldf!-int u))
   then csub:=list(v . prepsq caar solvef(w,v));
   if csub then return t;
   end$

 symbolic procedure simpsys0$
 %Removes variable which are stored on list CZERO;
   begin scalar u,v;
   if pclass=2 then<<write"Entering SIMPSYS0"; terpri2()>>;
   u:=delnil foreach x in car uhf collect ldf!-subf0 x;
   v:=foreach x in cadr uhf collect ldf!-subf0 numr x ./ denr x;
   uhf:=list(makeset u,v);
   if pclass=1 then
     begin
     terpri2();
     if eqn(length czero,1) then
     write"Substitution" else write"Substitutions";
     terpri();
     foreach x in czero do
     algebraic write (lisp aeval x),":=0";
     terpri();
     end;
   if pclass=2 then<<write"CZERO:="; prettyprint czero; terpri()>>;
   czero:=nil;
   if pclass=2 then<<write"Leaving SIMPSYS0"; terpri2()>>;
   end$

 symbolic procedure simpsys!-rdep$
 %Removes dependencies which are stored on list RDEP;
   begin scalar u,v;
   if pclass=2 then<<write"Entering SIMPSYS!-RDEP"; terpri2()>>;
   foreach x in rdep do rmdep cdr x;
   u:=makeset delnil foreach x in car uhf collect ldf!-simp x;
   v:=foreach x in cadr uhf collect simp prepsq x;
   uhf:=list(u,v);
   if pclass=1 then
     begin
     terpri();
     write"Dependencies removed"; terpri2();
     foreach x in rdep do
     <<maprin cadr x; prin2!*" independent of ";
       maprin caddr x; terpri!* t;>>;
     terpri();
     end;
   if pclass=2 then<<write"RDEP:='"; prettyprint rdep; terpri()>>;
   if pclass=2 then<<write"Leaving SIMPSYS!-RDEP"; terpri2()>>;
   end$

 symbolic procedure simpsys!-sep$
 %Performs all possible separations;
 if uhf and car uhf then
   begin scalar u,v,test;
   if pclass=2 then<<write"Entering SIMPSYS!-SEP"; terpri2()>>;
   foreach x in car uhf do
   if eqn(length(v:=ldf!-sep x),1) then u:=x . u else
     begin
     u:=append(v,u);
     if pclass=1 or pclass=2 then
       begin scalar z; integer l;
       terpri();
       l:=length car uhf-length member(x,car uhf)+1;
       write"Equation ",l," separated into the terms";
       terpri();
       if pclass=1 then for k:=1:length v do
         begin
         z:=prepf nth(v,k);
         !*list := lengthf z geq 50;
         algebraic write"Term   ",k,"  ",z;
         end;
       if pclass=2 then foreach y in v do prettyprint y;
       end;
     test:=t;
     end;
   !*list := nil;
   if test then uhf:=list(reverse makeset u,cadr uhf);
   if pclass=2 then<<write"Leaving SIMPSYS!-SEP"; terpri2()>>;
   end$

 symbolic procedure simpsys!-sub$
 %Performs all substitutions which are stored on CSUB;
 if uhf and car uhf then
   begin scalar u,v;
   if pclass=2 then<<write"Entering SIMPSYS!-SUB"; terpri2()>>;
   if pclass=1 then prrule csub;
   if pclass=2 then<<write"CSUB:='"; prettyprint csub; terpri()>>;
   u:=makeset delnil foreach x in car uhf collect
   ldf!-simp numr subf(x,csub);
   v:=foreach x in cadr uhf collect subsq(x,csub);
   uhf:=list(u,v);
   csub:=nil;
   if pclass=2 then<<write"Leaving SIMPSYS!-SUB"; terpri2()>>;
   end$

 symbolic procedure simpsys$
 if not uhf then
 rederr"The determining system is not defined" else
 if not car uhf then
 rederr"The determining system completely solved" else
   begin scalar u,v; integer nfun;
   prload();
   u:=makeset delnil foreach x in car uhf collect ldf!-simp x;
   v:=foreach x in cadr uhf collect simp prepsq x;
   uhf:=list(u,v);
   mark0:
   if pclass=1 then<<prsys!*"Entering main loop">> else
   if pclass=2 then prtlist"Entering main loop";
   czero:=csub:=rdep:=nil;
   simpsys!-sep();
   rule0();
   if czero then<<simpsys0(); go to mark0>>;
   if rule1() or rule1!-diff() then<<simpsys!-rdep(); go to mark0>>;
   if ruledf 2 or rulec 2 or rule!-int 2 or ruledf!-diff 2
   or ruledf 3 or rulec 3 or rule!-int 3 or ruledf!-diff 3
   or ruledf 4 or rulec 4 or rule!-int 4 or ruledf!-diff 4
   or ruledf 5 or rulec 5 or rule!-int 5 or ruledf!-diff 5
   then <<simpsys!-sub(); go to mark0>>;
   if car uhf then
   <<write"Determining system is not completely solved";
     terpri2(); prsys!*"The remaining equations are";
     if not zerop(nfun:=find!-nfun()) then
     write"Number of functions is ",nfun>>;
   end$

 symbolic procedure crepol u$
   begin scalar l1,f; integer pow,nfun;
   nfun:=find!-nfun();
   l1:=cdr assoc(car(u:=cdr u),depl!*);
   while (u:=cdr u) do
     begin scalar v;
     v:=car u;
     if  length u=1 or not numberp cadr u then pow:=1 else
     <<pow:=cadr u; u:=delete(pow,u);>>;
     for k:=1:pow do
       begin scalar w;
       w:=!*a2k list('c,nfun:=nfun+1);
       mkdep(w . delete(v,l1));
       if k=1 then f:=w  . f;
       if k=2 then f:=list('times,w,v) . f;
       if k geq 3 then
       f:=list('times,w,list('expt,v,k-1)) . f;
       end;
     end;
   return append('(plus),f);
   end$

 %*************************************************************$
 %     Procedures  for  analysing the result                   $
 %*************************************************************$

 symbolic procedure cpar u$
   begin scalar v;
   v:=makeset appends(sacar('xi,u),sacar('eta,u),sacar('c,u));
   foreach x in v do if not assoc(x,depl!*) then v:=delete(x,v);
   return v;
   end$

 symbolic procedure makeset!-c!-x u$
 if not u then nil else
 if member!-c!-x(car u,cdr u) then makeset!-c!-x cdr u else
 car u . makeset!-c!-x cdr u$

 symbolic procedure member!-c!-x(u,v)$
 if not v then nil else
 if equal!-c!-x(u,car v) then v else member!-c!-x(u,cdr v)$

 symbolic procedure equal!-c!-x(u,v)$
   begin scalar p,q;
   p:=scar('c,u) or scar('xi,u) or scar('eta,u);
   q:=scar('c,v) or scar('xi,v) or scar('eta,v);
   return equal(subst('cxx,p,u),subst('cxx,q,v));
   end$

 symbolic procedure numgen$ length get('gen,'kvalue)$

 symbolic operator numgen$

 symbolic procedure gengen$
   begin scalar u,z,cgen,dgen; integer ngen;
   remprop('gen,'kvalue); remprop('gen,'klist);
   foreach x in cadr uhf do u:=append(ldf!-fvar numr x,u);
   foreach x in makeset u do
     begin scalar v,w;
     w:=nil ./ 1;
     if assoc(x,depl!*) then
     v:=foreach y in cadr uhf collect
     simp prepsq(ldf!-fvar!-part(numr y,x) ./denr y) else
     v:=foreach y in cadr uhf collect
     simp prepsq((lcf ldf!-fvar!-part(numr y,x)) ./denr y);
     for k:=1:nn do if numr nth(v,k) then
     w:=addsq(multsq(nth(v,k),!*k2q !*a2k list('dx,k)),w);
     for k:=1:mm do if numr nth(v,nn+k) then
     w:=addsq(multsq(nth(v,nn+k),!*k2q !*a2k list('du,k)),w);
     if assoc(x,depl!*) then
     cgen:=(absf remfacn numr simp prepf numr  w) . cgen else
     dgen:=(absf remfacn numr simp prepf numr w) . dgen;
     end;
   dgen:=makeset dgen; cgen:=makeset!-c!-x cgen;
   num!-dgen:=length dgen; num!-cgen:=length cgen;
   for k:=1:nn do if member(z:=!*k2f !*a2k list('dx,k),dgen) then
   <<setk(list('gen,ngen:=add1 ngen),prepf z); dgen:=delete(z,dgen)>>;
   for k:=1:mm do if member(z:=!*k2f !*a2k list('du,k),dgen) then
   <<setk(list('gen,ngen:=add1 ngen),prepf z); dgen:=delete(z,dgen)>>;
   dgen:=sortx(function length,dgen);
   foreach x in dgen do setk(list('gen,ngen:=add1 ngen),prepf x);
   cgen:=sortx(function length,cgen);
   foreach x in cgen do setk(list('gen,ngen:=add1 ngen),prepf x);
   end$

 symbolic operator gengen$

 algebraic procedure comm(a,b)$
   begin scalar z;
   if (lisp length list!-deq)=0 then
   <<write"Differential equations not defined"; return nil>>;
   z:= (for k:=1:nn sum df(a,dx k)*df(b,x k)-df(b,dx k)*df(a,x k))
   +(for k:=1:mm sum df(a,du k)*df(b,u k)-df(b,du k)*df(a,u k))$
   return z;
   end$

 algebraic procedure result$
   begin integer l;
   if (l:=lisp length list!-deq)=1 then
   write"The differential equation" else
   write"The differential equations";
   for j:=1:l do
     begin scalar z; integer i,k;
     lisp(z:=car cadadr nth(list!-deq,j));
     i:=lisp cadar nth(list!-deq,j);
     k:=lisp lengthf prepf z;
     symbolic(!*list := k>40);
     write"DEQ(",i,"):=",lisp prepf z;
     end;
   !*list := nil;
   if (lisp length car uhf) neq 0  then
   prsys!*"The determining system is not completely solved" else
   <<lisp gengen(); prgen(); comm!-tab()>>;
   end$

 %*************************************************************$
 %     Procedures  for  displaying the output                  $
 %*************************************************************$

 symbolic procedure prsys!* u$
 if uhf and car uhf then
 <<terpri(); write u; terpri(); prsys(); terpri()>>$

 symbolic procedure prsys$
   begin scalar v;
   terpri();
   remprop('gl,'kvalue); remprop('gl,'klist);
   for k:=1:length car uhf do
     begin scalar z; integer l;
     z:=prepf nth(car uhf,k);
     l:=lengthf prepf nth(car uhf,k);
     !*list := l>50;
     algebraic write"GL(",k,"):=",z;
     setk(list('gl,k),z);
     end;
   terpri2();
   write"The remaining dependencies";
   terpri2();
   v:=makeset
   appends(sacar('xi,car uhf),sacar('eta,car uhf),sacar('c,car uhf));
   foreach x in v do write!-dep x;
   !*list := nil;
   end$

 symbolic procedure prrule u$
   begin
   terpri2();
   if eqn(length u,1) then
   write"Substitution" else write"Substitutions";
   terpri2();
   foreach x in u do
   <<maprin car x; prin2!*" = "; maprin cdr x; terpri!* t;>>;
   terpri();
   foreach x in u do foreach y in sacar('c,cdr x) do write!-dep y;
   end$

  symbolic procedure prtlist u$
  <<write u; terpri2(); write"DEPL!*:='"; prettyprint depl!*;
    write"UHF:='"; prettyprint uhf>>$

 symbolic procedure write!-df!-sub$
 if get('df,'kvalue) then
   begin scalar w;
   w:=get('df,'kvalue);
   remprop('df,'kvalue);
   terpri();
   if length w=1 then write"Constraint" else write"Constraints";
   terpri2();
   foreach x in w do
     begin scalar u,v;
     u:=car x;
     v:=cadadr x;
     algebraic write lisp u,":=",lisp prepsq v;
     terpri2();
     end;
   put('df,'kvalue,w);
   end$

 algebraic procedure prgen$
   begin scalar lcpar;
   for k:=1:nn do <<order dx k; factor dx k>>;
   for k:=1:mm do factor du k$
   lisp(lcpar:=cpar get('gen,'kvalue));
   write"The symmetry generators are";
   for k:=1:numgen() do
   if (lisp lengthf reval list('gen,k)) leq 60 then
   <<symbolic(!*list := nil); write"GEN(",k,"):=",gen k>> else
     begin scalar z; integer r,s,nt; operator gen!*;
     nt:=lisp length(z:=numr simp reval list('gen,k));
     r:=lisp maxl foreach x in z collect abs comfacn list x;
     if r=1 then r:=0 else r:=lisp flatsizec r;
     for l:=1:nt do gen!* l:=lisp prepf list nth(z,l);
     for l:=1:nt do
       begin
       symbolic(!*list := lengthf prepf tc nth(z,l) geq 56);
       s:=lisp abs comfacn list nth(z,l);
       if r=0 then s:=0 else
       if s=1 then s:=-1 else s:=lisp flatsizec s;
       if l=1 then write"GEN(",k,"):=",lisp blanks(r-s+1),gen!* 1 else
       if minus!-f gen!* l=t then
       write lisp blanks(r-s+6),gen!* l else
       write lisp blanks(r-s+6)," + ",gen!* l;
       end;
     clear gen!*;
     symbolic(!*list := nil);
     end;
   if (lisp length lcpar) neq 0 then
   <<write"The remaining dependencies"; lisp terpri()>>;
   for k:=1:(lisp length lcpar) do
   <<lisp write!-dep nth(lcpar,k);>>;
   if (lisp length lcpar) neq 0 then lisp terpri();
   lisp write!-df!-sub();
   end$

 algebraic procedure comm!-tab$
 if (lisp num!-dgen) geq 2 then
   begin integer nd; scalar v;
   nd:=lisp num!-dgen;
   write"The non-vanishing commutators of the finite subgroup";
   for i:=1:nd-1 do for j:=(i+1):nd do
   if(v:=comm(gen i,gen j)) neq 0 then
   if (lisp lengthf reval v) leq 60 then
   <<symbolic(!*list := nil); write"COMM(",i,",",j,"):= ",v>> else
     begin integer r,s,nt; scalar z; operator gen!*;
     nt:=lisp length(z:=numr simp reval v);
     r:=lisp maxl foreach x in z collect abs comfacn list x;
     if r=1 then r:=0 else r:=lisp flatsizec r;
     for i:=1:nt do gen!* i:=lisp prepf list nth(z,i);
     for l:=1:nt do
       begin
       symbolic(!*list := lengthf reval list('gen!*,l) geq 63);
       s:=lisp abs comfacn list nth(z,l);
       if r=0 then s:=0 else
       if s=1 then s:=-1 else s:=lisp flatsizec s;
       if l=1 then
       write"COMM(",i,",",j,"):=",lisp blanks(r-s+1),gen!* 1 else
       if minus!-f gen!* l=t then
       write lisp blanks(r-s+9),gen!* l else
       write lisp blanks(r-s+9)," + ",gen!* l;
       end;
     clear gen!*;
     end;
   symbolic(!*list := nil);
   end$

 symbolic procedure write!-dep u$
 if assoc(reval u,depl!*) then
   begin scalar v;
   v:=cdr assoc(u,depl!*);
   write car u,"(",cadr u,") depends on ";
   write caar v,"(",cadar v,")";
   foreach x in cdr v do write",",car x,"(",cadr x,")";
   terpri2();
   end$

 symbolic operator write!-dep$

 symbolic procedure find!-nfun$
 if not get('c,'klist) then 0 else
 maxl makeset foreach x in get('c,'klist) collect cadar x$

endmodule;


end;

Added r33/symget.dat version [43b2e36117].













































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
% symget.dat
 
(load symget)
(setq &symgetsize& 32)
(null (progn
(install-symget 'opmtch      1)  % get pseudo gets
(install-symget 'stat        2)
(install-symget 'infix       3)
(install-symget 'newnam      4)
(install-symget 'array       5)
(install-symget 'alt         6)
(install-symget 'polyfn      7)
(install-symget 'specprn     8)
(install-symget 'dname       9)
(install-symget 'avalue     10)
(install-symget 'formfn     11)
(install-symget 'initl      12)
(install-symget 'psopfn     13)
(install-symget 'rtype      14)
(install-symget 'prifn      15)
(install-symget 'rvalue     16)
(install-symget 'pprifn     17)
(install-symget 'dimension  18)
(install-symget 'simpfn     19)
(install-symget 'klist      20)
(install-symget 'rtypefn    21)
(install-symget 'idvalfn    22)
(install-symget 'kvalue     23)
(install-symget 'switch*    24)
(install-symget 'onep       25)
(install-symget 'zerop      26)
(install-symget 'plus       27)
(install-symget 'times      28)
(install-symget 'quotient   29)
(install-symget 'id2        30)
(install-symget 'intequivfn 31)
                               %   true flags
(install-symflag 'share      0)
(install-symflag 'full       1)
(install-symflag 'nary       2)
(install-symflag 'noncom     3)
(install-symflag 'nospur     4)
(install-symflag 'symmetric  5)
(install-symflag 'opfn       6)
(install-symflag 'nochange   7)
(install-symflag 'nodel      8)
(install-symflag 'noform     9)
(install-symflag 'field     10)
(install-symflag 'delim     11)
(install-symflag 'intfn     12)
(install-symflag 'noncom    13)
(install-symflag 'modefn    14)
(install-symflag 'convert   15)
))

Added r33/util.red version [60e5a7157d].







































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
module cedit; % REDUCE input string editor.

% Author: Anthony C. Hearn;

fluid '(!*mode);

global '(!$eol!$
         !*blanknotok!*
         !*eagain
         !*full
         crbuf!*
         crbuf1!*
         crbuflis!*
         esc!*
         inputbuflis!*
         rprifn!*
         rterfn!*
         statcounter);


%esc!* := intern ascii 125;   %this is system dependent and defines
                              %a terminator for strings.

symbolic procedure rplacw(u,v);
   if atom u or atom v then errach list('rplacw,u,v)
    else rplacd(rplaca(u,car v),cdr v);

symbolic procedure cedit n;
   begin scalar x,ochan;
      if null terminalp() then rederr "Edit must be from a terminal";
      ochan := wrs nil;
      if n eq 'fn then x := reversip crbuf!*
       else if null n
        then if null crbuflis!*
               then <<statcounter := statcounter-1;
                      rederr "No previous entry">>
              else x := cdar crbuflis!*
       else if (x := assoc(car n,crbuflis!*))
        then x := cedit0(cdr x,car n)
       else <<statcounter := statcounter-1;
              rederr list("Entry",car n,"not found")>>;
      crbuf!* := nil;
      x := for each j in x collect j;   %to make a copy.
      terpri();
      editp x;
      terpri();
      x := cedit1 x;
      wrs ochan;
      if x eq 'failed then nil else crbuf1!* := x
   end;

symbolic procedure cedit0(u,n);
   % Returns input string augmented by appropriate mode.
   begin scalar x;
      if not(x := assoc(n,inputbuflis!*)) or ((x := cddr x) eq !*mode)
        then return u
       else return append(explode x,append(cdr explode '! ,u))
   end;

symbolic procedure cedit1 u;
   begin scalar x,y,z;
      z := setpchar '!>;
      if not !*eagain
        then <<prin2t "For help, type ?"; !*eagain := t>>;
      while u and (car u eq !$eol!$) do u := cdr u;
      u := append(u,list '! );   %to avoid 'last char' problem.
      if !*full then editp u;
    top:
      x := u;   %current pointer position.
    a:
      y := readch();   %current command.
      if y eq 'p or y eq '!p then editp x
       else if y eq 'i or y eq '!i then editi x
       else if y eq 'c or y eq '!c then editc x
       else if y eq 'd or y eq '!d then editd x
       else if y eq 'f or y eq '!f then x := editf(x,nil)
       else if y eq 'e or y eq '!e
        then <<terpri(); editp1 u; setpchar z; return u>>
       else if y eq 'q or y eq '!q then <<setpchar z; return 'failed>>
       else if y eq '!? then edith()
       else if y eq 'b or y eq '!b then go to top
       else if y eq 'k or y eq '!k then editf(x,t)
       else if y eq 's or y eq '!s then x := edits x
       else if y eq '!  and not !*blanknotok!* or y eq 'x or y eq '!x
        then x := editn x
       else if y eq '!  and !*blanknotok!* then go to a
       else if y eq !$eol!$ then go to a
       else lprim!* list(y,"Invalid editor character");
      go to a
   end;

symbolic procedure editc x;
   if null cdr x then lprim!* "No more characters"
    else rplaca(x,readch());

symbolic procedure editd x;
   if null cdr x then lprim!* "No more characters"
    else rplacw(x,cadr x . cddr x);

symbolic procedure editf(x,bool);
   begin scalar y,z;
      y := cdr x;
      z := readch();
      if null y then return <<lprim!* list(z,"Not found"); x>>;
      while cdr y and not z eq car y do y := cdr y;
      return if null cdr y then <<lprim!* list(z,"Not found"); x>>
                else if bool then rplacw(x,car y . cdr y)
                else y
   end;

symbolic procedure edith;
   <<prin2t "THE FOLLOWING COMMANDS ARE SUPPORTED:";
     prin2t "   B              move pointer to beginning";
     prin2t "   C<character>   replace next character by <character>";
     prin2t "   D              delete next character";
     prin2t "   E              end editing and reread text";
     prin2t
    "   F<character>   move pointer to next occurrence of <character>";
     prin2t
       "   I<string><escape>   insert <string> in front of pointer";
     prin2t "   K<character>   delete all chars until <character>";
     prin2t "   P              print string from current pointer";
     prin2t "   Q              give up with error exit";
     prin2t
       "   S<string><escape> search for first occurrence of <string>";
     prin2t "                      positioning pointer just before it";
     prin2t "   <space> or X   move pointer right one character";
     terpri();
     prin2t
       "ALL COMMAND SEQUENCES SHOULD BE FOLLOWED BY A CARRIAGE RETURN";
     prin2t "    TO BECOME EFFECTIVE">>;

symbolic procedure editi x;
   begin scalar y,z;
      while (y := readch()) neq esc!* do z := y . z;
      rplacw(x,nconc(reversip z,car x . cdr x))
   end;

symbolic procedure editn x;
   if null cdr x then lprim!* "NO MORE CHARACTERS"
    else cdr x;

symbolic procedure editp u;
   <<editp1 u; terpri()>>;

symbolic procedure editp1 u;
   for each x in u do if x eq !$eol!$ then terpri() else prin2 x;

symbolic procedure edits u;
   begin scalar x,y,z;
      x := u;
      while (y := readch()) neq esc!* do z := y . z;
      z := reversip z;
  a:  if null x then return <<lprim!* "not found"; u>>
       else if edmatch(z,x) then return x;
      x := cdr x;
      go to a
   end;

symbolic procedure edmatch(u,v);
   % Matches list of characters U against V. Returns rest of V if
   % match occurs or NIL otherwise.
   if null u then v
    else if null v then nil
    else if car u=car v then edmatch(cdr u,cdr v)
    else nil;

symbolic procedure lprim!* u; <<lprim u; terpri()>>;

comment Editing Function Definitions;

remprop('editdef,'stat);

symbolic procedure editdef u; editdef1 car u;

symbolic procedure editdef1 u;
   begin scalar type,x;
      if null(x := getd u) then return lprim list(u,"not defined")
       else if codep cdr x or not eqcar(cdr x,'lambda)
        then return lprim list(u,"cannot be edited");
      type := car x;
      x := cdr x;
      if type eq 'expr then x := 'de . u . cdr x
       else if type eq 'fexpr then x := 'df . u . cdr x
       else if type eq 'macro then x := 'dm . u . cdr x
       else rederr list("strange function type",type);
      rprifn!* := 'add2buf;
      rterfn!* := 'addter2buf;
      crbuf!* := nil;
      x := errorset(list('rprint,mkquote x),t,nil);
      rprifn!* := nil;
      rterfn!* := nil;
      if errorp x then return (crbuf!* := nil);
      crbuf!* := cedit 'fn;
      return nil
   end;

symbolic procedure add2buf u; crbuf!* := u . crbuf!*;

symbolic procedure addter2buf; crbuf!* := !$eol!$ . crbuf!*;

put('editdef,'stat,'rlis);

comment Displaying past input expressions;

put('display,'stat,'rlis);

symbolic procedure display u;
   % Displays input stack in reverse order.
   % Modification to reverse list added by F. Kako.
  begin scalar x,w;
      u := car u;
      x := crbuflis!*;
      terpri();
      if not numberp u then u := length x;
      while u>0 and x do
       <<w := car x . w; x := cdr x; u := u - 1>>;
      for each j in w do
       <<prin2 car j; prin2 ": "; editp cdr j; terpri()>>
  end;

endmodule;


module pretty;  % Print list structures in an indented format.

% Author: A. C. Norman, July 1978.

fluid '(bn
        bufferi
        buffero
        indblanks
        indentlevel
        initialblanks
        lmar
        pendingrpars
        rmar
        rparcount
        stack);

global '(!*quotes !*symmetric thin!*);

!*symmetric := t;
!*quotes := t;
thin!* := 5;

% This package prints list structures in an indented format that
% is intended to make them legible. There are a number of special
% cases recognized, but in general the intent of the algorithm
% is that given a list (R1 R2 R3 ...), SUPERPRINT checks if
% the list will fit directly on the current line and if so
% prints it as:
%        (R1 R2 R3 ...)
% if not it prints it as:
%        (R1
%           R2
%           R3
%           ... )
% where each sublist is similarly treated.
%


% Functions:
%   SUPERPRINTM(X,M)   print expression X with left margin M
%   PRETTYPRINT(X)     = <<superprintm(x,posn()); terpri(); terpri()>>;
%
% Flag:
%   !*SYMMETRIC        If TRUE, print with escape characters,
%                      otherwise do not (as PRIN1/PRIN2
%                      distinction). defaults to TRUE;
%   !*QUOTES           If TRUE, (QUOTE x) gets displayed as 'x.
%                      default is TRUE;
%
% Variable:
%   THIN!*             if THIN!* expressions can be fitted onto
%                      a single line they will be printed that way.
%                      this is a parameter used to control the
%                      formatting of long thin lists. default 
%                      value is 5;


symbolic procedure prettyprint x;
 << superprinm(x,posn()); %WHAT REDUCE DOES NOW;
    terpri();
    terpri();
    nil>>;

symbolic procedure superprintm(x,lmar);
  << superprinm(x,lmar); terpri(); x >>;


% From here down the functions are not intended for direct use.

% The following functions are defined here in case this package
% is called from LISP rather than REDUCE.

symbolic procedure eqcar(a,b);
    pairp a and car a eq b;

symbolic procedure spaces n;
    for i:=1:n do prin2 '! ;

% End of compatibility section.

symbolic procedure superprinm(x,lmar);
  begin
    scalar stack,bufferi,buffero,bn,initialblanks,rmar,
           pendingrpars,indentlevel,indblanks,rparcount,w;
    bufferi:=buffero:=list nil; %fifo buffer.
    initialblanks:=0;
    rparcount:=0;
    indblanks:=0;
    rmar:=linelength(nil)-3; %right margin.
    if rmar<25 then error(0,list(rmar+3,
        "Linelength too short for superprinting"));
    bn:=0; %characters in buffer.
    indentlevel:=0; %no indentation needed, yet.
    if lmar+20>=rmar then lmar:=rmar-21; %no room for specified margin.
    w:=posn();
    if w>lmar then << terpri(); w:=0 >>;
    if w<lmar then initialblanks:=lmar-w;
    prindent(x,lmar+3); %main recursive print routine.
% traverse routine finished - now tidy up buffers.
    overflow 'none; %flush out the buffer.
    return x
  end;


% Access functions for a stack entry.


smacro procedure top; car stack;
smacro procedure depth frm; car frm;
smacro procedure indenting frm; cadr frm;
smacro procedure blankcount frm; caddr frm;
smacro procedure blanklist frm; cdddr frm;
smacro procedure setindenting(frm,val); rplaca(cdr frm,val);
smacro procedure setblankcount(frm,val); rplaca(cddr frm,val);
smacro procedure setblanklist(frm,val); rplacd(cddr frm,val);
smacro procedure newframe n; list(n,nil,0);
smacro procedure blankp char; numberp car char;





symbolic procedure prindent(x,n);
% Print list x with indentation level n.
    if atom x then if vectorp x then prvector(x,n)
        else for each c in 
          (if !*symmetric
             then if stringp x then explodes x else explode x
            else explode2 x) do putch c
    else if quotep x then <<
        putch '!';
        prindent(cadr x,n+1) >>
    else begin
        scalar cx;
        if 4*n>3*rmar then << %list is too deep for sanity.
            overflow 'all;
            n:=n/8;
            if initialblanks>n then <<
                lmar:=lmar-initialblanks+n;
                initialblanks:=n >> >>;
        stack := (newframe n) . stack;
        putch ('lpar . top());
        cx:=car x;
        prindent(cx,n+1);
        if idp cx and not atom cdr x then 
            cx:=get(cx,'ppformat) else cx:=nil;
        if cx=2 and atom cddr x then cx:=nil;
        if cx='prog then <<
            putch '! ;
            prindent(car (x:=cdr x),n+3) >>;
% CX now controls the formatting of what follows:
%    nil      default action
%    <number> first few blanks are non-indenting
%    prog     display atoms as labels.
         x:=cdr x;

   scan: if atom x then go to outt;
         finishpending(); %about to print a blank.
         if cx='prog then <<
             putblank();
             overflow bufferi; %force format for prog.
             if atom car x then << % a label.
                 lmar:=initialblanks:=max(lmar-6,0);
                 prindent(car x,n-3); % print the label.
                 x:=cdr x;
                 if not atom x and atom car x then go to scan;
                 if lmar+bn>n then putblank()
                 else for i:=lmar+bn:n-1 do putch '! ;
                 if atom x then go to outt>> >>
         else if numberp cx then <<
             cx:=cx-1;
             if cx=0 then cx:=nil;
             putch '!  >>
         else putblank();
         prindent(car x,n+3);
         x:=cdr x;
         go to scan;

   outt: if not null x then <<
            finishpending();
            putblank();
            putch '!.;
            putch '! ;
            prindent(x,n+5) >>;
        putch ('rpar . (n-3));
        if indenting top()='indent and not null blanklist top() then
               overflow car blanklist top()
        else endlist top();
        stack:=cdr stack
      end;

symbolic procedure explodes x;
   %dummy function just in case another format is needed.
   explode x;

symbolic procedure prvector(x,n);
  begin
    scalar bound;
    bound:=upbv x; % length of the vector.
    stack:=(newframe n) . stack;
    putch ('lsquare . top());
    prindent(getv(x,0),n+3);
    for i:=1:bound do <<
        putch '!,;
        putblank();
        prindent(getv(x,i),n+3) >>;
    putch('rsquare . (n-3));
    endlist top();
    stack:=cdr stack
  end;

symbolic procedure putblank();
  begin
    putch top(); %represents a blank character.
    setblankcount(top(),blankcount top()+1);
    setblanklist(top(),bufferi . blanklist top());
         %remember where I was.
    indblanks:=indblanks+1
  end;




symbolic procedure endlist l;
%Fix up the blanks in a complete list so that they
%will not be turned into indentations.
     pendingrpars:=l . pendingrpars;

% When I have printed a ')' I want to mark all of the blanks
% within the parentheses as being unindented, ordinary blank
% characters. It is however possible that I may get a buffer
% overflow while printing a string of )))))))))), and so this
% marking should be delayed until I get round to printing
% a further blank (which will be a candidate for a place to
% split lines). This delay is dealt with by the list
% pendingrpars which holds a list of levels that, when
% convenient, can be tidied up and closed out.

symbolic procedure finishpending();
 << for each stackframe in pendingrpars do <<
        if indenting stackframe neq 'indent then
            for each b in blanklist stackframe do
              << rplaca(b,'! ); indblanks:=indblanks-1 >>;
% blanklist of stackframe must be non-nil so that overflow
% will not treat the '(' specially.
        setblanklist(stackframe,t) >>;
    pendingrpars:=nil >>;



symbolic procedure quotep x;
    !*quotes and
    not atom x and
    car x='quote and
    not atom cdr x and
    null cddr x;






% property ppformat drives the prettyprinter -
% prog     : special for prog only
% 1        :    (fn a1
%                  a2
%                  ... )
% 2        :    (fn a1 a2
%                  a3
%                  ... )     ;

put('prog,'ppformat,'prog);
put('lambda,'ppformat,1);
put('lambdaq,'ppformat,1);
put('setq,'ppformat,1);
put('set,'ppformat,1);
put('while,'ppformat,1);
put('t,'ppformat,1);
put('de,'ppformat,2);
put('df,'ppformat,2);
put('dm,'ppformat,2);
put('foreach,'ppformat,4); % (foreach x in y do ...) etc.


% Now for the routines that buffer things on a character by character
% basis, and deal with buffer overflow.


symbolic procedure putch c;
  begin
    if atom c then rparcount:=0
    else if blankp c then << rparcount:=0; go to nocheck >>
    else if car c='rpar then <<
        rparcount:=rparcount+1;
% format for a long string of rpars is:
%    )))) ))) ))) ))) )))   ;
        if rparcount>4 then << putch '! ; rparcount:=2 >> >>
    else rparcount:=0;
    while lmar+bn>=rmar do overflow 'more;
nocheck:
    bufferi:=cdr rplacd(bufferi,list c);
    bn:=bn+1 
  end;

symbolic procedure overflow flg;
  begin
    scalar c,blankstoskip;
%the current buffer holds so much information that it will
%not all fit on a line. try to do something about it.
% flg is one of:
%  'none       do not force more indentation
%  'more       force one level more indentation
% <a pointer into the buffer>
%               prints up to and including that character, which
%               should be a blank.
    if indblanks=0 and initialblanks>3 and flg='more then <<
        initialblanks:=initialblanks-3;
        lmar:=lmar-3;
        return 'moved!-left >>;
fblank:
    if bn=0 then <<
% No blank found - can do no more for now.
% If flg='more I am in trouble and so have to print
% a continuation mark. in the other cases I can just exit.
        if not(flg = 'more) then return 'empty;
        if atom car buffero then
% continuation mark not needed if last char printed was
% special (e.g. lpar or rpar).
            prin2 "%+"; %continuation marker.
        terpri();
        lmar:=0;
        return 'continued >>
    else <<
        spaces initialblanks;
        initialblanks:=0 >>;
    buffero:=cdr buffero;
    bn:=bn-1;
    lmar:=lmar+1;
    c:=car buffero;
    if atom c then << prin2 c; go to fblank >>
    else if blankp c then if not atom blankstoskip then <<
        prin2 '! ;
        indblanks:=indblanks-1;
% blankstoskip = (stack-frame . skip-count).
        if c eq car blankstoskip then <<
            rplacd(blankstoskip,cdr blankstoskip-1);
            if cdr blankstoskip=0 then blankstoskip:=t >>;
        go to fblank >>
      else go to blankfound
    else if car c='lpar or car c='lsquare then <<
        prin2 get(car c,'ppchar);
        if flg='none then go to fblank;
% now I want to flag this level for indentation.
        c:=cdr c; %the stack frame.
        if not null blanklist c then go to fblank;
        if depth c>indentlevel then << %new indentation.
% this level has not emitted any blanks yet.
            indentlevel:=depth c;
            setindenting(c,'indent) >>;
        go to fblank >>
    else if car c='rpar or car c='rsquare then <<
        if cdr c<indentlevel then indentlevel:=cdr c;
        prin2 get(car c,'ppchar);
        go to fblank >>
    else error(0,list(c,"UNKNOWN TAG IN OVERFLOW"));
blankfound:
    if eqcar(blanklist c,buffero) then
        setblanklist(c,nil);
% at least one entry on blanklist ought to be valid, so if I
% print the last blank I must kill blanklist totally.
    indblanks:=indblanks-1;
% check if next level represents new indentation.
    if depth c>indentlevel then <<
        if flg='none then << %just print an ordinary blank.
            prin2 '! ;
            go to fblank >>;
% here I increase the indentation level by one.
        if blankstoskip then blankstoskip:=nil
        else <<
            indentlevel:=depth c;
            setindenting(c,'indent) >> >>;
%otherwise I was indenting at that level anyway.
    if blankcount c>(thin!*-1) then << %long thin list fix-up here.
        blankstoskip:=c . ((blankcount c) - 2);
        setindenting(c,'thin);
        setblankcount(c,1);
        indentlevel:=(depth c)-1;
        prin2 '! ;
        go to fblank >>;
    setblankcount(c,(blankcount c)-1);
    terpri();
    lmar:=initialblanks:=depth c;
    if buffero eq flg then return 'to!-flg;
    if blankstoskip or not (flg='more) then go to fblank;
% keep going unless call was of type 'more'.
    return 'more; %try some more.
  end;

put('lpar,'ppchar,'!();
put('lsquare,'ppchar,'![);
put('rpar,'ppchar,'!));
put('rsquare,'ppchar,'!]);

endmodule;


module rprint;  % The Standard LISP to REDUCE pretty-printer.

% Author: Anthony C. Hearn.

fluid '(!*n buffp combuff curmark curpos orig pretop pretoprinf rmar);

global '(rprifn!* rterfn!*);

comment RPRIFN!* allows output from RPRINT to be handled differently,
        RTERFN!* allows end of lines to be handled differently;

pretop := 'op; pretoprinf := 'oprinf;

symbolic procedure rprint u;
   begin integer !*n; scalar buff,buffp,curmark,rmar,x;
      curmark := 0;
      buff := buffp := list list(0,0);
      rmar := linelength nil;
      x := get('!*semicol!*,pretop);
      !*n := 0;
      mprino1(u,list(caar x,cadar x));
      prin2ox ";";
      omarko curmark;
      prinos buff
   end;

symbolic procedure rprin1 u;
   begin scalar buff,buffp,curmark,x;
      curmark := 0;
      buff := buffp := list list(0,0);
      x := get('!*semicol!*,pretop);
      mprino1(u,list(caar x,cadar x));
      omarko curmark;
      prinos buff
   end;

symbolic procedure mprino u; mprino1(u,list(0,0));

symbolic procedure mprino1(u,v);
   begin scalar x;
        if x := atsoc(u,combuff)
          then <<for each y in cdr x do comprox y;
                 combuff := delete(x,combuff)>>;
      if numberp u and u<0 and (x := get('difference,pretop))
        then return begin scalar p;
        x := car x;
        p := (not car x>cadr v) or (not cadr x>car v);
        if p then prin2ox "(";
        prinox u;
        if p then prinox ")"
       end
       else if atom u then return prinox u
      else if not atom car u 
           then <<curmark := curmark+1;
          prin2ox "("; mprino car u; prin2ox ")";
          omark list(curmark,3); curmark := curmark-1>>
       else if x := get(car u,pretoprinf)
        then return begin scalar p;
           p := car v>0
                 and not car u
                          memq '(block procedure prog quote string);
           if p then prin2ox "(";
           apply(x,list cdr u);
           if p then prin2ox ")"
         end
       else if x := get(car u,pretop)
        then return if car x then inprinox(u,car x,v)
                     else if cddr u then rederr "Syntax error"
                     else if null cadr x then inprinox(u,list(100,1),v)
                     else inprinox(u,list(100,cadr x),v)
       else prinox car u;
      if rlistatp car u then return rlpri cdr u;
      u := cdr u;
      if null u then prin2ox "()"
      else mprargs(u,v)
   end;

symbolic procedure mprargs(u,v);
   if null cdr u then <<prin2ox " "; mprino1(car u,list(100,100))>>
   else inprinox('!*comma!* . u,list(0,0),v);

symbolic procedure inprinox(u,x,v);
   begin scalar p;
      p := (not car x>cadr v) or (not cadr x>car v);
      if p then prin2ox "("; omark '(m u);
      inprino(car u,x,cdr u);
      if p then prin2ox ")"; omark '(m d)
   end;

symbolic procedure inprino(opr,v,l);
   begin scalar flg,x;
      curmark := curmark+2;
      x := get(opr,pretop);
      if x and car x
        then <<mprino1(car l,list(car v,0)); l := cdr l; flg := t>>;
      while l do
        <<if opr eq '!*comma!* then <<prin2ox ","; omarko curmark>>
           else if opr eq 'setq
            then <<prin2ox " := "; omark list(curmark,1)>>
        else if atom car l or not opr eq get!*(caar l,'alt)
        then <<omark list(curmark,1); oprino(opr,flg); flg := t>>;
      mprino1(car l,list(if null cdr l then 0 else car v,
                          if null flg then 0 else cadr v));
         l := cdr l>>;
      curmark := curmark-2
   end;

symbolic procedure oprino(opr,b);
   (lambda x; if null x
                 then <<if b then prin2ox " "; prinox opr; prin2ox " ">>
               else prin2ox x)
   get(opr,'prtch);

symbolic procedure prin2ox u;
   <<rplacd(buffp,explode2 u);
     while cdr buffp do buffp := cdr buffp>>;

symbolic procedure explode2 u;
   % "explodes" atom U without including escape characters;
   if numberp u then explode u
    else if stringp u then reversip cdr reversip cdr explode u
    else explode21 explode u;

symbolic procedure explode21 u;
   if null u then nil
    else if car u eq '!! then cadr u . explode21 cddr u
    else car u . explode21 cdr u;

symbolic procedure prinox u;
   <<rplacd(buffp,explode u);
     while cdr buffp do buffp := cdr buffp>>;

symbolic procedure omark u;
   <<rplacd(buffp,list u); buffp := cdr buffp>>;

symbolic procedure omarko u; omark list(u,0);

symbolic procedure comprox u;
   begin scalar x;
        if car buffp = '(0 0)
          then return <<for each j in u do prin2ox j;
                        omark '(0 0)>>;
        x := car buffp;
        rplaca(buffp,list(curmark+1,3));
        for each j in u do prin2ox j;
        omark x
   end;

symbolic procedure rlistatp u;
   get(u,'stat) member '(endstat rlis);

symbolic procedure rlpri u;
   if null u then nil
    else begin
      prin2ox " ";
      omark '(m u);
      inprino('!*comma!*,list(0,0),u);
      omark '(m d)
   end;

symbolic procedure condox u;
   begin scalar x;
      omark '(m u);
      curmark := curmark+2;
      while u do
        <<prin2ox "IF "; mprino caar u; omark list(curmark,1);
          prin2ox " THEN ";
          if cdr u and eqcar(cadar u,'cond)
                 and not eqcar(car reverse cadar u,'t)
           then <<x := t; prin2ox "(">>;
          mprino cadar u;
          if x then prin2ox ")";
          u := cdr u;
          if u then <<omarko(curmark-1); prin2ox " ELSE ">>;
          if u and null cdr u and caar u eq 't
            then <<mprino cadar u; u := nil>>>>;
      curmark := curmark-2;
      omark '(m d)
   end;

put('cond,pretoprinf,'condox);

symbolic procedure blockox u;
   begin
      omark '(m u);
      curmark := curmark+2;
      prin2ox "BEGIN ";
      if car u then varprx car u;
      u := labchk cdr u;
      omark list(curmark,if eqcar(car u,'!*label) then 1 else 3);
      while u do
        <<mprino car u;
        if not eqcar(car u,'!*label) and cdr u then prin2ox "; ";
        u := cdr u;
        if u
          then omark list(curmark,
                          if eqcar(car u,'!*label) then 1 else 3)>>;
      omark list(curmark-1,-1);
      prin2ox " END";
      curmark := curmark-2;
      omark '(m d)
   end;

symbolic procedure retox u;
   begin
      omark '(m u);
      curmark := curmark+2;
      prin2ox "RETURN ";
      omark '(m u);
      mprino car u;
      curmark := curmark-2;
      omark '(m d);
      omark '(m d)
   end;

put('return,pretoprinf,'retox);

%  symbolic procedure varprx u;
%        mapc(cdr u,function (lambda j;
%                          <<prin2ox car j;
%                          prin2ox " ";
%                          inprino('!*comma!*,list(0,0),cdr j);
%                          prin2ox "; ";
%                          omark list(curmark,6)>>));

comment a version for the old parser;

symbolic procedure varprx u;
   begin scalar typ;
      u := reverse u;
       while u do
        <<if cdar u eq typ
            then <<prin2ox ","; omarko(curmark+1); prinox caar u>>
           else <<if typ then <<prin2ox "; "; omark '(m d)>>;
                prinox (typ := cdar u);
                  prin2ox " "; omark '(m u); prinox caar u>>;
           u := cdr u>>;
      prin2ox "; ";
      omark '(m d)
   end;

put('block,pretoprinf,'blockox);

symbolic procedure progox u;
   blockox(mapcar(reverse car u,function (lambda j; j . 'scalar)) 
        . cdr u);

symbolic procedure labchk u;
   begin scalar x;
      for each z in u do if atom z
        then x := list('!*label,z) . x else x := z . x;
       return reversip x
   end;

put('prog,pretoprinf,'progox);

symbolic procedure gox u;
   <<prin2ox "GO TO "; prinox car u>>;

put('go,pretoprinf,'gox);

symbolic procedure labox u;
   <<prinox car u; prin2ox ": ">>;

put('!*label,pretoprinf,'labox);

symbolic procedure quotox u;
   if stringp u then prinox u else <<prin2ox "'"; prinsox car u>>;

symbolic procedure prinsox u;
   if atom u then prinox u
    else <<prin2ox "(";
           omark '(m u);
           curmark := curmark+1;
        while u do <<prinsox car u;
                        u := cdr u;
                        if u then <<omark list(curmark,-1);
                        if atom u
                          then <<prin2ox " . "; prinsox u; u := nil>>
                         else prin2ox " ">>>>;
           curmark := curmark-1;
           omark '(m d);
        prin2ox ")">>;

put('quote,pretoprinf,'quotox);

symbolic procedure prognox u;
   begin
      curmark := curmark+1;
      prin2ox "<<";
      omark '(m u);
      while u do <<mprino car u; u := cdr u;
                if u then <<prin2ox "; "; omarko curmark>>>>;
      omark '(m d);
      prin2ox ">>";
      curmark := curmark-1
   end;

put('prog2,pretoprinf,'prognox);

put('progn,pretoprinf,'prognox);

symbolic procedure repeatox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "REPEAT ";
      mprino car u;
      prin2ox " UNTIL ";
      omark list(curmark,3);
      mprino cadr u;
      omark '(m d);
      curmark := curmark-1
   end;

put('repeat,pretoprinf,'repeatox);

symbolic procedure whileox u;
   begin
      curmark := curmark+1;
     omark '(m u);
      prin2ox "WHILE ";
      mprino car u;
      prin2ox " DO ";
      omark list(curmark,3);
      mprino cadr u;
      omark '(m d);
      curmark := curmark-1
   end;

put('while,pretoprinf,'whileox);

symbolic procedure procox u;
   begin
      omark '(m u);
      curmark := curmark+1;
      if cadddr cdr u then <<mprino cadddr cdr u; prin2ox " ">>;
      prin2ox "PROCEDURE ";
      procox1(car u,cadr u,caddr u)
   end;

symbolic procedure procox1(u,v,w);
   begin
      prinox u;
      if v then mprargs(v,list(0,0));
      prin2ox "; ";
      omark list(curmark,3);
      mprino w;
      curmark := curmark-1;
      omark '(m d)
   end;

put('proc,pretoprinf,'procox);

symbolic procedure proceox u;
   begin
      omark '(m u);
      curmark := curmark+1;
      if cadr u then <<mprino cadr u; prin2ox " ">>;
      if not caddr u eq 'expr then <<mprino caddr u; prin2ox " ">>;
      prin2ox "PROCEDURE ";
      proceox1(car u,cadddr u,car cddddr u)
   end;

symbolic procedure proceox1(u,v,w);
   begin
      prinox u;
      if v
        then <<if not atom car v then v:= for each j in v collect car j;
               %allows for typing to be included with proc arguments;
               mprargs(v,list(0,0))>>;
      prin2ox "; ";
      omark list(curmark,3);
      mprino w;
      curmark := curmark -1;
      omark '(m d)
   end;

put('procedure,pretoprinf,'proceox);

symbolic procedure proceox0(u,v,w,x);
   proceox list(u,'symbolic,v,
                mapcar(w,function (lambda j; j . 'symbolic)),x);

symbolic procedure deox u;
   proceox0(car u,'expr,cadr u,caddr u);

put('de,pretoprinf,'deox);

symbolic procedure dfox u;
   proceox0(car u,'fexpr,cadr u,caddr u);

%put('df,pretoprinf,'dfox);   %commented out because of confusion with
                              %differentiation;

symbolic procedure stringox u;
   <<prin2ox '!"; prin2ox car u; prin2ox '!">>;

put('string,pretoprinf,'stringox);

symbolic procedure lambdox u;
   begin
      omark '(m u);
      curmark := curmark+1;
      procox1('lambda,car u,cadr u)
   end;

put('lambda,pretoprinf,'lambdox);

symbolic procedure eachox u;
   <<prin2ox "FOR EACH ";
     while cdr u do <<mprino car u; prin2ox " "; u := cdr u>>;
     mprino car u>>;

put('foreach,pretoprinf,'eachox);

symbolic procedure forox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "FOR ";
      mprino car u;
      prin2ox " := ";
      mprino caadr u;
      if cadr cadr u neq 1
        then <<prin2ox " STEP "; mprino cadr cadr u; prin2ox " UNTIL ">>
       else prin2ox ":";
      mprino caddr cadr u;
      prin2ox " ";
      mprino caddr u;
      prin2ox " ";
      omark list(curmark,3);
      mprino cadddr u;
      omark '(m d);
      curmark := curmark-1
   end;

put('for,pretoprinf,'forox);

symbolic procedure forallox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "FOR ALL ";
      inprino('!*comma!*,list(0,0),car u);
      if cadr u
        then <<omark list(curmark,3);
               prin2ox " SUCH THAT ";
               mprino cadr u>>;
      prin2ox " ";
      omark list(curmark,3);
      mprino caddr u;
      omark '(m d);
      curmark := curmark-1
   end;

put('forall,pretoprinf,'forallox);


comment Declarations needed by old parser;

if null get('!*semicol!*,'op)
  then <<put('!*semicol!*,'op,'((-1 0)));
         put('!*comma!*,'op,'((5 6)))>>;


comment RPRINT MODULE, Part 2;

fluid '(orig curpos);

symbolic procedure prinos u;
   begin integer curpos;
        scalar orig;
      orig := list posn();
      curpos := car orig;
      prinoy(u,0);
      terpri0x()
   end;

symbolic procedure prinoy(u,n);
   begin scalar x;
      if car(x := spaceleft(u,n)) then return prinom(u,n)
       else if null cdr x then return if car orig<10 then prinom(u,n)
       else <<orig := 9 . cdr orig;
                terpri0x();
                spaces20x(curpos := 9+cadar u);
                prinoy(u,n)>>
      else begin
        a: u := prinoy(u,n+1);
           if null cdr u or caar u<=n then return;
           terpri0x();
           spaces20x(curpos := car orig+cadar u);
           go to a end;
      return u
   end;

symbolic procedure spaceleft(u,mark);
   %U is an expanded buffer of characters delimited by non-atom marks
   %of the form: '(M ...) or '(INT INT))
   %MARK is an integer;
   begin integer n; scalar flg,mflg;
      n := rmar - curpos;
      u := cdr u;   %move over the first mark;
      while u and not flg and n>=0 do
        <<if atom car u then n := n-1
           else if caar u eq 'm then nil
           else if mark>=caar u then <<flg := t; u := nil . u>>
           else mflg := t;
          u := cdr u>>;
      return ((n>=0) . mflg)
   end;

symbolic procedure prinom(u,mark);
   begin integer n; scalar flg,x;
      n := curpos;
      u := cdr u;
      while u and not flg do
        <<if atom car u then <<x := prin20x car u; n := n+1>>
          else if caar u eq 'm
           then if cadar u eq 'u then orig := n . orig
                 else orig := cdr orig
           else if mark>=caar u
             and not(x='!, and rmar-n-6>charspace(u,x,mark))
            then <<flg := t; u := nil . u>>;
          u := cdr u>>;
      curpos := n;
        if mark=0 and cdr u
          then <<terpri0x();
                 terpri0x();
                 orig := list 0; curpos := 0; prinoy(u,mark)>>;
          %must be a top level constant;
      return u
   end;

symbolic procedure charspace(u,char,mark);
   %determines if there is space until the next character CHAR;
   begin integer n;
      n := 0;
      while u do
        <<if car u = char then u := list nil
           else if atom car u then n := n+1
           else if car u='(m u) then <<n := 1000; u := list nil>>
           else if numberp caar u and caar u<mark then u := list nil;
          u := cdr u>>;
      return n
   end;

symbolic procedure spaces20x n;
   %for i := 1:n do prin20x '! ;
   while n>0 do <<prin20x '! ; n := n-1>>;

symbolic procedure prin2rox u;
   begin integer m,n; scalar x,y;
      m := rmar-12;
      n := rmar-1;
      while u do
        if car u eq '!"
          then <<if not stringspace(cdr u,n-!*n)
                   then <<terpri0x(); !*n := 0>>
                  else nil;
                 prin20x '!";
                 u := cdr u;
                 while not car u eq '!" do
                   <<prin20x car u; u := cdr u; !*n := !*n+1>>;
                 prin20x '!";
                 u := cdr u;
                 !*n := !*n+2;
                 x := y := nil>>
         else if atom car u and not(car u eq '!  and (!*n=0 or null x
               or cdr u and breakp cadr u or breakp x and not y eq '!!))
          then <<y := x; prin20x(x := car u); !*n := !*n+1;
         u := cdr u;
         if !*n=n or !*n>m and not breakp car u and nospace(u,n-!*n)
          then <<terpri0x(); x := y := nil>> else nil>>
         else u := cdr u
   end;

symbolic procedure nospace(u,n);
   if n<1 then t
    else if null u then nil
    else if not atom car u then nospace(cdr u,n)
    else if not car u eq '!! and (cadr u eq '!  or breakp cadr u)
     then nil
    else nospace(cdr u,n-1);

symbolic procedure breakp u;
   u member '(!< !> !; !: != !) !+ !- !, !' !");

symbolic procedure stringspace(u,n);
   if n<1 then nil else if car u eq '!" then t
    else stringspace(cdr u,n-1);


comment Some interfaces needed;

symbolic procedure prin20x u;
   if rprifn!* then apply(rprifn!*,list u) else prin2 u;

symbolic procedure terpri0x;
   if rterfn!* then apply(rterfn!*,nil) else terpri();

endmodule;


end;

Added r34.1/README version [ccdf66d6c9].









>
>
>
>
1
2
3
4
The "plot" directory seems to contain a set of files relating to
"gnuplot". They may be distributed IF UNCHANGED (and I believe that the
copies here are unaltered from the original versions).

Added r34.1/doc/addendum.tex version [a622098877].





























































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
\documentstyle[11pt]{article}

\parindent 0pt

\parskip 6pt

\raggedbottom

\newlength{\reduceboxwidth}
\setlength{\reduceboxwidth}{4in}

\newlength{\redboxwidth}
\setlength{\redboxwidth}{3.5in}

\newlength{\rboxwidth}
\setlength{\rboxwidth}{2.6in}

\newcommand{\REDUCE}{REDUCE}
\newcommand{\RLISP}{RLISP}
\newcommand{\ttindex}[1]{\index{#1@{\tt #1}}}
\newcommand{\COMPATNOTE}{{\em Compatibility Note:\ }}

% Close up default vertical spacings:
\setlength{\topsep}{0.5\baselineskip}  % above and below environments
\setlength{\itemsep}{\topsep}
\setlength{\abovedisplayskip}{\topsep}  % for "long" equations
\setlength{\belowdisplayskip}{\topsep}

\pagestyle{headings}

\begin{document}
% \pagestyle{empty}
% \vspace*{\fill}
\begin{center}

{\LARGE\bf Addendum to the \\[0.4cm]
\Huge\bf {\REDUCE}} \\[0.1cm]
{\LARGE\bf User's Manual\vspace{0.3cm} \\
for Version 3.4.1}

\vspace{0.1in}\large\bf

Anthony C.\ Hearn \\
RAND \\
Santa Monica, CA 90407-2138

\vspace{0.1in}

\bf Email: reduce@rand.org

\vspace{0.1in}

\large\bf July 1992

\vspace*{0.2in}

\end{center}

%\pagestyle{headings}
%\setcounter{page}{1}

\section{Introduction}
The major purpose of the 3.4.1 release is to correct various bugs and
deficiencies in the former version.  In addition, the following
capabilities have been augmented or changed:

\section{SOLVE}

A number of changes have been made in the {\tt SOLVE} package in order
to improve its effectiveness.

\subsection{Improved Handling of Undetermined Solutions}

The {\tt SOLVE} package has been modified so that when a solution cannot
be found, an equation for the relevant indeterminates is normally returned
in terms of a new operator {\tt ROOT\_OF}, rather than an equation in
terms of unknown expressions.  For example, the expression
\begin{verbatim}
        solve(cos(x) + log(x),x);
\end{verbatim}
now returns the result
\begin{verbatim}
        {X=ROOT_OF(COS(X_) + LOG(X_),X_)}
\end{verbatim}
rather than
\begin{verbatim}
        {COS(X) + LOG(X)=0} .
\end{verbatim}
This makes the form of the {\tt SOLVE} output much more uniform, thus
allowing for its easier manipulation by other operators.

An expression with a top-level {\tt ROOT\_OF} operator is implicitly a
list with an unknown number of elements (since we can't always know how
many solutions an equation has).  If a substitution is made into such an
expression, closed form solutions can emerge.  If this occurs, the {\tt
ROOT\_OF construct} is replaced by an operator {\tt ONE\_OF}.  At this
point it is of course possible to transform the result of the original
{\tt SOLVE} operator expression into a standard {\tt SOLVE} solution.  To
effect this, an operator {\tt EXPAND\_CASES} can be used.

The following complete example shows the use of these facilities:
\begin{verbatim}
solve({1-c*x1+x1*x2^2,
          1-c*x2+x2*x1^2},
         {x1,x2});

              3
      SQRT(4*C  + 1) + 1
{{X2=--------------------,
             2*C

                 3
       - SQRT(4*C  + 1) + 1
  X1=-----------------------},
               2*C

                 3
       - SQRT(4*C  + 1) + 1
 {X2=-----------------------,
               2*C

              3
      SQRT(4*C  + 1) + 1
  X1=--------------------},
             2*C

                              3
 {X2=ROOT_OF(C*X2____ - X2____  - 1,X2____),

  X1=X2}}

sub(c=2,ws);

      SQRT(33) + 1
{{X2=--------------,
           4

       - SQRT(33) + 1
  X1=-----------------},
             4

       - SQRT(33) + 1
 {X2=-----------------,
             4

      SQRT(33) + 1
  X1=--------------},
           4
                 1/2        1/2
              - 5    - 1   5    - 1
 {X2=ONE_OF(-------------,----------,1),
                  2           2

  X1=X2}}

expand_cases ws;

      SQRT(33) + 1       - SQRT(33) + 1
{{X2=--------------,X1=-----------------},
           4                   4

       - SQRT(33) + 1      SQRT(33) + 1
 {X2=-----------------,X1=--------------},
             4                  4

       - SQRT(5) - 1       - SQRT(5) - 1
 {X2=----------------,X1=----------------},
            2                   2

      SQRT(5) - 1      SQRT(5) - 1
 {X2=-------------,X1=-------------},
           2                2

 {X2=1,X1=1}}

\end{verbatim}

\subsection{Improved Handling of Cubics and Quartics}

Since roots of cubics and quartics can often be very messy, a switch
{\tt FULLROOTS} has been added, which, when off (the default), will
prevent the production of a result in closed form.  The {\tt ROOT\_OF}
construct will be used in this case instead.

Finally, the code for the production of solutions of cubics and quartics
has been modified so that trigonometrical forms are used where appropriate.
This option is under the control of a switch {\tt TRIGFORM}, which is
normally on.

The following example illustrates the use of these facilities:
\begin{verbatim}
let xx = solve(x^3+x+1,x);

xx;

             3
{X=ROOT_OF(X_  + X_ + 1,X_)}

on fullroots;

xx;

                           - SQRT(31)*I
                    ATAN(---------------)
                            3*SQRT(3)
{X=(I*(SQRT(3)*SIN(-----------------------)
                              3

                      - SQRT(31)*I
               ATAN(---------------)
                       3*SQRT(3)
        - COS(-----------------------)))/SQRT(3),
                         3

                              - SQRT(31)*I
                       ATAN(---------------)
                               3*SQRT(3)
 X=( - I*(SQRT(3)*SIN(-----------------------)
                                 3

                         - SQRT(31)*I
                  ATAN(---------------)
                          3*SQRT(3)
           + COS(-----------------------)))/SQRT(
                            3

      3),

                  - SQRT(31)*I
           ATAN(---------------)
                   3*SQRT(3)
    2*COS(-----------------------)*I
                     3
 X=----------------------------------}
                SQRT(3)

off trigform;

xx;

                             2/3
{X=( - (SQRT(31) - 3*SQRT(3))   *SQRT(3)*I

                             2/3    2/3
     - (SQRT(31) - 3*SQRT(3))    - 2   *SQRT(3)*I

        2/3                           1/3  1/3
     + 2   )/(2*(SQRT(31) - 3*SQRT(3))   *6

                1/6
              *3   ),

                          2/3
 X=((SQRT(31) - 3*SQRT(3))   *SQRT(3)*I

                             2/3    2/3
     - (SQRT(31) - 3*SQRT(3))    + 2   *SQRT(3)*I

        2/3                           1/3  1/3
     + 2   )/(2*(SQRT(31) - 3*SQRT(3))   *6

                1/6
              *3   ),

                           2/3    2/3
     (SQRT(31) - 3*SQRT(3))    - 2
 X=-------------------------------------}
                          1/3  1/3  1/6
    (SQRT(31) - 3*SQRT(3))   *6   *3

\end{verbatim}
\newpage
\section{New Operators}

In addition to the operators ONE\_OF and ROOT\_OF described above, the
following new operator is available in REDUCE 3.4.1:

\subsection{ROOT\_VAL Operator}

The {\tt ROOT\_VAL} operator takes a single univariate polynomial as
argument, and returns a list of root values at system precision (or
greater if required to separate roots).  It is used with the syntax
\begin{verbatim}
	ROOT_VAL(EXPRN:univariate polynomial):list.
\end{verbatim}
For example, the sequence
\begin{verbatim}
        on rounded; root_val(x^3-x-1);
\end{verbatim}
gives the result
\begin{verbatim}
        {0.562279512062*I - 0.662358978622, - 0.562279512062*I

          - 0.662358978622,1.32471795724}
\end{verbatim}

\section{New Switches}
In many cases it is desirable to expand product arguments of logarithms, or
collect a sum of logarithms into a single logarithm.  Since these are inverse
operations, it is not possible to provide rules for doing both at the same
time and preserve the {\REDUCE} concept of idempotent evaluation. As an
alternative, REDUCE 3.4.1 provides two switches {\tt EXPANDLOGS} and
{\tt COMBINELOGS} to carry out these operations.  Both are off by default.
Thus to expand {\tt LOG(X*Y)} into a sum of logs, one can say
\begin{verbatim}
        ON EXPANDLOGS; LOG(X*Y);
\end{verbatim}
and to combine this sum into a single log:
\begin{verbatim}
	ON COMBINELOGS; LOG(X) + LOG(Y);
\end{verbatim}

At the present time, it is possible to have both switches on at once,
which could lead to infinite recursion.  However, an expression is
switched from one form to the other in this case.  Users should not rely
on this behavior, since it may change in the next release.

\section{User-Contributed Library Packages}

The following packages, not directly supported by the REDUCE distributors,
are contained in the REDUCE 3.4.1 user library.  Please consult the {\tt
lib} directory for a detailed description of their functionality.  Any
questions regarding them should be directed to the relevant author(s).
\begin{itemize}

\item{ASSIST: Useful utilities for various applications} 

Author: Hubert Caprasse.

\item{CAMAL: Calculations in celestial mechanics}

Author: John P. Fitch

\item{CHANGEVAR:  Change of Independent Variable(s) in DEs}

Author: G. \"{U}\c{c}oluk

\item{CVIT: Fast Calculation of Dirac Gamma matrices traces}

Authors: V.Ilyin, A.Kryukov, A.Rodionov, A.Taranov

\item{DESIR: Differential linear homogenous Equation Solutions in the
              neighbourhood of Irregular and Regular singular points}

Authors: C. Dicrescenzo, F. Richard-Jung, E. Tournier

\item{FIDE: Finite difference method for partial differential equations}

Author: Richard Liska

\item{GNUPLOT: Using the GNUPLOT package for REDUCE graphical output}

Author: Herbert Melenk

\item{LAPLACE: Laplace and inverse Laplace transform}

Author: C. Kazasov, M. Spiridonova, V. Tomov

\item{LININEQ: Solving systems of linear inequalities}

Author: Herbert Melenk

\item{NUMERIC: Basic algorithms for numerical problems using rounded mode}

Author: Herbert Melenk

\item{PHYSOP: Package for Operator Calculus in Quantum Theory}

Author: Mathias Warns

\item{PM: A REDUCE Pattern Matcher}

Author: Kevin McIsaac

\item{REACTEQN: Support for chemical reaction equation systems}

Author: Herbert Melenk

\item{RLFI: REDUCE LATEX Formula Interface}

Author: Richard Liska

\item{SYMMETRY: Symmetry-adapted bases and block diagonal forms
of symmetric matrices}

Author: Karin Gatermann

\item{TRI: TeX REDUCE Interface}

Author: Werner Antweiler

\item{WU: Wu Algorithm for polynomial systems}

Author: Russell Bradford

\end{itemize}
\end{document}

Added r34.1/doc/arnum.bib version [286098fe49].











































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
% Bibliography entry for arnum.tex.

@INPROCEEDINGS{Bradford:86,
  AUTHOR = "R. J. Bradford and A. C. Hearn and J. A. Padget and E.
            Schr{\"u}fer",
  TITLE = "Enlarging the {REDUCE} Domain of Computation",
  BOOKTITLE = "Proceedings of {SYMSAC} '86", YEAR = 1986,
  PAGES = "100-106"}

@INPROCEEDINGS{Trager:76,
  AUTHOR = "B. M. Trager",
  TITLE = "Algebraic Factoring and Rational Function Integration",
  BOOKTITLE = "Proceedings of {SYMSAC} '76",
  YEAR = 1976, PAGES = "196-208"}

@INCOLLECTION{Davenport:81,
  AUTHOR = "James Harold Davenport",
  TITLE = "On the Integration of Algebraic Functions",
  BOOKTITLE = "Lecture Notes in Computer Science",
  PUBLISHER = "Springer Verlag",
  VOLUME = 102, YEAR = 1981}

Added r34.1/doc/arnum.tex version [280481b037].

































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
\documentstyle[11pt,reduce]{article}
\title{Algebraic Number Fields}
\date{}
\author{Eberhard Schr\"{u}fer \\
GMD, Institut F1   \\
Postfach 1240      \\
5205 St. Augustin  \\
GERMANY       \\[0.05in]
Email: schrufer@gmdzi.gmd.de}
\begin{document}
\maketitle

\index{algebraic number fields}
\index{algebraic numbers}
\index{ARNUM package}
Algebraic numbers are the solutions of an irreducible polynomial over
some ground domain.  \index{i} The algebraic number $i$ (imaginary
unit), \index{imaginary unit} for example, would be defined by the
polynomial $i^2 + 1$.  The arithmetic of algebraic number $s$ can be
viewed as a polynomial arithmetic modulo the defining polynomial.

Given a defining polynomial for an algebraic number $a$
\begin{eqnarray*}
a^n ~ + ~ {p _{n-1}} {a ^ {n -1}} ~ + ~ ... ~ + ~ {p_0}
\end{eqnarray*}

All algebraic numbers which can be built up from $a$ are then of the form:
\begin{eqnarray*}
{r_{n-1}} {a ^{n-1}} ~+~ {r_{n-2}} {a ^{n-2}} ~+~ ... ~+~ {r_0}
\end{eqnarray*}
where the $r_j$'s are rational numbers.

\index{+ ! algebraic numbers}
The operation of addition is defined by
\begin{eqnarray*}
({r_{n-1}} {a ^{n-1}} ~+~ {r_{n-2}} {a ^{n-2}} ~+~ ...) ~ + ~
({s_{n-1}} {a ^{n-1}} ~+~ {s_{n-2}} {a ^{n-2}} ~+~ ...) ~ =  \\
({r_{n-1}+s_{n-1}}) {a ^{n-1}} ~+~ ({r_{n-2}+s_{n-2}}) {a ^{n-2}} ~+~ ...
\end{eqnarray*}

\index{* ! algebraic numbers}
Multiplication of two algebraic numbers can be performed by normal
polynomial multiplication followed by a reduction of the result with the
help of the defining polynomial.

\begin{eqnarray*}
({r_{n-1}} {a ^{n-1}} + {r_{n-2}} {a ^{n-2}} + ...) ~ \times ~
({s_{n-1}} {a ^{n-1}} + {s_{n-2}} {a ^{n-2}} + ...) = \\
 {r_{n-1}} {s ^{n-1}}{a^{2n-2}} +  ... ~ {\bf modulo} ~
a^n ~ + ~ {p _{n-1}} {a ^ {n -1}} ~ + ~ ... ~ + ~ {p_0} \\
= ~~~{q_{n-1}} a^{n-1} ~ + ~ {q _{n-2}} {a ^ {n -2}} ~ + ~ ...
\end{eqnarray*}

\index{/ ! algebraic numbers}
Division of two algebraic numbers r and s yields another algebraic number q.

$ \frac{r}{s} = q$ or $ r = q s $.

The last equation written out explicitly reads

\begin{eqnarray*}
\lefteqn{({r_{n-1}} {a^{n-1}} + {r_{n-2}} {a^{n-2}} + \ldots)} \\
& = & ({q_{n-1}} {a^{n-1}} + {q_{n-2}} {a^{n-2}} + \ldots) \times
({s_{n-1}} {a^{n-1}} + {s_{n-2}} {a^{n-2}} + \ldots) \\
& & {\bf modulo} (a^n + {p _{n-1}} {a^{n -1}} + \ldots) \\
& = & ({t_{n-1}} {a^{n-1}} + {t_{n-2}} {a^{n-2}} + \ldots)
\end{eqnarray*}

The $t_i$ are linear in the $q_j$.  Equating equal powers of $a$ yields a
linear system for the quotient coefficients $q_j$.

With this, all field operations for the algebraic numbers are available.  The
translation into algorithms is straightforward.  For an implementation we
have to decide on a data structure for an algebraic number.  We have chosen
the representation REDUCE normally uses for polynomials, the so-called
standard form.  Since our polynomials have in general rational coefficients,
we must allow for a rational number domain inside the algebraic number.

\begin{tabbing}
\s{algebraic number} ::= \\
\hspace{.25in} \= {\tt :ar:} . \s{univariate polynomial over the rationals}
\\[0.05in]

\s{univariate polynomial over the rationals} ::= \\
\> \s{variable} .** \s{ldeg} .* \s{rational} .+ \s{reductum} \\[0.05in]

\s{ldeg} ::= integer \\[0.3in]

\s{rational} ::= \\
\> {\tt :rn:} . \s{integer numerator} . \s{integer denominator} :
integer \\[0.05in]

\s{reductum} ::= \s{univariate polynomial} : \s{rational} : nil
\end{tabbing}

This representation allows us to use the REDUCE functions for adding and
multiplying polynomials on the tail of the tagged algebraic number.  Also,
the routines for solving linear equations can easily be used for the
calculation of quotients.  We are still left with the problem of
introducing a particular algebraic number.  In the current version this is
done by giving the defining polynomial to the statement {\bf defpoly}.  The
\index{DEFPOLY statement}
algebraic number sqrt(2), for example, can be introduced by
\begin{verbatim}
   defpoly sqrt2**2 - 2;
\end{verbatim}

This statement associates a simplification function for the
translation of the variable in the defining polynomial into its tagged
internal form and also generates a power reduction rule used by the
operations {\bf times} and {\bf quotient} for the reduction of their
result modulo the defining polynomial.  A basis for the representation
of an algebraic number is also set up by the statement.  In the
working version, the basis is a list of powers of the indeterminate of
the defining polynomial up to one less then its degree.  Experiments
with integral bases, however, have been very encouraging, and these
bases might be available in a later version.  If the defining
polynomial is not monic, it will be made so by an appropriate
substitution.

\example \index{ARNUM package ! example}

\begin{verbatim}
     defpoly sqrt2**2-2;

     1/(sqrt2+1);

     SQRT2 - 1

     (x**2+2*sqrt2*x+2)/(x+sqrt2);

     X + SQRT2

     on gcd;

     (x**3+(sqrt2-2)*x**2-(2*sqrt2+3)*x-3*sqrt2)/(x**2-2);

       2
     (X  - 2*X - 3)/(X - SQRT2)

     off gcd;

     sqrt(x**2-2*sqrt2*x*y+2*y**2);

     X - SQRT2*Y
\end{verbatim}

Until now we have dealt with only a single algebraic number.  In practice
this is not sufficient as very often several algebraic numbers appear in an
expression.  There are two possibilities for handling this: one can use
multivariate extensions \cite{Davenport:81} or one can construct a defining
polynomial that contains all specified extensions.  This package implements
the latter case (the so called primitive representation).  The algorithm we
use for the construction of the primitive element is the same as given by
Trager \cite{Trager:76}.  In the implementation, multiple extensions can be
given as a list of equations to the statement {\bf defpoly}, which, among other
things, adds the new extension to the previously defined one.  All
algebraic numbers are then expressed in terms of the primitive element.


\example\index{ARNUM package ! example}

\begin{verbatim}
   defpoly sqrt2**2-2,cbrt5**3-5;

   *** defining polynomial for primitive element:

     6       4        3        2
   A1  - 6*A1  - 10*A1  + 12*A1  - 60*A1 + 17

   sqrt2;

             5             4              3              2
   48/1187*A1  + 45/1187*A1  - 320/1187*A1  - 780/1187*A1  +


   735/1187*A1 - 1820/1187

   sqrt2**2;

   2
\end{verbatim}
\newpage
We can provide factorization of polynomials over the algebraic number
domain by using Trager's algorithm.  The polynomial to be factored is first
mapped to a polynomial over the integers by computing the norm of the
polynomial, which is the resultant with respect to the primitive element of
the polynomial and the defining polynomial.  After factoring over the
integers, the factors over the algebraic number field are recovered by GCD
calculations.

\example\index{ARNUM package ! example}

\begin{verbatim}
   defpoly a**2-5;

   x**2 + x - 1;

   (X + (1/2*A + 1/2))*(X - (1/2*A - 1/2))
\end{verbatim}
\index{SPLIT\_FIELD function}
We have also incorporated a function {\bf split\_field} for the calculation
of a primitive element of minimal degree for which a given polynomial splits
into linear factors.  The algorithm as described in Trager's article is
essentially a repeated primitive element calculation.

\example\index{ARNUM package ! example}

\begin{verbatim}
   split!_field(x**3-3*x+7);

   *** Splitting field is generated by:

     6        4        2
   A5  - 18*A5  + 81*A5  + 1215



            4          2
   {1/126*A5  - 5/42*A5  - 1/2*A5 + 2/7,


              4          2
    - (1/63*A5  - 5/21*A5  + 4/7),


           4          2
   1/126*A5  - 5/42*A5  + 1/2*A5 + 2/7}


   for each j in ws product (x-j);

    3
   X  - 3*X + 7
\end{verbatim}

A more complete description can be found in \cite{Bradford:86}.
\bibliography{arnum}
\bibliographystyle{plain}
\end{document}

Added r34.1/doc/avector.tex version [3c536e94ab].













































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
\documentstyle[11pt,reduce]{article}
\date{}
\title{A Vector Algebra and Calculus Package for REDUCE}
\author{David Harper \\
Astronomy Unit \\
Queen Mary and Westfield College \\
University of London \\
Mile End Road \\
London E1 4NS \\
England \\[0.05in]
Electronic mail: {\it adh@star.qmw.ac.uk}}
\begin{document}
\maketitle

\index{AVECTOR package}

\section{Introduction}

This package \footnote{Reference: Computer Physics Communications,
{\bf 54}, 295-305 (1989)}
is written in RLISP (the LISP meta-language) and is
intended for use with REDUCE 3.4. \index{vector algebra} It provides
REDUCE with the ability to perform vector algebra using the same
notation as scalar algebra.  The basic algebraic operations are
supported, as are differentiation and integration of vectors with
respect to scalar variables, cross product and dot product, component
manipulation and application of scalar functions ({\em e.g.} cosine)
to a vector to yield a vector result.

A set of vector calculus operators are provided for use with any
orthogonal curvilinear coordinate system. These operators are
gradient, divergence, curl and del-squared (Laplacian).  The Laplacian
operator can take scalar or vector arguments.

Several important coordinate systems are pre-defined and can be
invoked by name. It is also possible to create new coordinate systems
by specifying the names of the coordinates and the values of the scale
factors.

\section{Vector declaration and initialisation}

Any name may be declared to be a vector, provided that it has
not previously been declared as a matrix or an array. To
declare a list of names to be vectors use the VEC command:
\index{VEC command}
\begin{verbatim}
   VEC A,B,C;
\end{verbatim}
declares the variables {\tt A}, {\tt B} and {\tt C} to be vectors.
If they have already been assigned (scalar) values, these will be lost.

When a vector is declared using the {\tt VEC} command, it does not
have an initial value.

If a vector value is assigned to a scalar variable, then that
variable will automatically be declared as a vector and the
user will be notified that this has happened.

\index{AVEC function}
A vector may be initialised using the {\tt AVEC} function which
takes three scalar arguments and returns a vector made up
from those scalars. For example
\begin{verbatim}
   A := AVEC(A1, A2, A3);
\end{verbatim}
sets the components of the vector {\tt A} to {\tt A1}, {\tt A2} and {\tt A3}.

\section{Vector algebra}

(In the examples which follow, {\tt V}, {\tt V1}, {\tt V2} {\em etc}
are assumed to be vectors while {\tt S}, {\tt S1}, {\tt S2} etc are scalars.)

\index{+ ! vector} \index{- ! vector} \index{* ! vector} \index{/ ! vector}
The scalar algebra operators +,-,* and / may be used with
vector operands according to the rules of vector algebra.
Thus multiplication and division of a vector by a scalar
are both allowed, but it is an error to multiply or
divide one vector by another.

\begin{tabular}{l l}
{\tt V := V1 + V2 - V3;} & Addition and subtraction \\
{\tt V := S1*3*V1;} & Scalar multiplication \\
{\tt V := V1/S;} & Scalar division \\
{\tt V := -V1;} & Negation \\
\end{tabular}

\index{DOT ! vector} \index{dot product} \index{CROSS ! vector}
\index{cross product}
\noindent Vector multiplication is carried out using the infix
operators {\tt DOT} and {\tt CROSS}. These are defined to have
higher precedence than scalar multiplication and
division.

\begin{tabular}{l l}
{\tt V := V1 CROSS V2;} & Cross product \\
{\tt S := V1 DOT V2;} & Dot product \\
{\tt V := V1 CROSS V2 + V3;} & \\
{\tt V := (V1 CROSS V2) + V3;} & \\
\end{tabular}

The last two expressions are equivalent due to the precedence of
the {\tt CROSS} operator.

\index{VMOD operator}
The modulus of a vector may be calculated using the {\tt VMOD} operator.

\begin{verbatim}
   S := VMOD V;
\end{verbatim}

A unit vector may be generated from any vector using the {\tt VMOD}
operator.

\begin{verbatim}
   V1 := V/(VMOD V);
\end{verbatim}

Components may be extracted from any vector using index notation
in the same way as an array.

\begin{tabular}{l l}
{\tt V := AVEC(AX, AY, AZ);} & \\
{\tt V(0);} & yields AX \\
{\tt V(1);} & yields AY \\
{\tt V(2);} & yields AZ \\
\end{tabular}

It is also possible to set values of individual components. Following
from above:

\begin{verbatim}
   V(1) := B;
\end{verbatim}

The vector {\tt V} now has components {\tt AX}, {\tt B}, {\tt AZ}.

\index{vector ! differentiation} \index{vector | integration}
\index{differentiation ! vector} \index{differentiation ! vector}
Vectors may be used as arguments in the differentiation and
integration routines in place of the dependent expression.

\begin{tabular}{l l}
{\tt V := AVEC(X**2, SIN(X), Y);} & \\
{\tt DF(V,X);} & yields (2*X, COS(X), 0) \\
{\tt INT(V,X);} & yields (X**3/3, -COS(X), Y*X) \\
\end{tabular}

Vectors may be given as arguments to monomial functions such as {\tt
SIN}, {\tt LOG} and {\tt TAN}. The result is a vector obtained by
applying the function component-wise to the argument vector.

\begin{tabular}{l l}
{\tt V := AVEC(A1, A2, A3);} & \\
{\tt SIN(V);} & yields (SIN(A1), SIN(A2), SIN(A3)) \\
\end{tabular}

\section{ Vector calculus}

\index{DIV ! operator} \index{divergence ! vector field}
\index{GRAD ! operator} \index{gradient ! vector field}
\index{CURL ! operator} \index{curl ! vector field}
\index{DELSQ ! operator} \index{Laplacian ! vector field}
The vector calculus operators div, grad and curl are recognised.
The Laplacian operator is also available and may be applied to
scalar and vector arguments.

\begin{tabular}{l l}
{\tt V := GRAD S;} & Gradient of a scalar field \\
{\tt S := DIV V;} & Divergence of a vector field \\
{\tt V := CURL V1;} & Curl of a vector field \\
{\tt S := DELSQ S1;} & Laplacian of a scalar field \\
{\tt V := DELSQ V1;} & Laplacian of a vector field \\
\end{tabular}

These operators may be used in any orthogonal curvilinear coordinate
system. The user may alter the names of the coordinates and the values
of the scale factors. Initially the coordinates are {\tt X}, {\tt Y}
and {\tt Z} and the scale factors are all unity.

\index{COORDS vector} \index{HFACTORS scale factors}
There are two special vectors : {\tt COORDS} contains the names
of the coordinates in the current system and {\tt HFACTORS}
contains the values of the scale factors.

\index{COORDINATES operator}
The coordinate names may be changed using the {\tt COORDINATES}
operator.

\begin{verbatim}
   COORDINATES R,THETA,PHI;
\end{verbatim}

This command changes the coordinate names to {\tt R}, {\tt THETA} and
{\tt PHI}.

\index{SCALEFACTORS operator}
The scale factors may be altered using the {\tt SCALEFACTORS} operator.

\begin{verbatim}
   SCALEFACTORS(1,R,R*SIN(THETA));
\end{verbatim}

This command changes the scale factors to {\tt 1}, {\tt R} and {\tt R
SIN(THETA)}.

Note that the arguments of {\tt SCALEFACTORS} must be enclosed in
parentheses. This is not necessary with {\tt COORDINATES}.


When vector differential operators are applied to an expression,
the current set of coordinates are used as the independent
variables and the scale factors are employed in the calculation.
(See, for example, Batchelor G.K. 'An Introduction to Fluid
Mechanics', Appendix 2.)


\index{"!*CSYSTEMS global (AVECTOR)}
Several coordinate systems are pre-defined and may be invoked by
name. To see a list of valid names enter

\begin{verbatim}
   SYMBOLIC !*CSYSTEMS;
\end{verbatim}

and REDUCE will respond with something like

\begin{verbatim}
   (CARTESIAN SPHERICAL CYLINDRICAL)
\end{verbatim}

\index{GETCSYSTEM command}
To choose a coordinate system by name, use the command {\tt GETCSYSTEM}.

To choose the Cartesian coordinate system :
\begin{verbatim}
   GETCSYSTEM 'CARTESIAN;
\end{verbatim}
\index{PUTCSYSTEM command}

Note the quote which prefixes the name of the coordinate system. This
is required because {\tt GETCSYSTEM} (and its complement {\tt
PUTCSYSTEM}) is a {\tt SYMBOLIC} procedure which requires a literal
argument.

REDUCE responds by typing a list of the coordinate names in that
coordinate system. The example above would produce the response

\begin{verbatim}
   (X Y Z)
\end{verbatim}

whilst

\begin{verbatim}
   GETCSYSTEM 'SPHERICAL;
\end{verbatim}

would produce

\begin{verbatim}
   (R THETA PHI)
\end{verbatim}

Note that any attempt to invoke a coordinate system is subject to the
same restrictions as the implied calls to {\tt COORDINATES} and {\tt
SCALEFACTORS}.  In particular, {\tt GETCSYSTEM} fails if any of the
coordinate names has been assigned a value and the previous coordinate
system remains in effect.

A user-defined coordinate system can be assigned a name using the
command {\tt PUTCSYSTEM}. It may then be re-invoked at a later stage using
{\tt GETCSYSTEM}.

\example\index{AVECTOR package ! example}

We define a general coordinate system with coordinate names {\tt
X},{\tt Y},{\tt Z} and scale factors {\tt H1},{\tt H2},{\tt H3} :

\begin{verbatim}
   COORDINATES X,Y,Z;
   SCALEFACTORS(H1,H2,H3);
   PUTCSYSTEM 'GENERAL;
\end{verbatim}

This system may later be invoked by entering

\begin{verbatim}
   GETCSYSTEM 'GENERAL;
\end{verbatim}

\section{Volume and Line Integration}

Several functions are provided to perform volume and line integrals.
These operate in any orthogonal curvilinear coordinate system and
make use of the scale factors described in the previous section.


Definite integrals of scalar and vector expressions may be calculated
using the {\tt DEFINT} function.

\example\index{AVECTOR package ! example}

\index{DEFINT function} \index{integration ! definite (simple)}
\index{definite integration (simple)}
\noindent To calculate the definite integral of $\sin(x)^2$ between 0 and
2$\pi$ we enter

\begin{verbatim}
   DEFINT(SIN(X)**2,X,0,2*PI);
\end{verbatim}

This function is a simple extension of the {\tt INT} function taking
two extra arguments, the lower and upper bounds of integration
respectively.

\index{VOLINTEGRAL function} \index{integration ! volume}
Definite volume integrals may be calculated using the {\tt
VOLINTEGRAL} function whose syntax is as follows :

\noindent {\tt VOLINTEGRAL}({\tt integrand}, vector {\tt lower-bound},
vector {\tt upper-bound});

\example\index{AVECTOR package ! example}

\noindent In spherical polar coordinates we may calculate the volume of a
sphere by integrating unity over the range $r$=0 to {\tt RR}, $\theta$=0 to
{\tt PI}, $\phi$=0 to 2*$\pi$ as follows :

\begin{tabular}{l l}
{\tt VLB := AVEC(0,0,0);} & Lower bound \\
{\tt VUB := AVEC(RR,PI,2*PI);} & Upper bound in $r, \theta, \phi$
 respectively \\
{\tt VOLINTORDER := (0,1,2);} & The order of integration \\
{\tt VOLINTEGRAL(1,VLB,VUB);} & \\
\end{tabular}

\index{VOLINTORDER vector}
Note the use of the special vector {\tt VOLINTORDER} which controls
the order in which the integrations are carried out. This vector
should be set to contain the number 0, 1 and 2 in the required order.
The first component of {\tt VOLINTORDER} contains the index of the
first integration variable, the second component is the index of the
second integration variable and the third component is the index of
the third integration variable.

\example\index{AVECTOR package ! example}

Suppose we wish to calculate the volume of a right circular cone. This
is equivalent to integrating unity over a conical region with the
bounds:

\begin{tabular}{l l}
z = 0 to H  & (H = the height of the cone) \\
r = 0 to pZ & (p = ratio of base diameter to height) \\
phi = 0 to 2*PI & \\
\end{tabular}

We evaluate the volume by integrating a series of infinitesimally thin
circular disks of constant z-value. The integration is thus performed
in the order : d($\phi$) from 0 to $2\pi$, dr from 0 to p*Z, dz from 0 to H.
The order of the indices is thus 2, 0, 1.

\begin{verbatim}
   VOLINTORDER := AVEC(2,0,1);
   VLB := AVEC(0,0,0);
   VUB := AVEC(P*Z,H,2*PI);
   VOLINTEGRAL(1,VLB,VUB);
\end{verbatim}

(At this stage, we replace {\tt P*H} by {\tt RR}, the base radius of the cone,
to obtain the result in its more familiar form.)


\index{LINEINT function} \index{DEFLINEINT function}
\index{integration ! line} \index{line integrals}
Line integrals may be calculated using the {\tt LINEINT} and {\tt DEFLINEINT}
functions. Their general syntax is

\noindent {\tt LINEINT}({\tt vector-function}, {\tt vector-curve},
{\tt variable});

\noindent{\tt DEFLINENINT}({\tt vector-function}, {\tt vector-curve},
{\tt variable}, {\tt lower-bound}, {\tt upper-bound});

\noindent where
\begin{description}
\item[{\tt vector-function}] is any vector-valued expression;
\item[{\tt vector-curve}] is a vector expression which describes the path of
integration in terms of the independent variable;
\item[{\tt variable}] is the independent variable;
\item[{\tt lower-bound}]
\item[{\tt upper-bound}] are the bounds of integration in terms of the
independent variable.
\end{description}

\example\index{AVECTOR package ! example}

In spherical polar coordinates, we may integrate round a line of
constant theta (`latitude') to find the length of such a line. The
vector function is thus the tangent to the `line of latitude', (0,0,1)
and the path is {\tt (0,LAT,PHI)} where {\tt PHI} is the independent
variable. We show how to obtain the definite integral {\em i.e.} from
$\phi=0$ to $2 \pi$ :
\begin{verbatim}
DEFLINEINT(AVEC(0,0,1),AVEC(0,LAT,PHI),PHI,0,2*PI);
\end{verbatim}

\section{Defining new functions and procedures}

Most of the procedures in this package are defined in symbolic mode
and are invoked by the REDUCE expression-evaluator when a vector
expression is encountered. It is not generally possible to define
procedures which accept or return vector values in algebraic mode.
This is a consequence of the way in which the REDUCE interpreter
operates and it affects other non-scalar data types as well : arrays
cannot be passed as algebraic procedure arguments, for example.

\section{Acknowledgements}

This package was written whilst the author was the U.K. Computer
Algebra Support Officer at the University of Liverpool Computer Laboratory.
\end{document}

Added r34.1/doc/bibl.bib version [11899c1328].























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
%                          REDUCE BIBLIOGRAPHY

%                              Part 1:  A-F

% Copyright (c) 1991 RAND.  All Rights Reserved.

% Additions and corrections are solicited.  Please send them, in the
% same format as these entries if possible, to reduce at rand.org.


@ARTICLE{Abbott:85,
 AUTHOR = "J. A. Abbott and R. J. Bradford and J. H. Davenport",
 TITLE = "A Remark on Factorisation",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 2, PAGES = "31-33", MONTH = "May"}

@INPROCEEDINGS{Abbott:86,
 AUTHOR = "J. A. Abbott and R. J. Bradford and J. H. Davenport",
 TITLE = "The {Bath} Algebraic Number Package",
 BOOKTITLE = "Proc. of {SYMSAC} '86",
 YEAR = 1986, PAGES = "250-253"}

@INPROCEEDINGS{Abbott:87,
 AUTHOR = "J. A. Abbott and J. H. Davenport",
 TITLE = "Polynomial Factorization: An Exploration of {Lenstra's}
Algorithm",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "391-402",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{Abbott:87a,
 AUTHOR = "J. A. Abbott",
 TITLE = "Integration: Solving the {Risch} Differential Equation",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "465-467",
 PUBLISHER = "Springer-Verlag"}

@PHDTHESIS{Abbott:88,
 AUTHOR = "J. A. Abbott",
 TITLE = "Factorisation of Polynomials over Algebraic Number Fields",
 SCHOOL = "Univ. of Bath, England",
 YEAR = 1988}

@ARTICLE{Abbott:88a,
 AUTHOR = "J. A. Abbott and J. H. Davenport",
 TITLE = "A Remark on a Paper by {Wang}: Another Surprising Property of 42",
 JOURNAL = "Math. Comp.",
 YEAR = 1988, VOLUME = 51, PAGES = "837-839"}

@INPROCEEDINGS{Abbott:89,
 AUTHOR = "J. A. Abbott",
 TITLE = "Recovery of Algebraic Numbers from their p-Adic Approximations",
 BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York",
 YEAR = 1989, PAGES = "112-120"}

@TECHREPORT{Abbott:89a,
 AUTHOR = "J. A. Abbott and R. J. Bradford and J. H. Davenport",
 TITLE = "A Remark on the Multiplication of Sparse Polynomials",
 NUMBER = "TR 89-21", YEAR = 1989,
 INSTITUTION = "School of Mathematical Sciences, University of Bath"}

@INPROCEEDINGS{Abdali:88,
 AUTHOR = "S. K. Abdali and D. S. Wise",
 TITLE = "Experiments with Quadtree Representation of Matrices",
 BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag",
 YEAR = 1988, VOLUME = 358, PAGES = "96-108"}

@ARTICLE{Abiezzi:83,
 AUTHOR = "Salim S. {Abi-Ezzi}",
 TITLE = "Clarification to the Symbolic Mode in {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1983, VOLUME = 17, NUMBER = "3 and 4", PAGES = "43-47",
 MONTH = "August and November"}

@INPROCEEDINGS{Abramov:91,
 AUTHOR = "S. A. Abramov and K. Yu. Kvansenko",
 TITLE = "Fast Algorithms to Search for the Rational Solutions of Linear
Differential Equations with Polynomial Coefficients",
 EDITOR = "Stephen M. Watt",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", YEAR = 1991,
 PAGES = "267-270"}

@TECHREPORT{Abramov:91a,
 AUTHOR = "S. A. Abramov and K. Yu. Kvashenko",
 TITLE = "Fast search of a certain type solutions of linear ordinary
differential equations with polynomial coefficients",
 INSTITUTION = "Computer Center of the USSR, Academy of Science, Moscow",
 YEAR = 1991}

@InProceedings{Adamchik90,
  author =      "V. S. Adamchik and O. I. Marichev",
  title =       "The Algorithm for calculating Integrals of
                 Hypergeometric type functions and its realization in
                 {REDUCE} System",
  booktitle =   "Proceedings of the 1990 International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "212-224",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@ARTICLE{Adams:83,
 AUTHOR = "K. J. Adams",
 TITLE = "Analytic Estimates for the Dynamic Aperture of Nonlinear Lattices",
 JOURNAL = "IEEE Trans. Nucl. Sci.",
 YEAR = 1983, VOLUME = "NS-30", PAGES = "2436-2438",
 COMMENT = {"For an accelerator lattice{\ldots}" {REDUCE} was used to obtain low
order coefficients in the calculation of the amplitude.}}

@ARTICLE{Adkins:83,
 AUTHOR = "G. S. Adkins",
 TITLE = "Analytic Evaluation of an {O}($\alpha$) Vertex Correction to the
Rate of Orthopositronium",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1983, VOLUME = 27,  PAGES = "530-532",
 ABSTRACT = {The order-$\alpha$ correction to the lowest order
orthopositronium decay rate due to the two outer-vertex graphs obtained in
analytic form.}}

@ARTICLE{Adkins:83a,
 AUTHOR = "G. S. Adkins and  F. R. Brown",
 TITLE = "Rate for Positronium Decay to Five Photons",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1983, VOLUME = 28, PAGES = "1164-1165",
 COMMENT = {{REDUCE} used to calculate trace of $\gamma$ matrices.  Large
calculation.}}

@ARTICLE{Adkins:85,
 AUTHOR = "G. S. Adkins",
 TITLE = "Inner-Vertex Contributions to the Decay Rate of Orthopositronium",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1985, VOLUME = 31, PAGES = "1250-1252",
 COMMENT = {{REDUCE} trace calculations.  "In this paper the order-$\alpha$
contribution to the inner-vertex graphs to the decay rate of
orthopositronium is obtained in analytic form."}}

@ARTICLE{Aguilera-Navarro:87,
 AUTHOR = "V. C. Aguilera-Navarro and  R. Guardiola and C. Keller and
M. de Llano and M. Popovic and M. Fortes",
 TITLE = "Van der {Waals} Perturbation Theory for Fermion and Boson
Ground-State Matter",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1987, VOLUME = 35, PAGES = "3901-3910",
 COMMENT = {Uses computer algebra to rearrange ideal-gas-based low-density
expansions; to them {REDUCE} or {MACSYMA} provide just the expertise they
require to substitute forms into equations, and so makes their
formulation possible.}}

@TECHREPORT{Akselrod:90,
 AUTHOR = "I.R. Akselrod and V.P. Gerdt and V.E. Kovtun and V.N. Robuk",
 TITLE = "Construction of a {Lie} algebra by a subset of generators and
commutation relations",
 INSTITUTION = "J.I.N.R.", YEAR = 1990, TYPE = "Preprint",
 NUMBER = "E5-90-508",
 ABSTRACT = {The problem of constructing the quotient algebra for a free
{Lie} algebra over an ideal given by a subset of generators and commutation
relations is investigated.  The method proposed to solve this problem can be
applied in particular for constructing a {L-A} pair for nonlinear evolution
equations.  The algorithm is based on the concept of {Hall} basis for a
free {Lie} algebra and is implemented in the computer algebra system
{REDUCE}.}}

@ARTICLE{Aldins:69,
 AUTHOR = "J. Aldins and S. J. Brodsky and A. J. Dufner and
T. Kinoshita",
 TITLE = "Photon-Photon Scattering Contribution to the Sixth
Order Magnetic Moments of the Muon and Electron",
 JOURNAL = "Phys. Rev. Lett.",
 YEAR = 1969, VOLUME = 23, PAGES = "441-443"}

@TECHREPORT{Alekseev:86,
 AUTHOR = "A. I. Alekseev and V. F. Edneral",
 TITLE = "Tensor Structure of Axial Gauge Polarization Operator in the
Infrared Region",
 INSTITUTION = "IHEP", YEAR = 1986, TYPE = "Preprint",
 NUMBER = "86-46"}

@ARTICLE{Alekseev:87,
 AUTHOR = "A. I. Alekseev and V. F. Edneral",
 TITLE = "Tensor Structure of Gluon Polarization Operator in the
Axial Gauge for Infra-Red Region",
 JOURNAL = "Journal of Nuclear Physics",
 YEAR = 1987, PAGES = "1105-1114"}

@TECHREPORT{Alekseev:87a,
 AUTHOR = "A. I. Alekseev and V. F. Edneral",
 TITLE = "On Evaluation of {Feynman} Integrals in Axial Gauge",
 INSTITUTION = "IHEP", YEAR = 1987, TYPE = "Preprint",
 NUMBER = "87-118",
 ABSTRACT = {The recurrent algorithm for axial gauge calculations of
one-loop massless {Feynman} integrals in the n-dimensional
momentum space is described.  The algorithm we suggest is
realized on the basis of {REDUCE} system and presented as
a procedure.  It is rather effective for cumbersome
combinations of those integrals.}}

@ARTICLE{Alfeld:82,
 AUTHOR = "P. Alfeld",
 TITLE = "Fixed Point Iteration with Inexact Function Values",
 JOURNAL = "Math. Comp.",
 YEAR = 1982, VOLUME = 38, PAGES = "87-98",
 COMMENT = {Numerical analysis generating an improved iterative scheme.
"The technical manipulations in this paper were carried out using the
symbol manipulation language {REDUCE}."}}

@TECHREPORT{Amirkhanov:87,
 AUTHOR = "I. V. Amirkhanov and E. P. Zhydkov and I. E. Zhydkova",
 TITLE = "The Conditions of Bounding of the Oscillation Amplitudes of
Charge Particle within the Resonance Vicinity Investigations",
 INSTITUTION = "J.I.N.R., Dubna", YEAR = 1987, NUMBER = "P11-87-452"}

@INPROCEEDINGS{Amirkhanov:91,
 AUTHOR = "I.V. Amirkhanov and E.P. Zhidkov and I.E. Zhidkova",
 TITLE = "The Betatron Oscillations in the Vicinity of Nonlinear Resonance
in Cyclic Accelerator Investigation",
 EDITOR = "Stephen M. Watt",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", YEAR = 1991,
 PAGES = "452-453"}

@ARTICLE{Antweiler:89,
 AUTHOR = "Werner Antweiler and Andreas Strotmann and Volker Winkelmann",
 TITLE = "A {\TeX-{REDUCE}-Interface}",
 JOURNAL = "SIGSAM Bulletin",
 YEAR = 1989, VOLUME = 23,
 MONTH = "February", PAGES = "26-33"}

@ARTICLE{Appelquist:70,
 AUTHOR = "T. W. Appelquist and S. J. Brodsky",
 TITLE = "The Order $\alpha^{2}$ Electrodynamic Corrections to
the {Lamb} Shift",
 JOURNAL = "Phys. Rev. Letters",
 YEAR = 1970, VOLUME = 24, PAGES = "562-565"}

@TECHREPORT{Arbuzov:86,
 AUTHOR = "B. A. Arbuzov and E. E. Boos and A. I. Davydychev",
 TITLE = "Infrared Asymptotics of Gluonic {Green} Functions
in Covariant Gauge",
 INSTITUTION = "IHEP", YEAR = 1986, TYPE = "Preprint",
 NUMBER = "86-123"}

@ARTICLE{Aso:81,
 AUTHOR = "T. Aso and T. Nonoyama and S. Kato",
 TITLE = "Numerical Simulation of Semidiurnal Atmospheric Tides",
 JOURNAL = "J. Geophysical R.",
 YEAR = 1981, VOLUME = 86, NUMBER = 11, PAGES = "388-400",
 COMMENT = {"Numerical modeling of the solar and lunar semidiurnal
atmospheric tides has been performed by invoking a comprehensive approach that
includes both algebraic manipulation and numerical solution of the
primitive equation system."  Used {REDUCE} to overcome difficulties of
complication and error.}}

@ARTICLE{Atherton:73,
 AUTHOR = "R. W. Atherton and G. M. Homsey",
 TITLE = "Use of Symbolic Computation to Generate Evolution
Equations and Asymptotic Solutions to Elliptic Equations",
 JOURNAL = "Journ. Comp. Phys.",
 YEAR = 1973, VOLUME = 1, PAGES = "45-59"}

@ARTICLE{Aurenche:84,
 AUTHOR = "P. Aurenche and A. Douir and R. Baier and M. Fontannaz and
D. Schiff",
 TITLE = "Photoproduction of Hadrons at Large Transverse Momentum in
Second Order {QCD}",
 JOURNAL = "Phys. Lett.",
 YEAR = 1984, VOLUME = "135B", PAGES = "164-168",
 COMMENT = {Uses {REDUCE} and {SCHOONSCHIP} in the extension of calculations
to a higher order to keep pace with experimental results.}}

@ARTICLE{Aurenche:84a,
 AUTHOR = "P. Aurenche and A. Douir and R. Baier and M. Fontannaz and
D. Schiff",
 TITLE = "Prompt Photon Production at Large $p_{\tau}$ in {GCD} Beyond the
Leading Order",
 JOURNAL = "Phys. Lett.",
 YEAR = 1984, VOLUME = "140B", PAGES = "87-92",
 COMMENT = {Uses {REDUCE} and {SCHOONSCHIP}.}}

@ARTICLE{Autin:89,
 AUTHOR = "B. Autin and J. Bengtsson",
 TITLE = "Symbolic Evaluation of Integrals Occurring in Accelerator
Orbit Theory",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1989, VOLUME = 7, NUMBER = 2, PAGES = "183-187", MONTH = "February"}

@ARTICLE{Baekler:84,
 AUTHOR = "P. Baekler and F. W. Hehl",
 TITLE = "A Charged {Taub-NUT} Metric with Torsion:  A New Axially
Symmetric Solution of the {Poincar\'{e}} Gauge Field Theory",
 JOURNAL = "Phys. Lett.",
 YEAR = 1984, VOLUME = "100A", PAGES = "277-316"}

@TECHREPORT{Baekler:84a,
 AUTHOR = "Peter Baekler and Friedrich W. Hehl",
 TITLE = "On the Dynamics of the Torsion of Spacetime:
Exact Solutions in a Gauge Theoretical Model of Gravity",
 INSTITUTION = "Department of Physics, University of California,
Los Angeles", YEAR = 1984,
 NUMBER = "UCLA/84/TEP/19", PAGE = "18", MONTH = "December"}

@INPROCEEDINGS{Baekler:86,
 AUTHOR = "P. Baekler and F. W. Hehl and E. W. Mielke",
 TITLE = "Nonmetricity and Torsion:  Facts and Fancies in Gauge
Approaches to Gravity",
 EDITOR = "R. Ruffini",
 BOOKTITLE = "Proc. 4th Marcel Grossmann Meeting on
General Relativity, ed.", PUBLISHER = "North-Holland, Amsterdam",
 YEAR = 1986, PAGES = "277-316"}

@ARTICLE{Baekler:87,
 AUTHOR = "P. Baekler and R. Hecht and F. W. Hehl and T. Shirafuji",
 TITLE = "Mass and Spin of Exact Solutions of the {Poincar{\'e}} Gauge
Theory",
 JOURNAL = "Prog. Theor. Phys.",
 YEAR = 1987, VOLUME = 78, PAGES = "16-21"}

@ARTICLE{Baekler:87a,
 AUTHOR = "P. Baekler and M. Guerses",
 TITLE = "Exact Solutions of the {Poincar{\'e}} Gauge Theory from Its
Linearized Field Equations",
 JOURNAL = "Lett. Math. Phys.",
 YEAR = 1987, VOLUME = 14, PAGES = "185-191"}

@ARTICLE{Baekler:87b,
 AUTHOR = "P. Baekler and E. W. Mielke and F. W. Hehl",
 TITLE = "Kinky Torsion in a {Poincar{\'e}} Gauge Model of Gravity Coupled
to a Massless Scalar Field",
 JOURNAL = "Nuclear Phys.",
 YEAR = 1987, VOLUME = "B288", PAGES = "800-812"}

@ARTICLE{Baekler:88,
 AUTHOR = "P. Baekler and M. Seitz and V. Winkelmann",
 TITLE = "Cylindrically Symmetric Solutions of Self-Consistently
Coupled {Dirac} Fields in Gauge Theories of Gravity",
 JOURNAL = "Class. Quantum Grav.",
 YEAR = 1988, VOLUME = 5, PAGES = "479-490"}

@ARTICLE{Baekler:88a,
 AUTHOR = "P. Baekler and M. Guerses and F. W. Hehl and J. D. McCrea",
 TITLE = "The Exterior Gravitational Field of a Charged Spinning
Source in the {Poincar{\'e}} Gauge Theory:  A {Kerr-Newman} Metric with
Dynamic Torsion",
 JOURNAL = "Phys. Lett.",
 YEAR = 1988, VOLUME = "A128", PAGES = "245-250"}

@ARTICLE{Baekler:88b,
 AUTHOR = "P. Baekler and M. Guerses and F. W. Hehl",
 TITLE = "A New Method to Solve the Field Equations of {Poincar{\'e}}
Gauge Theories",
 JOURNAL = "Class. Quantum Grav.",
 YEAR = 1988}

@TECHREPORT{Bahrdt:90,
 AUTHOR = "J. Bahrdt and G. W{\"u}stefeld",
 TITLE = "A New Tracking Routine for Particles in Undulator and
Wiggler Fields",
 INSTITUTION = "Technischer Bericht",
 YEAR = 1990, TYPE = "Report", NUMBER = "BESSY TB Nr. 158",
 MONTH = "October",
 ABSTRACT = {In this report we present an approximated solution of the
particle motion in wiggler and undulator fields by an algebraic mapping
routine.  The solution is based on a series expansion up to the third
order in the two transversal angle coordinates and, as a third variable,
the bending radius of the particle orbit.  The wiggler and undulator fields
are represented by an expansion as suggested by K. Halbach.

The report consists of two parts.  In the first part we solve the
equations of motion by an iteration procedure, which originally was also
the first approach.  In the second part the solution is based on a Taylor
series expansion.  Both approaches are equivalent.},
ABSTRACT2 = {Beside the presentation of the solution, the main topics
discussed in the two parts are the calculation speed and accuracy of the
algebraic method in comparison to integration methods along undulator
fields, as they are typically applied in lattice design codes.

As a further result of the discussion we obtain a proper canonical mapping
routine at least as accurate but faster than typical integration routines.}}

@ARTICLE{Baier:81,
 AUTHOR = {V.N.Baier and A.G.Grozin},
 TITLE = {Inclusive quarkonium production in {$e^+ e^-$} annihilation},
 JOURNAL = {Yad. Fiz. (Sov. J. Nucl. Phys.)},
 YEAR = 1981, VOLUME = 33, NUMBER = 2, PAGES = {491-500}}

@ARTICLE{Baier:85,
 AUTHOR = {V.N.Baier and A.G.Grozin},
 TITLE = {Gluonic contributions to the exclusive amplitudes},
 JOURNAL = {Zeit. f\"ur Phys. C},
 YEAR = 1985, VOLUME = 29, PAGES = {161-165}}

@ARTICLE{Baier:90,
 AUTHOR = {V.N.Baier and A.G.Grozin},
 TITLE = {Decay {$B \to D l \bar\nu$} from {QCD} sum rules},
 JOURNAL = {Zeit. f\"ur Phys. C},
 YEAR = 1990, VOLUME = 47, PAGES = {669-675}}

@TECHREPORT{Bajla:78,
 AUTHOR = "I. Bajla and G. A. Ososkov and A. C. Hearn",
 TITLE = "The Orthogonalization Program of Polynomials
in Two Variables in {REDUCE}-2 Language",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1978, TYPE = "Report", NUMBER = "P10-11944",
 ABSTRACT = {The analytical algorithm for constructing orthogonal
polynomials in two variables, based on the {Gram-Schmidt}
orthogonalization method, is proposed.}}

@INPROCEEDINGS{Balian:78,
 AUTHOR = "R. Balian and G. Parisi and A. Voros",
 TITLE = "Quartic Oscillator",
 YEAR = 1978, MONTH = "May",
 BOOKTITLE = "Proc. of the Colloq. on Mathematical Problems in {Feynman}
Path Integrals, Marseille",
 ABSTRACT = {On the example of the semi-classical expansion for the levels
of the quartic oscillator -(d**2/dq**2)+q**4, we show how the complex WKB
method provides information about the singularities of the Borel transform
of the semi-classical series.}}

@ARTICLE{Baker:81,
 AUTHOR = "G. A. Baker and L. P. Benofy and M. Fortes and M. de Llano and
S. M. Peltier and A. Plastino",
 TITLE = "Hard-Core Square-Well Fermion",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1982, VOLUME = 26, PAGES = "3575-3588",
 COMMENT = {The mixed use of {FORTRAN} and {REDUCE}, various derivative were
calculated algebraically, but the double series was evaluated numerically.}}

@ARTICLE{Bark:78,
 AUTHOR = "Fritz H. Bark and Herman Tinoco",
 TITLE = "Stability of Plane {Poiseuille} Flow of a Dilute
Suspension of Slender Fibres",
 JOURNAL = "J. Fluid Mech.",
 YEAR = 1978, VOLUME = 87, PAGES = "321-333",
 ABSTRACT = {The linear hydrodynamic stability problem for plane {Poiseuille}
flow of a dilute suspension of rigid fibers is solved
numerically.  The constitutive equation given by {Batchelor}
is used to model the rheological properties of the suspension.
The resulting eigenvalue problem is shown to be singular.}}

@ARTICLE{Barthes-Biesel:73,
 AUTHOR = "D. Barthes-Biesel and A. Acrivos",
 TITLE = "On Computer Generated Analytic Solutions to the
Equations of Fluid Mechanics, The Case of Creeping Flows",
 JOURNAL = "Journ. Comp. Phys.",
 YEAR = 1973, VOLUME = 3, PAGES = "403-411"}

@ARTICLE{Barton:72,
 AUTHOR = "David Barton and Anthony C. Hearn",
 TITLE = "Comment on Problem \#2 - The {Y(2n)} Functions",
 JOURNAL = "SIGSAM Bulletin",
 YEAR = 1972, VOLUME = 15,
 ABSTRACT = {A compact program for the solution of {SIGSAM} Problem \#2
is presented.}}

@ARTICLE{Bateman:86,
 AUTHOR = "G. Bateman and R. G. Storer",
 TITLE = "Direct Determination of Axisymmetric Magnetohydrodynamic
Equilibrium in {Hamada} Coordinates",
 JOURNAL = "Journ. Comp. Phys.",
 YEAR = 1986, VOLUME = 64, PAGES = "161-176",
 COMMENT = {Plasma.  {"REDUCE} was used to analyse the general set of
equations for large numbers of {Fourier} harmonics {\ldots}"}}

@INPROCEEDINGS{Belkov:91,
 AUTHOR = "Alexander A. Bel'Kov and Alexander V. Lanyov",
 TITLE = "{REDUCE} Usage for Calculation of Low-Energy Process Amplitudes in
Chiral {QCD} Model",
 EDITOR = "Stephen M. Watt",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", YEAR = 1991,
 PAGES = "454-455",
 ABSTRACT = {We describe the extension of {REDUCE} capabilities for the
calculations of strong and weak meson processes within the chiral
Lagrangians with higher derivatives.  The main non-trivial difficulty is to
obtain the process amplitude from the Lagrangian, describing these
interactions.  Another one is to overcome some {REDUCE} deficiencies such
as the lack of arguments in the matrix data type as well as of some
physical operations with the particle operators.  This package of procedures
allows one to claculate the amplitudes of the strong and weak processes by
simple specifying the particles involved and their momenta.}}

@TECHREPORT{Bennett,
 AUTHOR = "J. P. Bennett and J. H. Davenport and H. M. Sauro",
 TITLE = "Solution of Some Equations in Biochemistry",
 INSTITUTION = "School of Mathematical Sciences, University of
Bath, England", NUMBER = "88-12"}

@ARTICLE{Berends:81,
 AUTHOR = "A. Berends and R. Kleiss and P. de Causmaecher and T. T. Wu",
 TITLE = "Single Bremsstrahlung Process in Gauge Theories",
 JOURNAL = "Phys. Lett.",
 YEAR = 1981, VOLUME = "103B", PAGES = "124-128",
 COMMENT = {Used {REDUCE} to calculate 25 {Feynman} diagrams to produce
theoretical results which could be checked against experiment.}}

@TECHREPORT{Berkovich:89,
 AUTHOR = "L.M. Berkovich and V.P. Gerdt and Z.T. Kostova and
M.L. Nechaevsky",
 TITLE = "Second Order Reducible Linear Differential Equations",
 INSTITUTION = "J.I.N.R., Dubna", YEAR = 1989, TYPE = "Preprint",
 NUMBER = "E5-89-141"}

@TECHREPORT{Berkovich:90,
 AUTHOR = "L.M. Berkovich and V.P. Gerdt and Z.T. Kostova and
M.L. Nechaevsky",
 TITLE = "Computer algebra generating related {2nd} order linear differential
equation",
 INSTITUTION = "J.I.N.R., Dubna", YEAR = 1990, TYPE = "Preprint",
 NUMBER = "E5-90-509",
 ABSTRACT = {An algorithm with its mathematical foundation concerning {2nd}
order ordinary linear differential equations {(OLDE)} is described.  It
allows one to generate related {four-parametric} families of {OLDE} with
coefficients of preassigned (in the scope of the procedure) structures
integrable in terms of a given (generating) equation.  The number of those
families in each next generation grows according to geometric progression
with ratio eight.  Several examples of both mathematical and physical
significance illustrate the efficiency of the algorithm implemented in the
{REDUCE} compute algebra system.}}

@ARTICLE{Berman:63,
 AUTHOR = "S. M. Berman and Y. S. Tsai",
 TITLE = "Intermediate Boson Pair Production as a Means for
Determining its Magnetic Moment",
 JOURNAL = "Phys. Rev. Lett.",
 YEAR = 1963, VOLUME = 11, PAGES = "483-487"}

@INPROCEEDINGS{Berndt:91,
 AUTHOR = "R. Berndt and A. Lock and G. Witte and Ch. W{\"o}ll",
 TITLE = "Application of Computer Algebra to Surface Lattice Dynamics",
 EDITOR = "Stephen M. Watt",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", YEAR = 1991,
 PAGES = "433-438",
 ABSTRACT = {Lattice dynamical calculations for surfaces and in particular
for stepped and adsorbed covered surfaces are commonly hampered by the
complexity of the dynamical matrix for these systems.  We propose the use
of computer algebra programs to set up the dynamical matrix.  In the
present implementation the dynamical matrix is calculated fully analytically
within the framework of a force constant-model and partially analytically
for other interaction models such as the shell model or the bond charge
model.}}

@ARTICLE{Bessis:85,
 AUTHOR = "N. Bessis and G. Bessis and D. Roux",
 TITLE = "Closed-Form Expressions for the {Dirac-Coulomb} Radial $r^{t}$
Integrals",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1985, VOLUME = 32, PAGES = "2044-2050",
 COMMENT = {No direct algebraic manipluation, but the formula is stated to be
well suited to evaluation by {REDUCE} or {MACSYMA}, and this is an
advantage of their formula.}}

@TECHREPORT{Billoire:78,
 AUTHOR = "A. Billoire and R. Lacaze and A. Morel and H. Navelet",
 TITLE = "The {OZI} Rule Violating Radiative Decays of the Heavy
Pseudoscalars",
 INSTITUTION = "{CEN}-Saclay", YEAR = 1978, TYPE = "Report",
 NUMBER = "DpH-T 43/78",
 COMMENT = {Submitted to Phys. Letters B.
In lowest order {QCD} the rates for radiative transitions violating the {OZI}
rule of heavy pseudoscalars are found to be extremely small.}}

@ARTICLE{Biro:86,
 AUTHOR = "T. S. Biro and J. Zimanyi and M. Zimanyi",
 TITLE = "Hadrochemistry in Relativistic Mean Fields",
 JOURNAL = "Physics Letters",
 YEAR = 1986, VOLUME = "167B", NUMBER = 3, PAGES = "271-276",
 MONTH = "February"}

@ARTICLE{Biro:87,
 AUTHOR = "T. S. Biro and K. Niita and A. L. de Paoli and W. Bauer
and W. Cassing and U. Mosel",
 TITLE = "Microscopic Theory of Photon Production in Proton-Nucleus
and Nucleus-Nucleus Collisions",
 JOURNAL = "Nuclear Physics",
 YEAR = 1987, VOLUME = "475A", PAGES = "579-597", MONTH = "December"}

@TECHREPORT{Birrell:77,
 AUTHOR = "N. D. Birrell",
 TITLE = "The Application of Adiabatic Regularization
to Calculations of Cosmological Interest",
 INSTITUTION = "Dept. Math, King's College, London",
 YEAR = 1977}

@ARTICLE{Biswas:75,
 AUTHOR = "S. N. Biswas and S. R. Chaudhuri and K. S. Taank
and J. A. Campbell",
 TITLE = "Neutrino Production in Stellar Matter by Photons
in a Renormalizable Scalar-Boson-Exchange Model of Weak
Interactions",
 JOURNAL = "Phys. Rev. D",
 YEAR = 1975, VOLUME = 8, PAGES = "2523-2525"}

@TECHREPORT{Bittencourt:90,
 AUTHOR = "Guilherme Bittencourt and Jacques Calmet",
 TITLE = "Integrating Computer Algebra and Knowledge Representation",
 INSTITUTION = "Universit{\"a}t Karlsruhe Institut f{\"u}r
Algorithmen und Kognitive Systeme", YEAR = 1990, TYPE = "Preprint"}

@ARTICLE{Bocko:92,
 AUTHOR = "J. Bocko",
 TITLE = "{EQSHELL-} a {REDUCE-based} program for generation of equations
of equilibrium for shell",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1992, VOLUME = 69, NUMBER = 1, PAGES = "215-222", MONTH = "February",
 COMMENT = {EQSHELL is a REDUCE-based program which generates the equations
of equilibrium for various shapes of shells.  This program also produces
other important characteristics of the shell.}}

@ARTICLE{Boege:86,
 AUTHOR = "W. Boege and R. Gebauer and H. Kredel",
 TITLE = "Some Examples for Solving Systems of Algebraic Equations
by Calculating {Groebner} Bases",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1986, VOLUME = 2, NUMBER = 1, PAGES = "83-98", MONTH = "March"}

@ARTICLE{Bogdanova:88,
 AUTHOR = "N. Bogdanova and H. Hogreve",
 TITLE = "A {REDUCE} Package for Exact {Coulomb} Interaction Matrix
Elements",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1988, VOLUME = 48, NUMBER = 2, PAGES = "319-326", MONTH = "February"}

@ARTICLE{Bordoni:81,
 AUTHOR = "Luciana Bordoni and Attilio Colagrossi",
 TITLE = "An Application of {REDUCE} to Industrial Mechanics",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1981, VOLUME = 15, NUMBER = 2, PAGES = "8-12", MONTH = "May"}

@INPROCEEDINGS{Bowyer:87,
 AUTHOR = "A. Bowyer and J. H. Davenport and P. S. Milne and J. A. Padget
and A. F. Wallis",
 TITLE = "Applications of Computer Algebra in Solid Modelling",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "244-245",
 PUBLISHER = "Springer-Verlag"}

@TECHREPORT{Boyd:78,
 AUTHOR = "John P. Boyd",
 TITLE = "The Effects of Latitudinal Shear on Equatorial
Waves, Part {I}:  Theory and Methods",
 INSTITUTION = "Dept. of Atmos. and Oceanic Science, Univ.
of Michigan",
 YEAR = 1978, TYPE = "Preprint", MONTH = "January",
 COMMENT = {To be published in Journal of The Atmospheric Sciences.
By using the method of multiple scales in height and a
variety of methods in latitude, analytic solutions for
equatorial waves in combined vertical and horizontal shear
are derived.}}

@INPROCEEDINGS{Brackx:87,
 AUTHOR = "F. Brackx and H. Serras",
 TITLE = "Boundary Value Problems for the {Laplacian} in {Euclidean} Space
Solved by Symbolic Computation",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "208-215",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Brackx:87a,
 AUTHOR = "F. Brackx and D. Constales and R. Delanghe and H. Serras",
 TITLE = "{Clifford} Algebra with {REDUCE}",
 JOURNAL = "Rend. Circ. Mat. Palermo, Ser. II",
 YEAR = 1987, VOLUME = 16, PAGES = "11-19"}

@ARTICLE{Brackx:89,
 AUTHOR = "F. Brackx and D. Constales and A. Ronveaux and H. Serras",
 TITLE = "On the Harmonic and Monogenic Decomposition of Polynomials",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1989, VOLUME = 8, NUMBER = 3, PAGES = "297-304", MONTH = "September"}

@INPROCEEDINGS{Bradford:86,
 AUTHOR = "R. J. Bradford and A. C. Hearn and J. A. Padget
and E. Schr{\"u}fer",
 TITLE = "Enlarging the {REDUCE} Domain of Computation",
 BOOKTITLE = "Proc. of {SYMSAC} '86",
 YEAR = 1986, PAGES = "100-106"}

@INPROCEEDINGS{Bradford:88,
 AUTHOR = "R. J. Bradford and J. H. Davenport",
 TITLE = "Effective Tests for Cyclotomic Polynomials",
 BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag",
 YEAR = 1988, VOLUME = 358, PAGES = "244-251"}

@InProceedings{Bradford90,
  author =      "Russell Bradford",
  title =       "A parallelization of the {Buchberger} Algorithm",
  booktitle =   "Proceedings of the International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "296",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@ARTICLE{Broadhurst:85,
 AUTHOR = "D. J. Broadhurst",
 TITLE = "Evaluation of a Class of {Feynman} Diagrams for all Numbers of
Loops and Dimensions",
 JOURNAL = "Phys. Lett. B",
 YEAR = "1985", VOLUME = "164", PAGES = "356-360",
 COMMENT = {Uses {REDUCE} to calculate explicitly the l-loop member of a
class of massless, dimensionally regularized {Feynman} diagrams, in order to
verify an explicit formula.}}

@ARTICLE{Broadhurst:91,
 AUTHOR = {D.J.Broadhurst and A.G.Grozin},
 TITLE = {Two-loop renormalization of the effective field theory
of a static quark},
 JOURNAL = {Phys. Lett. B},
  YEAR = 1991, VOLUME = 267, PAGES = {105-110}}

@TECHREPORT{Broadhurst:91a,
 AUTHOR = {D.J.Broadhurst and A.G.Grozin},
 TITLE = {Operator product expansion in static-quark effective theory:
large perturbative corrections},
 INSTITUTION = {Open University, Milton Keynes MK7 6AA, England},
 YEAR = 1991, NUMBER = {OUT-4102-31}}

@ARTICLE{Brodsky:62,
 AUTHOR = "S. J. Brodsky and A. C. Hearn and R. G. Parsons",
 TITLE = "Determination of the Real Part of the {Compton} Amplitude
at a Nucleon Resonance",
 JOURNAL = "Phys. Rev.",
 YEAR = 1962, VOLUME = 187, PAGES = "1899-1904"}

@ARTICLE{Brodsky:67,
 AUTHOR = "S. J. Brodsky and J. D. Sullivan",
 TITLE = "W-Boson Contribution to the Anomalous Magnetic Moment of the
Muon",
 JOURNAL = "Phys. Rev.",
 YEAR = 1967, VOLUME = 156, PAGES = "1644-1647"}

@INPROCEEDINGS{Brodsky:69,
 AUTHOR = "S. J. Brodsky",
 TITLE = "Status of Quantum Electrodynamics",
 YEAR = 1969,
 BOOKTITLE = "Proc. International Symposium on
Electron and Photon Interactions at High Energies, Liverpool,
England"}

@TECHREPORT{Brodsky:70,
 AUTHOR = "S. J. Brodsky",
 TITLE = "Quantum Electrodynamic Theory:  Its Relation to Precision Low
Energy Experiments",
 INSTITUTION = "SLAC",
 YEAR = 1970, TYPE = "Report", NUMBER = "SLAC-PUB-795",
 MONTH = "August"}

@INPROCEEDINGS{Brodsky:71,
 AUTHOR = "S. J. Brodsky",
 TITLE = "Algebraic Computation Techniques in Quantum Electrodynamics",
 YEAR = 1971, VOLUME = "II", PAGES = "IV-1 to IV-27",
 BOOKTITLE = "Proc. {2nd} Computing Methods in Theoretical Physics,
Marseilles"}

@TECHREPORT{Brodsky:72,
 AUTHOR = "S. J. Brodsky",
 TITLE = "Atomic Physics and Quantum Electrodynamics in the Infinite
Momentum Frame",
 INSTITUTION = "SLAC", YEAR = 1972,
 TYPE = "Report",
 NUMBER = "SLAC-PUB-1118", MONTH = "August",
 COMMENT = {Presented at the Third International Conference on Atomic
Physics.}}

@ARTICLE{Brodsky:72a,
 AUTHOR = "S. J. Brodsky and J. F. Gunion and R. L. Jaffe",
 TITLE = "Test for Fractionally Charged Partons from
Deep-Inelastic Bremsstrahlung in the Scaling Region",
 JOURNAL = "Phys. Rev. D",
 YEAR = 1972, VOLUME = 6, PAGES = "2487-2494"}

@ARTICLE{Brodsky:72b,
 AUTHOR = "S. J. Brodsky and R. Roskies",
 TITLE = "Quantum Electrodynamics and Renormalization Theory
in The Infinite Momentum Frame",
 JOURNAL = "Phys. Lett.",
 YEAR = 1972, VOLUME = "41B", PAGES = "517-520"}

@ARTICLE{Brodsky:73,
 AUTHOR = "S. J. Brodsky and R. Roskies and R. Suaya",
 TITLE = "Quantum Electrodynamics and Renormalization Theory in the
Infinite-Momentum Frame",
 JOURNAL = "Phys. Rev. D",
 YEAR = 1973, VOLUME = 8, PAGES = "4574-4594"}

@ARTICLE{Broughan:82,
 AUTHOR = "K. A. Broughan",
 TITLE = "{Grad-Fokker-Planck} Plasma Equations.  Part 1. {Collision}
Moments",
 JOURNAL = "J. Plasma Phys.",
 YEAR = 1982, VOLUME = 27, PAGES = "437-452",
 COMMENT = {{REDUCE} used in collaboration with hand calculation.  {REDUCE}
did the substitutions, with hand integrations.  "Thirteen moments are taken
of the collision term in Boltzmann-Fokker-Planck
equation{\ldots}plasma{\ldots}"}}

@ARTICLE{Broughan:91,
 AUTHOR = "K. A. Broughan and G. Keady and T. D. Robb and M. G. Richardson
and M. C. Dewar",
 TITLE = "Some Symbolic Computing Links to the {NAG} Numeric Library",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1991, VOLUME = 25, NUMBER = 3, PAGES = "28-37", MONTH = "July"}

@ARTICLE{Brown:79,
 AUTHOR = "W. S. Brown and A. C. Hearn",
 TITLE = "Applications of Symbolic Algebraic Computation",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1979, VOLUME = 17, PAGES = "207-215",
 COMMENT = {This paper is a survey of applications of systems for symbolic
algebraic computation.}}

@ARTICLE{Bryan-Jones:87,
 AUTHOR = "Jane Bryan-Jones",
 TITLE = "A Tutorial in Computer Algebra for Statisticians",
 JOURNAL = "The Professional Statistician",
 YEAR = 1987, VOLUME = 6, NUMBER = 6, MONTH = "December",PAGES = "TBD"}

@TECHREPORT{Burnel,
 AUTHOR = "A. Burnel and H. Caprasse",
 TITLE = "Locality in Class III Noncovariant Gauges",
 INSTITUTION = "Physique Th{\'e}orique et Math{\'e}matique,
Universit{\'e} de Li{\`e}ge",
 ABSTRACT = {It is shown within a perturbative calculation of the gluon
self-energy that, in the framework of a general formulation of linear gauges,
axial gauges do not exhibit nonlocal counterterms.}}

@TECHREPORT{Calmet:72,
 AUTHOR = "Jacques Calmet",
 TITLE = "Further Evaluation of the Sixth Order Corrections to the
Anomalous Magnetic Moment of the Electron",
 INSTITUTION = "Department of Physics, University of Utah",
 YEAR = 1972,
 ABSTRACT = {We report on the contributions to the $\alpha^{3}$
part of the anomalous magnetic moment of the electron from the
seven so-called cross and ladder diagrams.}}

@ARTICLE{Calmet:72a,
 AUTHOR = "Jacques Calmet",
 TITLE = "A {REDUCE} Approach to the Calculation of {Feynman} Diagrams",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1972, VOLUME = 4, PAGES = "199-204",
 ABSTRACT = {A brief survey of two existing {REDUCE} programs (by
Campbell-Hearn and by Calmet) dealing with algebraic computation of
{Feynman} diagrams is given.  Work in progress on a more general approach
to this problem is discussed.}}

@ARTICLE{Calmet:74,
 AUTHOR = "Jacques Calmet",
 TITLE = "Computer Recognition of Divergences in {Feynman} Graphs",
 JOURNAL = "SIGSAM Bulletin",
 YEAR = 1974, VOLUME = 8, NUMBER = 3, PAGES = "74-75", MONTH = "August",
 ABSTRACT = {A description of a program for the recognition of divergences
in {Feynman} graphs is given.}}

@INCOLLECTION{Calmet:83,
 AUTHOR = "J. Calmet and J. A. van Hulzen",
 TITLE = "Computer Algebra Applications",
 EDITOR = "B. Buchberger and G. E. Collins and R. Loos and R. Albrecht",
 BOOKTITLE = "Computer Algebra Symbolic and Algebraic Computation",
 EDITION = "2nd", PUBLISHER = "Springer-Verlag", YEAR = 1983}

@ARTICLE{Campbell:67,
 AUTHOR = "J. A. Campbell",
 TITLE = "Algebraic Computation of Radiative Corrections for
Electron-Positron Scattering",
 JOURNAL = "Nucl. Phys.",
 YEAR = 1967, VOLUME = "B1", PAGES = "283-300"}

@ARTICLE{Campbell:68,
 AUTHOR = "J. A. Campbell",
 TITLE = "Astrophysical Consequences of the Existence of Charged
Intermediate Vector Bosons",
 JOURNAL = "Aust. Journ. of Phys.",
 YEAR = 1968, VOLUME = 21, PAGES = "139-148"}

@ARTICLE{Campbell:70,
 AUTHOR = "J. A. Campbell and A. C. Hearn",
 TITLE = "Symbolic Analysis of {Feynman} Diagrams by Computer",
 JOURNAL = "Journ. of Comp. Phys.",
 YEAR = 1970, VOLUME = 5, PAGES = "280-327"}

@ARTICLE{Campbell:70a,
 AUTHOR = "J. A. Campbell and R. B. Clark and D. Horn",
 TITLE = "Low-T Theorems for Charged-Pion Photoproduction",
 JOURNAL = "Phys. Rev. D",
 YEAR = 1970, VOLUME = 2, PAGES = "217-224"}

@ARTICLE{Campbell:74,
 AUTHOR = "J. A. Campbell",
 TITLE = "Symbolic Computing and Its Relationship to Particle Physics",
 JOURNAL = "Acta Physica Austriaca",
 YEAR = 1974, VOLUME = "Suppl. XIII", PAGES = "595-647"}

@ARTICLE{Campbell:87,
 AUTHOR = "J. A. Campbell and P. O. Fr{\"o}man and E. Walles",
 TITLE = "Explicit series formulae for the evaluation of integrals by the
method of steepest descents",
 JOURNAL = "Studies in Applied Mathematics",
 YEAR = 1987, VOLUME = 77, PAGES = "151-172"}

@TECHREPORT{Caprasse:84,
 AUTHOR = "H. Caprasse",
 TITLE = "Description et Utilisation d'Une Extension du Programme {REDUCE}",
 INSTITUTION = "Physique Th{\'e}orique et Math{\'e}matique,
Universit{\'e} de Li{\`e}ge", YEAR = 1984, MONTH = "October"}

@ARTICLE{Caprasse:85,
 AUTHOR = "H. Caprasse and M. Hans",
 TITLE = "A New Use of Operators in the Algebraic Mode of {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "46-52", MONTH = "August"}

@ARTICLE{Caprasse:86,
 AUTHOR = "H. Caprasse",
 TITLE = "Description of an Extension of the Matrix Package of {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1986, VOLUME = 20, NUMBER = 4, PAGES = "7-10", MONTH = "December"}

@ARTICLE{Caprasse:86a,
 AUTHOR = "H. Caprasse",
 TITLE = "A Complete Simplification Package for the Absolute Value
Function in {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1986, VOLUME = 20, NUMBER = "1 and 2", PAGES = "18-21",
 MONTH = "February and May",
 COMMENT = {Implementation for {REDUCE} 3.2 of the function {"ABS"}.}}

@INPROCEEDINGS{Caprasse:88,
 AUTHOR = "H. Caprasse and J. Demaret and E. Schruefer",
 TITLE = "Can {EXCALC} be Used to Investigate {High-dimensional}
Cosmological Models with {Non-Linear Lagrangians}?",
 BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag",
 YEAR = 1988, PAGES = "116-124"}

@ARTICLE{Caprasse:89a,
 AUTHOR = "H. Caprasse",
 TITLE = "Les Th{\'e}ories des {Champs} dans le monde de {REDUCE}
(in {French})",
 JOURNAL = "{CALSYF} (to appear)",
 YEAR = 1989}

@ARTICLE{Caprasse:90,
 AUTHOR = "H. Caprasse",
 TITLE = "Renormalization Group, Function Iterations and Computer
Algebra",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1990, VOLUME = 9, NUMBER = 1, PAGES = "61-72", MONTH = "January",
 COMMENT = {Based on a renormalization group equation met in Quantum Field
Theory, Continuous Iterations of a large class of functions are computed
using {REDUCE}.}}

@ARTICLE{Caprasse:91,
 AUTHOR = "H. Caprasse and J. Demaret and K. Gatermann and H. Melenk",
 TITLE = "Power-law type solutions of fourth-order gravity for
multidimensional {Bianchi I} Universes",
 JOURNAL = "International Journal of Modern Physics C",
 YEAR = 1991, VOLUME = 2, NUMBER = 2, PAGES = "601-611",
 COMMENT = {This paper is devoted to the application of computer algebra to
the study of solutions of the field equations derived from a non-linear
Lagrangian, as suggested by recently proposed unified theories.  More
precisely, we restrict ourselves to the most general quadratic Lagrangian,
i.e. containing quadratic contributions in the different curvature tensors
exclusively.  The corresponding field equations are then fourth-order in the
metric tensor components.  The cosmological models studied are the simplest
ones in the class of spatially homogeneous but anisotropic models,
i.e. Bianchi I models.  For these models, we consider only power-law
type solutions of the field equations.  All the solutions of the associated
system of algebraic equations are found, using computer algebra, from a
search of its Groebner bases.  While, in space dimension d=3, the
Einsteinian-Kasner metric is still the most general power-law type solution,
for d>3, no solution, other than the Minkowski space-time, is common to the
three systems of equations corresponding to the three contributions to the
Lagrangian density.  In the case of a pure Riemann-squared contribution to the
Lagrangian (suggested by a recent calculation of the effective action for
the heterotic string), the possibility exists to realize a splitting of the
d-dimensional space into a (d-3)-dimensional internal space and a physical
3-dimensional space, the latter expanding in time as a power bigger than
2 (about 4.5 when d=9).}}

@ARTICLE{Carlson:80,
 AUTHOR = "P. Carlson",
 TITLE = "Coordinate Free Relativity",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1980, VOLUME = 21, PAGES = "1149-1154",
 COMMENT = {{REDUCE} programs for tetrad formulation of GR.}}

@PHDTHESIS{Carroll:73,
 AUTHOR = "R. Carroll",
 TITLE = "The Anomalous Magnetic Moment of the Electron in the
Mass Operator Formalism",
 SCHOOL = "University of Michigan",
 YEAR = 1973}

@ARTICLE{Carroll:75,
 AUTHOR = "R. Carroll",
 TITLE = "Mass-Operator Calculation of the Electron g-Factor",
 JOURNAL = "Phys. Rev. D",
 YEAR = 1975, VOLUME = 8, PAGES = "2344-2354"}

@TECHREPORT{Cejchan,
 AUTHOR = "A. Cejchan and J. Nadrchal",
 TITLE = "Application of {REDUCE}-2 and Analytic Integration
Program in the Theoretical Solid State Physics",
 INSTITUTION = "Institute of Physics, CSAV, Prague"}

@INPROCEEDINGS{Chaffy:88,
 AUTHOR = "C. Chaffy-Camus",
 TITLE = "An Application of {REDUCE} to the Approximation of $f(x,y)$",
 BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag",
 YEAR = 1988, VOLUME = 358, PAGES = "73-84"}

@ARTICLE{Chinnick:86,
 AUTHOR = "K. Chinnick and C. Gibson and J. F. Griffiths and W. Kordylewski",
 TITLE = "Isothermal Interpretations of Oscillatory Ignition During
Hydrogen Oxidation in an Open System.  {I}.  {Analytical} Predictions and
Experimental Measurements of Periodicity",
 JOURNAL = "Proc. Royal Soc. Lond.",
 YEAR =  1986, VOLUME = "A405", PAGES = "117-128",
 COMMENT = {Used {REDUCE} to solve Jacobian, but answer too complicated to
be of any use.}}

@ARTICLE{Cline:90,
 AUTHOR = "Terry Cline and Harold Abelson and Warren Harris",
 TITLE = "Symbolic Computing in Engineering Design",
 JOURNAL = "AI EDAM", YEAR = 1990, MONTH = "February"}

@TECHREPORT{Cohen:76,
 AUTHOR = "H. I. Cohen and O. Leringe and Y. Sundblad",
 TITLE = "The Use of Algebraic Computing in General Relativity",
 INSTITUTION = "The Royal Institute of Technology Department of Mechanics",
 YEAR = 1976, NUMBER = "TRITA-MEK-76-02"}

@TECHREPORT{Cohen:76a,
 AUTHOR = "I. Cohen and F. Bark",
 TITLE = "Perturbation Calculations for the Spin Up Problem Using {REDUCE}",
 INSTITUTION = "The Royal Institute of Technology, Department
of Mechanics",
 YEAR = 1976, NUMBER = "TRITA-MEK-76-03"}

@TECHREPORT{Cohen:77,
 AUTHOR = "I. Cohen and S. Yu. Slavyanov",
 TITLE = "Smooth Perturbations of the {Schr{\"o}dinger} Equation with a
Linear Potential Related to the Charmonium Models",
 INSTITUTION = "University of Stockholm Institute of Physics",
 YEAR = 1977, TYPE = "USIP Report", NUMBER = "77-17"}

@ARTICLE{Cohen:79,
 AUTHOR = "J. P. Fitch and H. I. Cohen",
 TITLE = "Using {CAMAL} for Algebraic Calculations in General Relativity",
 JOURNAL = "General Relativity and Gravitation", VOLUME = 11, YEAR = 1979,
 PAGES = "411-418"}

@ARTICLE{Cohen:84,
 AUTHOR = "H. I. Cohen and I. B. Frick and J. E. {\AA}man",
 TITLE = "Algebraic Computing in General Relativity",
 JOURNAL = "General Relativity and Gravitation, ed.",
 YEAR = 1984, PAGES = "139-162",
 COMMENT = {General relativity review.}}

@INPROCEEDINGS{Cohen:89,
 AUTHOR = "Joel S. Cohen",
 TITLE = "The Effective Use of Computer Algebra Systems",
 YEAR = 1989, PAGES = "677-698",
 BOOKTITLE = "Transactions of the Sixth Army Conference on Applied
Mathematics and Computing",
 COMMENT = {Review of author's experience with four computer algebra
systems.}}

@ARTICLE{Connor:84,
 AUTHOR = "J. N. L. Connor and P. R. Curtis and D. Farrelly",
 TITLE = "The Uniform Asymptotic Swallowtail Approximation:  Practical
Methods for Oscillating Integrals with Four Coalescing Saddle Points",
 JOURNAL = "J. Phys. A",
 YEAR = 1984, VOLUME = 17, PAGES = "283-310",
 COMMENT = {Used {REDUCE} and {SCHOONSCHIP} for some algebraic
manipulations, and then checked the results with {MACSYMA}; this is the most
distrustful reference we have found.}}

@ARTICLE{Connor:84a,
 AUTHOR = "J. N. L. Connor and P. R. Curtis and C. J. Edge and A. Lagan{`a}",
 TITLE = "The Uniform Asymptotic Swallowtail Approximation:  Application
to the Collinear $H+F_{2}$",
 JOURNAL = "J. Chem. Phys.", YEAR = 1984, VOLUME = 80, NUMBER = 3,
 PAGES = "1362-1363", MONTH = "February"}

@ARTICLE{Conwell:84,
 AUTHOR = "P. R. Conwell and P. W. Barber and C. K. Rushworth",
 TITLE = "Resonant Spectra of Dielectric Sphere",
 JOURNAL = "J. Opt. Soc. Am. A",
 YEAR = 1984, VOLUME = 1, PAGES = "62-67",
 COMMENT = {{REDUCE} used to confirm independently convergence and accuracy
of {Numerical Bessel} function routine, expanding series by {REDUCE} and
using bigfloats.  Described as slow but worthwhile.}}

@INPROCEEDINGS{Cowan:79,
 AUTHOR = "Richard M. Cowan and Martin L. Griss",
 TITLE = "Hashing -- The Key to Rapid Pattern Matching",
 BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes
in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "266-278",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Cung:75,
 AUTHOR = "V. K. Cung",
 TITLE = "Differential Cross Section of e+ + e- to e+ + mu- +
nubar(mu) + nubar(e)",
 JOURNAL = "Phys. Lett.",
 YEAR = 1975, VOLUME = "55B", PAGES = "67-70"}

@TECHREPORT{Darbaidze:86,
 AUTHOR = "Ya. Z. Darbaidze",
 TITLE = "A Gluon Bremsstrahlung in Supersymmetry {QCD}",
 INSTITUTION = "JINR", YEAR = 1986, TYPE = "Preprint",
 NUMBER = "P2-86-825"}

@ARTICLE{Darbaidze:86a,
 AUTHOR = "J. Z. Darbaidze and V. A. Matveev and
Z. V. Merebashvili and L. A. Slepchenko",
 TITLE = "Gluon Bremsstrahlung in Supersymmetric {QCD}",
 JOURNAL = "Phys. Lett.",
 YEAR = 1986, VOLUME = "B177", PAGE = "188"}

@TECHREPORT{Darbaidze:88,
 AUTHOR = "Ya. Z. Darbaidze and Z.V. Merebashvili and V.A. Rostovtsev",
 TITLE = "Some Computer Realizations of the {REDUCE-3} Calculations for
Exclusive Processes",
 INSTITUTION = "JINR", YEAR = 1988, TYPE = "Preprint",
 NUMBER = "P2-88-769"}

@TECHREPORT{Darbaidze:89,
 AUTHOR = "Ya. Z. Darbaidze and V.A. Rostovtsev",
 TITLE = "Analysis of the Differential Equations for the Exclusive Processes
and Explanation for the {``Mystery''} of the {Gamma-Distribution}",
 INSTITUTION = "JINR", YEAR = 1989, TYPE = "Preprint",
 NUMBER = "E2-89-286"}

@INPROCEEDINGS{Dautcourt:79,
 AUTHOR = "G. Dautcourt",
 TITLE = "Application of {REDUCE} to Algebraic Computations in General
Relativity and Astrophysics",
 YEAR = 1979, MONTH = "September",
 BOOKTITLE = "Proc. of the Workshop in Symbolic Computation, Dubna,
{U.S.S.R.}",
 COMMENT = {Reports the use of the system {REDUCE} 2 for general relativistic
calculations.}}

@TECHREPORT{Dautcourt:80,
 AUTHOR = "G. Dautcourt and K. P. Jann",
 TITLE = "A Program Package in {REDUCE} 2 for Algebraic Computations in
General Relativity",
 YEAR = 1980,
 INSTITUTION = "Zentralinstitut fuer Astrophysik der
Akademie der Wissenschaften"}

@ARTICLE{Dautcourt:81,
 AUTHOR = "G. Dautcourt and K. P. Jann and E. Riemer and M. Riemer",
 TITLE = "User's Guide to {REDUCE} Subroutines For Algebraic
Computations in General Relativity",
 JOURNAL = "Astron. Nachr.",
 YEAR = 1981, VOLUME = 302, PAGES = "1-13"}

@ARTICLE{Dautcourt:83,
 AUTHOR = "G. Dautcourt",
 TITLE = "The Cosmological Problem as an Initial Value Problem on the
Observer's Past Light Cone:  Geometry",
 JOURNAL = "J. Phys. A",
 YEAR = 1983, VOLUME = 16, PAGES = "3507-3528",
 COMMENT = {Checked calculations with {REDUCE}, mainly {Riemann} tensor in
null coordinates.}}

@ARTICLE{Davenport:81,
 AUTHOR = "James Harold Davenport",
 TITLE = "On the Integration of Algebraic Functions",
 JOURNAL = "Lecture Notes in Computer Science",
 PUBLISHER = "Springer-Verlag",
 YEAR = 1981, VOLUME = 102, PAGES = "1-197"}

@ARTICLE{Davenport:82,
 AUTHOR = "James H. Davenport",
 TITLE = "Fast {REDUCE:}  The {trade-off} between efficiency and
generality",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1982, VOLUME = 16, NUMBER = 1, PAGES = "8-11", MONTH = "February"}

@ARTICLE{Davenport:82a,
 AUTHOR = "James H. Davenport",
 TITLE = "What do we want from a {high-level} language?",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1982, VOLUME = 16, NUMBER = 4, PAGES = "6-9", MONTH = "November"}

@INPROCEEDINGS{Davenport:85,
 AUTHOR = "James Davenport and Julian Padget",
 TITLE = "{HEUGCD:}  How Elementary Upperbounds Generate Cheaper Data",
 BOOKTITLE = "Proc. {EUROCAL} 1985, Lecture Notes
in Computer Science", YEAR = 1985, VOLUME = 204, PAGES = "18-28",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Davenport:88,
 AUTHOR = "J. H. Davenport",
 TITLE = "The World of Computer Algebra",
 JOURNAL = "New Scientist",
 YEAR = 1988, MONTH = "September", VOLUME = 1629, PAGES = "71-72"}

@BOOK{Davenport:88a,
 AUTHOR = "J. H. Davenport and Y. Siret and E. Tournier",
 TITLE = "Computer Algebra, Systems and Algorithms for Algebraic
Computation",
 PUBLISHER = "Academic Press", PRINTING = "2nd", YEAR = 1989}

@TECHREPORT{Della-Dora:81,
 AUTHOR = "J. Della Dora and E. Tournier",
 TITLE = "Solutions Formelles D'Equations Differentielles au Voisinage de
Points Singuliers Reguliers",
 INSTITUTION = "Centre National de la Recherche Scientifique",
 YEAR = 1981, TYPE = "Report", NUMBER = 239}

@INPROCEEDINGS{Della-Dora:84,
 AUTHOR = "J. Della Dora and E. Tournier",
 TITLE = "Homogeneous Linear Difference Equation {(Frobenius-Boole Method)}",
 BOOKTITLE = "Proc. {EUROSAM} 1984, Lecture Notes
in Computer Science", YEAR = 1984, VOLUME = 174, PAGES = "2-12",
 PUBLISHER = "Springer-Verlag"}

@TECHREPORT{Della-Dora:85,
 AUTHOR = "Jean Della-Dora and Claire Dicrescenzo and Dominique Duval",
 TITLE = "About a New Method for Computing in Algebraic Number Fields",
 INSTITUTION = "Universit{\'e} de Grenoble, Institut Fourier,
France", YEAR = 1985, MONTH = "November"}

@ARTICLE{Demaret:89,
 AUTHOR = "J. Demaret and H. Caprasse and A. Moussiaux and Ph. Tombal and
D. Papadopoulos",
 TITLE = "{Ten-dimensional Lovelock-type Space-Times}",
 JOURNAL = "{To appear} Phys. Rev. D",
 YEAR = 1989, MONTH = "July"}

@ARTICLE{DeMenna:87,
 AUTHOR = "L. De Menna and G. Miano and G. Rubinacci",
 TITLE = "Volterra's Series Solutions of Free Boundary Plasma Equilibria",
 JOURNAL = "Phys. Fluids",
 YEAR = 1987, VOLUME = 30, PAGES = "409-416",
 COMMENT = {Magnetohydrodynamics.  "We have carried out the computations up
to the fourth order, (the fourth order has been obtained by means of the
symbolic program {REDUCE}").}}

@ARTICLE{Demichev:85,
 AUTHOR = "A. P. Demichev and A. Ya. Rodionov",
 TITLE = "A {REDUCE} Program for the Calculation of Geometrical
Characteristics of Compactified Multidimensional {Riemannian} Space",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1985, VOLUME = 38, PAGES = "441-448",
 COMMENT = {Covariant theories in N dimensional ($N \geq 4$) space-time.
{REDUCE} programs to calculate {Ricci, Einstein and Yang-Mills} curvature
and energy-momentum tensor.}}

@TECHREPORT{Demichev:86,
 AUTHOR = "A. P. Demichev and A. Ya. Rodionov",
 TITLE = "Freund-{Rubin} Type Solutions for Different Compactifications of
the Eleven-Dimensional Space",
 INSTITUTION = "Institute for High Energy Physics", YEAR = 1986,
 TYPE = "Preprint", NUMBER = "86-85",
 ABSTRACT = {The results of calculating geometrical characteristics of
seven-dimensional quotient spaces are represented.  These
quantities are necessary for the construction of compactifying
solutions of the eleven-dimensional supergravity.}}

@ARTICLE{deRop:88,
 AUTHOR = "Y. de Rop and J. Demaret",
 TITLE = "Using {EXCALC} to Study Nondiagonal Multidimensional
Spatially Homogeneous Cosmologies",
 JOURNAL = "Gen. Rel. Grav.",
 YEAR = 1988, VOLUME = 20, PAGES = "1127-1139"}

@TECHREPORT{DeVos:89,
 AUTHOR = "Alexis De Vos",
 TITLE = "The use of {Reduce} in solar energy conversion theory",
 INSTITUTION = "State University of Gent, {CAGe} Computer Algebra
Group", YEAR = 1989, TYPE = "Reports of the {CAGe} Project",
NUMBER = 4, MONTH = "August"}

@INPROCEEDINGS{Dewar:89,
 AUTHOR = "M. C. Dewar",
 TITLE = "{IRENA --} An Integrated Symbolic and Numerical Computation
Environment",
 BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York",
 YEAR = 1989, PAGES = "171-179"}

@ARTICLE{Dhar:85,
 AUTHOR = "D. Dhar and J-M. Maillard",
 TITLE = "Susceptibility of the Checkerboard {Ising} Model",
 JOURNAL = "J. Phys. A",
 YEAR = 1985, VOLUME = 18, PAGES = "L383-L388",
 COMMENT = {Used {REDUCE} for tedious algebra, and got a simple answer.
statistical mechanics(?). "At the disorder variety, the n-point correlation
functions of the checkerboard Potts model has a simple causal
structure.  An exact expression for the susceptibility in the Ising
case is obtained."}}

@TECHREPORT{Dicrescenzo:85,
 AUTHOR = "Claire Dicrescenzo",
 TITLE = "Algebraic Computation on Algebraic Numbers",
 INSTITUTION = "Institut Fourier, Laboratoire de
Math{\'e}matiques, France", YEAR = 1985, MONTH = "December",
 COMMENT = {Examples are given of a new method, implemented on {REDUCE},
for computing algebraically on algebraic numbers.}}

@TECHREPORT{Diver,
 AUTHOR = "D. A. Diver and E. Q. Laing and C. C. Sellar",
 TITLE = "Waves in a Cold Plasma with a Spatially Rotating Magnetic Field",
 INSTITUTION = "Department of Physics and Astronomy, University of
Glasgow, Plasma Physics Group", TYPE = "Report", NUMBER = "GU TPA 88/12-1",
 COMMENT = {"{\ldots}The algebraic manipulation system {REDUCE} was used in
constructing the following tensor definitions which allows us to make fewer
approximations than other authors."}}

@INPROCEEDINGS{Diver:86,
 AUTHOR = "D. A. Diver and E. W. Laing",
 TITLE = "Proc. 8th {Europhysics} Conference on
Computational Physics",
 YEAR = 1986,
 BOOKTITLE = "Computing in Plasma Physics"}

@INPROCEEDINGS{Diver:88,
 AUTHOR = "D. A. Diver and E. W. Laing",
 TITLE = "Proc. {XV} {European} Conference on Controlled
Fusion and Plasma Heating",
 YEAR = 1988}

@TECHREPORT{Diver:88a,
 AUTHOR = "D. A. Diver and E. W. Laing",
 TITLE = "Alfven Resonance Absorption in a Magnetofluid",
 YEAR = 1988, TYPE = "Internal Report",
 NUMBER = "GUTPA 88/04-01", MONTH = "July",
 COMMENT = {Presented at 15th {UK} Plasma Physics Conference, {UMIST}.}}

@ARTICLE{Diver:91,
 AUTHOR = "D. A. Diver",
 TITLE = "Modelling Waves with Computer Algebra",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1991, VOLUME = 11, NUMBER = 3, PAGES = "275-289", MONTH = "March",
 ABSTRACT = {A sophisticated model for linear waves in an inhomogeneous
plasma is tackled completely using the computer algebra system {REDUCE}.
The algebra code mirrors the mathematics, and is structured in a simple
and straightforward manner.  In so doing, the solution technique is made
obvious, and the overall philosophy of the approach is intuitive to the
{non-specialist} computer algebra user.}}

@TECHREPORT{Dorfi:85,
 AUTHOR = "E. A. Dorfi and L. O'C. Drury",
 TITLE = "Simple Adaptive Grids for {1D} Initial Value Problems",
 INSTITUTION = "Max-Plack-Institut fuer Kernphysik, Heidelberg,
West Germany", YEAR = 1985,
 NUMBER = "MPI H-1985-V21"}

@ARTICLE{Dorizzi:86,
 AUTHOR = "B. Dorizzi and B. Grammaticos and J. Hietarinta and A. Ramani
and F. Schwarz",
 TITLE = "New integrable three dimensional quartic potentials",
 JOURNAL = "Phys. Lett.",
 YEAR = 1986, VOLUME = "116A", PAGES = "432-436",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@TECHREPORT{dosSantos:85,
 AUTHOR = "R. P. dos Santos and P. P. Srivastava",
 TITLE = "Two-loop Effective Potential for {Wess-Zumino} Model using
Superfields",
 INSTITUTION = "International Centre for Theoretical Physics",
 YEAR = 1985, NUMBER = "IC/85/205", MONTH = "October",
 ABSTRACT = {For the case of several interacting chiral superfields the
propagators for the unconstrained superfield potentials in the 'shifted'
theory, where the supersymmetry is explicitly broken, are derived in a
compact form.  They are used to compute one-loop effective potential in
the general case, while a superfield calculation of renormalized effective
potential to two loops for the Wess-Zumino model is performed.}}

@ARTICLE{dosSantos:87,
 AUTHOR = "Renato P. dos Santos",
 TITLE = "Using {REDUCE} in Supersymmetry",
 JOURNAL = "J. Symb. Comp.",
 YEAR = 1989, VOLUME = 7, PAGES = "523-525"}

@PHDTHESIS{dosSantos:87a,
 AUTHOR = "R. P. dos Santos",
 TITLE = "O M{\'e}todo de Supercampos para o C{\'a}lculo de Potencial
Efetivo em Modelos com Supercampos Quirais: Os Modelos de Wess e
Zumino e de O'Raifeartaigh",
 SCHOOL = "Centro Brasileiro de Pesquisas F{\'i}sicas",
 YEAR = 1987,
 COMMENT = {{(In Portuguese)} Using the method of {Superfields}, the
effective potential for supersymmetric models of {Wess-Zumino} and of
{O'Raifeartaigh} is evaluated up to two-loop order. The spontaneous
supersymmetry breaking is discussed.  {REDUCE} plays very important
role in evaluation of the {Feynman} superdiagrams and in
renormalization.}}

@TECHREPORT{dosSantos:88a,
 AUTHOR = "Renato P. dos Santos",
 TITLE = "Introdu\c{c}\~{a}o ao Sistema {REDUCE} de C\'{a}lculo
Alg\'{e}brico",
 INSTITUTION = "CBPF, Rio de Janeiro, Brazil",
 YEAR = 1988, NUMBER = "CBPF-NT-001/88",
 COMMENT = {{(In Portuguese)} Lecture notes of a course on {REDUCE}.}}

@ARTICLE{dosSantos:90,
 AUTHOR = "R. P. dos Santos and W. L. Roque",
 TITLE = "On the Design of an Expert Help System for Computer Algebra
Systems",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1990, VOLUME = 24, NUMBER = 4, PAGES = "22-25", MONTH = "October"}

@ARTICLE{Drska:90,
 AUTHOR = "Ladislav Drska and Richard Liska and Milan Sinor",
 TITLE = "Two practical packages for computational physics{-GCPM, RLFI}",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1990, VOLUME = 61, NUMBER = "1-2", MONTH = "November",
 PAGES = "225-230",
 ABSTRACT = {Two handy computer-program packages for technical support of
the work in two different branches of the computational physics are reported:
(1) A general package for the symbolic and numerical transformation of
expressions from one system of units to another.  (2) A package allowing
high-quality two-dimensional output of mathematical formulas from the
computer-algebra system {REDUCE}.}}

@ARTICLE{Dubowsky:75,
 AUTHOR = "S. Dubowsky and J. L. Grant",
 TITLE = "Application of Symbolic Manipulation to Time
Domain Analysis of Nonlinear Dynamic Systems",
 JOURNAL = "Journ. of Dynamic Systems, Measurement, and Control",
 YEAR = 1975, NUMBER = "75-Aut-J"}

@ARTICLE{Dudley:89,
 AUTHOR = "M. L. Dudley and R. W. James",
 TITLE = "{Computer-aided} Derivation of Spherical Harmonic Spectral Equations
in Astrogeophyics",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1989, VOLUME = 8, NUMBER = 4, PAGES = "423-427", MONTH = "October"}

@ARTICLE{Dufner:69,
 AUTHOR = "A. M. Dufner and Y. S. Tsai",
 TITLE = "Phenomenological Analysis of the $\gamma$NN* Form Factors",
 JOURNAL = "Phys. Rev.",
 YEAR = 1969, VOLUME = 168, PAGES = "1801-1809"}

@INPROCEEDINGS{Dulyan:87,
 AUTHOR = "L. S. Dulyan",
 TITLE = "The Calculation of {QCD} Triangular {Feynman} Graphs in the
External Gluonic Field Using {REDUCE}-2 System",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "172-173",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Duncan:86,
 AUTHOR = "Anthony Duncan and Ralph Roskies",
 TITLE = "Representations of Unusual Mathematical Structures in Scientific
Applications of Symbolic Computation",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1986, VOLUME = 2, NUMBER = 2, PAGES = "201-206", MONTH = "June",
 ABSTRACT = {We present examples of techniques we have used to apply {REDUCE}
to problems in particle physics which have mathematical structures unknown to
{REDUCE}.}}

@PHDTHESIS{Duval:87,
 AUTHOR = "Dominique Duval",
 TITLE = "Diverses questions relatives au Calcul Formel
Avec des Nombres Alg{\'e}briques",
 SCHOOL = "L'Universit{\'e} Scientifique, Technologique
et M{\'e}dicale de Grenoble", YEAR = 1987}

@ARTICLE{Earles:70,
 AUTHOR = "D. Earles",
 TITLE = "A Measurement of the Electron-Production of Muon Pairs",
 JOURNAL = "Phys. Rev. Lett.",
 YEAR = 1970, VOLUME = 25, PAGES = "129-133"}

@ARTICLE{Eastwood:87,
 AUTHOR = "James W. Eastwood",
 TITLE = "Orthovec:  A {REDUCE} Program for {3-D} Vector Analysis
in Orthogonal Curvilinear Coordinates",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1987, VOLUME = 47, NUMBER = 1, PAGES = "139-147", MONTH = "October"}

@TECHREPORT{Eastwood:87a,
 AUTHOR = "James W. Eastwood and Christopher J. H. Watson",
 TITLE = "An Analytic Theory of {Wave-Current} Interactions",
 INSTITUTION = "Culham Laboratory, Theory and Optics Division",
 YEAR = 1987, NUMBER = "Plasma Physics Note 87/7", MONTH = "February",
 ABSTRACT = {This report presents results of the Department of Energy
contract to obtain high order analytic solutions to nonlinear hydrodynamic
equation describing steady periodic waves propagating in sheared currents.
The purpose of this work is to provide working formulae for computing
combined wave and current loadings in the design of offshore structures.
Using the {REDUCE} algebra package, we have identified minor typographical
errors in the published fifth coefficients for uniform currents given by
{Fenton [2]} and by Skjelbreia and {Hendrickson [5]}.  We have demonstrated
the equivalence of corrected forms of these expressions to fifth order, and
extended Fenton's expansion to seventh order.  We present a new fifth order
theory for bilinear current profiles. {FORTRAN} software for the seven order
uniform current and fifth order bilinear current theories are given.}}

@ARTICLE{Eastwood:91,
 AUTHOR = "James W. Eastwood",
 TITLE = "{ORTHOVEC:} version 2 of the {REDUCE} program for {3-D} vector
analysis in orthogonal curvilinear coordinates",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1991, VOLUME = 64, NUMBER = 1, PAGES = "121-122", MONTH = "April"}

@TECHREPORT{Edelen:81,
 AUTHOR = "Dominic G. B. Edelen",
 TITLE = "Programs for Calculation of Isovector Fields in the
{REDUCE}-2 Environment",
 INSTITUTION = "Center for the Application of Mathematics,
Lehigh University", YEAR = 1981, NUMBER = "TBD", MONTH = "August"}

@ARTICLE{Edelen:82,
 AUTHOR = "D. G. B. Edelen",
 TITLE = "Isovector Fields for Problems in the Mechanics of Solids and
Fluids",
 JOURNAL = "Int. Journ. Eng. Sci.",
 YEAR = 1982, VOLUME = 20, PAGES = "803-815",
 COMMENT = {Prolongation methods as a {REDUCE} package for this, available
from Center for Applications of Mathematics, Lehigh Univ., Bethlehem, PA
18015.  Applications to mechanics of solids and fluids.}}

@BOOK{Edneral:89,
 AUTHOR = "Viktor F. Edneral and Aleksandr P. Kryukov and
Anatolii Ia. Rodionov",
 TITLE = "The language of the analytic computer program {REDUCE}",
 PUBLISHER = "Moscow, {Izd-vo}, Moskovskogo {un-ta}", YEAR = 1989,
 COMMENT = {This monograph -- first in The Soviet Union with a systematic
treatment of the analytical computer (program) {REDUCE}.}}

@ARTICLE{Eisenberger:90,
 AUTHOR = "Moshe Eisenberger",
 TITLE = "Application of Symbolic Algebra to the Analysis of Plates
on Variable Elastic Foundation",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1990, VOLUME = 9, NUMBER = 2, PAGES = "207-213", MONTH = "February"}

@TECHREPORT{Eissfeller:86,
 AUTHOR = "Bernd Ei{\ss}feller and G{\"u}nter W. Hein",
 TITLE = "A Contribution to {3D-Operational} Geodesy",
 INSTITUTION = "Universit{\"a}rer Studiengang Vermessungswesen
and Universit{\"a}t der Bundeswehr M{\"u}nchen",
 YEAR = 1986, NUMBER = "Heft 17", MONTH = "December"}

@PHDTHESIS{Eitelbach:73,
 AUTHOR = "D. L. Eitelbach",
 TITLE = "Automatic Analysis of Problems in Elementary Mechanics",
 SCHOOL = "University of Illinois",
 YEAR = 1973}

@ARTICLE{Eleuterio:82,
 AUTHOR = "S. M. Eleut{\'e}rio and R. V. Mendes",
 TITLE = "Note on Equivalence and Singularities:  An Application of
Computer Algebra",
 JOURNAL = "Journ. Comp. Phys.",
 YEAR = 1982, VOLUME = 48, PAGES = "150-156",
 COMMENT = {{GR} equivalence, commenting on \AAman & Karlhede.}}

@ARTICLE{Eliseev:85,
 AUTHOR = "V. P. Eliseev and R. N. Fedorova and V. V. Kornyak",
 TITLE = "A {REDUCE} Program for Determining Point and Contact {Lie}
Symmetries of Differential Equations",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1985, VOLUME = 36, PAGES = "383-389",
 ABSTRACT = {A universal {REDUCE} program for obtaining the systems of
determining equations of the Lie algebra of point and contact
symmetries is proposed.}}

@ARTICLE{Elishakoff:87,
 AUTHOR = "Isaac Elishakoff and Joseph Hollkamp",
 TITLE = "Computerized Symbolic Solution for a Nonconservative
System in Which Instability Occurs by Flutter in One Range
of a Parameter and by Divergence in Another",
 JOURNAL = "Comp. Methods in Applied Mechanics and Engineering",
 YEAR = 1987, VOLUME = 62, PAGES = "27-46",
 COMMENT = {"{\ldots}the problem is solved by the {Galerkin} method in
conjunction with computerized symbolic algebra".  The system used is {REDUCE}.
"It carries out algebraic operations irrespective of their complexity".
Includes snatches of code and algebraic answers.  Mainly
differentiation and substitution, plus a little integration.  The
coefficients get rather large (18 digits or so).}}

@ARTICLE{Elishakoff:87a,
 AUTHOR = "Isaac Elishakoff and Brian Couch",
 TITLE = "Application of Symbolic Algebra to the Instability of a
Nonconservative System",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1987, VOLUME = 4, NUMBER = 3, PAGES = "391-396", MONTH = "December"}

@ARTICLE{Esteban:90,
 AUTHOR = "E.P. Esteban and E. Ramos",
 TITLE = "Algebraic computing and the {Newman-Penrose} formalism",
 JOURNAL = "Computers in Physics",
 YEAR = 1990, PAGES = "285-290", MONTH = "May/June"}

@ARTICLE{Falck:89,
 AUTHOR = "N. K. Falck and D. Graudenz and G. Kramer",
 TITLE = "Cross section for {five-parton} production in $e^{+} e^{-}$
annihilation",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1989, VOLUME = 56, PAGES = "181-198", NUMBER = 2, MONTH = "December"}

@ARTICLE{Fazio:84,
 AUTHOR = "P. M. Fazio and G. E. Copeland",
 TITLE = "Cooper-Type Minima in Multipole Cross Sections of Atomic Hydrogen",
 JOURNAL = "Phys. Rev. Lett.",
 YEAR = 1984, VOLUME = 53, NUMBER = "2", MONTH = "July"}

@INPROCEEDINGS{Fedorova:87,
 AUTHOR = "R. N. Fedorova and V. P. Gerdt and N. N. Govorun
and V. P. Shirikov",
 TITLE = "Computer Algebra in Physical Research of {Joint Institute}
for {Nuclear Research}",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "1-10",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{Fedorova:87a,
 AUTHOR = "R. N. Fedorova and V. V. Kornyak",
 TITLE = "Computer Algebra Application for Determining Local Symmetries
of Differential Equations",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "174-175",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Feldmar:86,
 AUTHOR = "E. Feldmar and K. S. K{\"o}lbig",
 TITLE = "{REDUCE} Procedures for the Manipulation of Generalized
Power Series",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1986, VOLUME = 39, PAGES = "267-284"}

@ARTICLE{Feuillebois:84,
 AUTHOR = "F. Feuillebois",
 TITLE = "Sedimentation in a Dispersion with Vertical Inhomogenieties",
 JOURNAL = "Journ. Fluid Mech.",
 YEAR = 1984, VOLUME = 139, PAGES = "145-171",
 COMMENT = {Uses {REDUCE} and {INT} to evaluate some integrals in the
expansion of 1/s, a small quantity.}}

@ARTICLE{Fitch:73,
 AUTHOR = "John Fitch",
 TITLE = "Problems \#3 and \#4 in {REDUCE} and {MACSYMA}",
 JOURNAL = "SIGSAM Bulletin",
 YEAR = 1973, PAGES = "10-11",
 ABSTRACT = {The algebra systems {REDUCE} and {MACSYMA} are used to solve
{SIGSAM} Problem \#3, the Reversion of a Double Series, and {SIGSAM}
Problem \#4, the Lie Transform Solution of the Harmonic Oscillator.}}

@INPROCEEDINGS{Fitch:81,
 AUTHOR = "J. P. Fitch",
 TITLE = "User-based Integration Software",
 BOOKTITLE = "Proc. 1981 {ACM} Symposium on Symbolic
and Algebraic Computation",
 YEAR = 1981, PAGES = "245-248"}

@INPROCEEDINGS{Fitch:83,
 AUTHOR = "J. P. Fitch",
 TITLE = "Implementing {REDUCE} on a Microprocessor",
 BOOKTITLE = "Proc. {EUROCAL} 1983, Lecture Notes
in Computer Science", YEAR = 1983, VOLUME = 162, PAGES = "128-136",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Fitch:85,
 AUTHOR = "J. P. Fitch",
 TITLE = "Solving Algebraic Problems with {REDUCE}",
 JOURNAL = "J. of Symbolic Computation",
 YEAR = 1985, VOLUME = 1, NUMBER = 2, PAGES = "211-227", MONTH = "June"}

@INPROCEEDINGS{Fitch:85a,
 AUTHOR = "J. P. Fitch",
 TITLE = "Applying Computer Algebra",
 BOOKTITLE = "International Conference on Computer Algebra and its
Application in Theory",
 YEAR = 1985, PAGES = "262-275"}

@INPROCEEDINGS{Fitch:87,
 AUTHOR = "J. P. Fitch",
 TITLE = "Utilisation du Calcul Formel",
 BOOKTITLE = "Calcul Formel et Automatique",
 EDITOR = "P. Chenin", PUBLISHER = "Editions du {CNRS}",
 YEAR = 1987, PAGES = "119-136"}

@INPROCEEDINGS{Fitch:87a,
 AUTHOR = "J. P. Fitch and R. G. Hall",
 TITLE = "Symbolic Computation and the Finite Element Method",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "95-96",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{Fitch:89,
 AUTHOR = "J. P. Fitch",
 TITLE = "Can {REDUCE} be run in parallel?",
 BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York",
 YEAR = 1989, PAGES = "155-162"}

@ARTICLE{Fitch:89a,
 AUTHOR = "J. Fitch",
 TITLE = "Compiling for Parallelism",
 JOURNAL = "Computer Algebra and Parallelism", EDITOR = "J. Della Dora
and J. Fitch",
 YEAR = 1989, PAGES = "19-31", PUBLISHER = "Academic Press, London"}

@InProceedings{Fitch90,
  author =      "J. P. Fitch",
  title =       "A delivery system for {REDUCE}",
  booktitle =   "Proceedings of the International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "76-81",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@ARTICLE{Fitch:90a,
 AUTHOR = "John Fitch",
 TITLE = "The symbolic-numeric interface",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1990, VOLUME = 61, NUMBER = "1-2", MONTH = "November",
 PAGES = "22-33",
 ABSTRACT = {Algebraic computation can be of great assistance in the
preparation of numerical programs.  The paper considers some of these,
from simple to complex, and describes work currently in progress to produce
a true integrated symbolic-numeric computing system.}}

@TECHREPORT{Flatau:86,
 AUTHOR = "Piotr J. Flatau and John P. Boyd and William R. Cotton",
 TITLE = "Symbolic Algebra in Applied Mathematics and Geophysical
Fluid Dynamics - {REDUCE} Examples",
 INSTITUTION = "Dept. of Atmospheric and Oceanic Science, University
of Michigan, and Dept. of Atmospheric Science, Colorado State
University", YEAR = 1986}

@TECHREPORT{Flath:86,
 AUTHOR = "Dan Flath",
 TITLE = "Remarks on Tensor Operators",
 INSTITUTION = "National University of Singapore, Department
of Mathematics", TYPE = "Research Report",
 YEAR = 1986, NUMBER = 266, MONTH = "July"}

@ARTICLE{Fleischer:71,
 AUTHOR = "J. Fleischer",
 TITLE = "Partial Wave Analysis of Nucleon-Nucleon {Bethe}-{Salpeter}
Equation on the Computer",
 JOURNAL = "Journ. of Comp. Phys.",
 YEAR = 1971, VOLUME = 12, PAGES = "112-123"}

@ARTICLE{Fleischer:73,
 AUTHOR = "J. Fleischer and J. L. Gammel and M. T. Menzel",
 TITLE = "Matrix {Pad\'e} Approximants for the {1SO}- and
{3PO}- Partial Waves in Nucleon-Nucleon Scattering",
 JOURNAL = "Phys. Rev. D",
 YEAR = 1973, VOLUME = 8, PAGES = "1545-1552"}

@ARTICLE{Fleischer:75,
 AUTHOR = "J. Fleischer and J. A. Tjon",
 TITLE = "Bethe-{Salpeter} Equation for {J}=0 Nucleon-Nucleon
Scattering with One-Boson Exchange",
 JOURNAL = "Nuclear Physics",
 YEAR = 1975, VOLUME = "B84", PAGES = "375-396"}

@ARTICLE{Fogelholm:82,
 AUTHOR = "Rabbe Fogelholm and Inge B. Frick",
 TITLE = "Standard {LISP} for the {VAX:}  A Provisional Implementation",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1982, VOLUME = 16, NUMBER = 4, PAGES = "10-12", MONTH = "November"}

@ARTICLE{Foster:89,
 AUTHOR = "Kenneth R. Foster and Haim H. Bau",
 TITLE = "Symbolic Manipulation Programs for the Personal Computer",
 JOURNAL = "Science",
 YEAR = 1989, VOLUME = 243, PAGES = "679-243", MONTH = "February",
 COMMENT = {Reviews several algebra programs that run on small machines.
doesn't rate the {PC} version of {REDUCE} very highly because of the small
workspace.}}

@ARTICLE{Fox:71,
 AUTHOR = "J. A. Fox",
 TITLE = "Recalculation of the Crossed Graph Contribution
to the 4th Order {Lamb} Shift",
 JOURNAL = "Phys. Rev. D",
 YEAR = 1971, VOLUME = 3, PAGES = "3228-3230"}

@ARTICLE{Fox:74,
 AUTHOR = "John A. Fox and Anthony C. Hearn",
 TITLE = "Analytic Computation of Some Integrals in Fourth Order
Quantum Electrodynamics",
 JOURNAL = "Journ. Comp. Phys.",
 YEAR = 1974, VOLUME = 14, PAGES = "301-317",
 ABSTRACT = {A program for the analytic evaluation of some parametric
integrals which occur in fourth order {QED} calculations is described.}}

@ARTICLE{Franceschetti:85,
 AUTHOR = "G. Franceschetti and I. Pinto",
 TITLE = "Nonlinear Propagation and Scattering:  Analytical Solution and
Symbolic Code Implementation",
 JOURNAL = "J. Opt. Soc. Am. A",
 YEAR = 1985, VOLUME = 2, PAGES = "997-1006",
 COMMENT = {Volterra series using {REDUCE}.  Perturbation expansions.}}

@INPROCEEDINGS{Freire:88,
 AUTHOR = "E. Freire and E. Gamero and E. Ponce and L. G. Franquelo",
 TITLE = "An Algorithm for Symbolic Computation of Center Manifolds",
 BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag",
 YEAR = 1988, VOLUME = 358, PAGES = "218-230"}

@INPROCEEDINGS{Freire:89,
 AUTHOR = "E. Freire and E. Gamero and E. Ponce",
 TITLE = "An Algorithm for Symbolic Computation of {Hopf} Bifurcation",
 BOOKTITLE = "Proc. Computers and Mathematics '89",
 EDITOR = "E. Kaltofen and S. M. Watt",
 YEAR = 1989, PAGES = "109-118", PUBLISHER = "Springer-Verlag, New York"}

@TECHREPORT{Frick:82,
 AUTHOR = "I. G. Frick and R. Fogelholm",
 TITLE = "An Implementation of {Standard} {Lisp} Built on Top of {Franz Lisp}",
 INSTITUTION = "University of Stockholm, Institute of
Physics", YEAR = 1982, TYPE = "Report", MONTH = "April",
 COMMENT = {A Standard {LISP} system has been built for the {VAX-11}
large-address-space computer by embedding the required function
definitions in the available Franz Lisp system for {VAX/UNIX}.}}

@ARTICLE{Fujimoto:84,
 AUTHOR = "Y. Fujimoto and T. Garavaglia",
 TITLE = "Phase Diagrams in {Scalar QED}",
 JOURNAL = "Physics Letters",
 YEAR = 1984, VOLUME = "148B", NUMBER = "1,2,3", PAGES = "220-224",
 MONTH = "November"}

@ARTICLE{Fuzio:85,
 AUTHOR = "P. M. Fuzio and G. E. Copeland",
 TITLE = "Partial Radiative-Recombination Cross Sections for Excited
States of Hydrogen",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1985, VOLUME = 31, NUMBER = 1, PAGES = "187-195",
 ABSTRACT = {The squares of the dipole and quadrupole matrix elements for the
free-to-bond transitions of hydrogen uptp high bound states are
derived in closed analytic form using a method suitable for computer
algebra.}}
%                          REDUCE BIBLIOGRAPHY

%                              Part 2:  G-L

% Copyright (c) 1990 The RAND Corporation.  All Rights Reserved.

% Additions and corrections are solicited.  Please send them, in the
% same format as these entries if possible, to reduce at rand.org.


@TECHREPORT{Gaemers,
 AUTHOR = "K. J. F. Gaemers and R. Gastmans and F. M. Renard",
 TITLE = "Neutrino Counting in e+ e- Collisions",
 INSTITUTION = "NIKHEF-H, Amsterdam", TYPE = "Preprint",
 ABSTRACT = {The possibility of counting the number of neutrino types
in e+ e- $\rightarrow$ gamma nu nubar is re-examined by taking into
account effects of the Z-pole.}}

@TECHREPORT{Gaemers:78,
 AUTHOR = "K. J. F. Gaemers and G. J. Gounaris",
 TITLE = "Polarization Amplitudes For e+e- $\rightarrow$ W+W-
$\rightarrow$ ZZ",
 INSTITUTION = "CERN", YEAR = 1978, TYPE = "Preprint",
 NUMBER = "TH.2548-CERN", MONTH = "August",
 ABSTRACT = {The main purpose of this work is to study the three weak boson
vertex.  We give explicit formulae for all polarization amplitudes of
the processes e+e- $\rightarrow$ W+W- and e+e- $\rightarrow$ ZZ, with
arbitrary couplings between the various intermediate vector bosons.}}

@INPROCEEDINGS{Ganzha:89,
 AUTHOR = "V. Ganzha and R. Liska",
 TITLE = "Application of the {REDUCE} Computer Algebra System to Stability
Analysis of Difference Schemes",
 BOOKTITLE = "Proc. Computers and Mathematics '89",
 EDITOR = "E. Kaltofen and S. M. Watt",
 YEAR = 1989, PAGES = "119-129", PUBLISHER = "Springer-Verlag, New York"}

@InProceedings{Ganzha90,
  author =      "Victor G. Ganzha and Michail Yu. Shaskov",
  title =       "Local Approximation Study of Difference Operators by
                 means of {REDUCE} System",
  booktitle =   "Proceedings of the International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "185-192",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@InProceedings{Ganzha90a,
  author =      "V. G. Ganzha and S. V. Meleshko and V. P. Shelest",
  title =       "Application of {REDUCE} System for Analyzing
                 Consistency of Systems of {P.D.E.'s}",
  booktitle =   "Proceedings of the International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "301",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@INPROCEEDINGS{Ganzha:91,
 AUTHOR = "V.G. Ganzha and B. Yu. Scobelev and E.V. Vorozhtsov",
 TITLE = "Stability Analysis of Difference Schemes by the Catastrophe
Theory Methods and by Means of Computer Algebra",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "427-428",
 YEAR = 1991}

@TECHREPORT{Garavaglia,
 AUTHOR = "Theodore Garavaglia",
 TITLE = "Polarized Electron Scattering on Spin Zero and Polarized Spin
$\frac{1}{2}$ Targets:  Deep Inelastic Scattering, Elastic Electron-muon
Scattering, and Elastic Electron-Nucleon Scattering",
 INSTITUTION = "Inst. Teich. Bhaile Atha Cliath, Eire", TYPE = "Preprint",
 ABSTRACT = {A covariant formulation is developed and used to derive
cross-sections for the analysis of experiments in which
polarized electrons(muons) are scattered from spin zero and
from polarized spin 1/2 targets.}}

@ARTICLE{Garavaglia:80,
 AUTHOR = "T. Garavaglia",
 TITLE = "A Covariant Formulation for Polarized Electron (Muon)
Scattering on Spin-Zero and Polarized Spin-$\frac{1}{2}$ Targets",
 JOURNAL = "Il Nuovo Cimento",
 YEAR = 1980, VOLUME = "56A", PAGES = "121-128",
 COMMENT = {{REDUCE} used in quantum mechanics.}}

@ARTICLE{Garavaglia:84,
 AUTHOR = "Theodore Garavaglia",
 TITLE = "{Dirac-} and {Majorana-neutrino-mass} effects in
{neutrino-electron} elastic scattering",
 JOURNAL = "Physical Review {D}",
 YEAR = 1984, VOLUME = 29, NUMBER = 3, PAGES = "387-392", MONTH = "February"}

@ARTICLE{Garcia:86,
 AUTHOR = "Arnaldo Garcia and Paulo Viana",
 TITLE = "Weierstrass Points on Certain Non-Classical Curves",
 JOURNAL = "Arch. Math.",
 YEAR = 1986, VOLUME = 46, PAGES = "315-322"}

@ARTICLE{Garrad:86,
 AUTHOR = "A. D. Garrad and D. C. Quarton",
 TITLE = "Symbolic Computing as a Tool in Wind Turbine Dynamics",
 JOURNAL = "Journ. of Sound and Vibration",
 YEAR = 1986, VOLUME = 109, NUMBER = 1, PAGES = "65-78",
 COMMENT = {{REDUCE} as a tool in turbine design, in particular present a
program for part of a stability analysis for a turbine tower.}}

@ARTICLE{Gastmans:79,
 AUTHOR = "R. Gastmans and A. van Proeyen and P. Verbaeten",
 TITLE = "Symbolic Evaluations of Dimensionally Regularized {Feynman}
Diagrams",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1979, VOLUME = 18, PAGES = "201-203",
 ABSTRACT = {A modification of the symbolic and algebraic manipulation
program {REDUCE} is reported which allows the treatment of vector and gamma
algebra in an arbitrary number of dimensions.}}

@TECHREPORT{Gatermann:90,
 AUTHOR = "Karin Gatermann",
 TITLE = "Gruppentheoretische {Konstruktion} von symmetrischen
{Kubaturformeln}",
 INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin",
 YEAR = 1990, TYPE = "Preprint", NUMBER = "TR 90-1", MONTH = "January"}

@InProceedings{Gatermann90a,
  author =      "Karin Gatermann",
  title =       "Symbolic solution of polynomial equation systems with
                 symmetry",
  booktitle =   "Proceedings of the 1990 International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "112-119",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@ARTICLE{Gatermann:91,
 AUTHOR = "Karin Gatermann and Andreas Hohmann",
 TITLE = "Symbolic Exploitation of Symmetry in Numerical Pathfollowing",
 JOURNAL = "IMPACT of Computing in Science and Engineering",
 YEAR = 1991, MONTH = "December", VOLUME = 3, NUMBER = 4,
 PAGES = "330-365",
 ABSTRACT = {{Parameter-dependent} systems of nonlinear equations with
symmetry are treated by a combination of symbolic and numerical computations.
In the symbolic part of the algorithm the complete analysis of the symmetry
occurs, and it is here where symmetrical normal forms, symmetry reduced
systems, and block diagonal Jacobians are computed.  Given a particular
problem, the symbolic algorithm can create and compute through the list of
possible bifurcations thereby forming a {so-called} tree of decisions
correlated to the different types of symmetry breaking bifurcation points.
The remaining part of the algorithm deals with the numerical pathfollowing
based on the implicit reparametrisation as suggested and worked out by
{Deuflhard/Fiedler/Kunkel}.  The symmetry preserving bifurcation points are
computed using recently developed augmented systems incorporating the use
of symmetry.}}

@INPROCEEDINGS{Gatermann:91a,
 AUTHOR = "Karin Gatermann",
 TITLE = "Mixed symbolic-numeric solution of symmetrical nonlinear systems",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt",
 ORGANIZATION =        "ACM",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "431-432",
 YEAR = 1991,
 ABSTRACT = {The mixed symbolic-numeric algorithm {SYMCON} for the fully
automatical treatment of equivariant systems is presented. The global
aspects of the theory of Vanderbauwhede for these systems are viewed with
regard to the full bifurcation scenario containing solution paths with
different isotropy groups and symmetry preserving and symmetry breaking
bifurcation points.  The advanced exploitation of symmetry in the numerical
computations causes an comprehensive symmetry analysis and complicated
organization of numerical work which is done by the symbolic part of the
algorithm.}}

@TECHREPORT{Gatermann:91b,
 AUTHOR = "Karin Gatermann and Andreas Hohmann",
 TITLE = "Hexagonal Lattice Dome--Illustration of a Nontrivial Bifurcation
Problem",
 INSTITUTION = "Konrad-Zuse-Zentrum {f\"u}r Informationstechnik Berlin",
 YEAR = 1991, MONTH = "July", TYPE = "Preprint", NUMBER = "SC-91-8"}
 ABSTRACT = {The deformation of a hexagonal lattice dome under an external
load is an example of a parameter dependent system which is equivariant
under the symmetry group of a regular hexagon.  In this paper the mixed
symbolic-numerical algorithm SYMCON is applied to analyze its steady state
solutions automatically showing their different symmetry and stability
properties.}}

@INPROCEEDINGS{Gates:85,
 AUTHOR = "Barbara L. Gates and J. A. van Hulzen",
 TITLE = "Automatic Generation of Optimized Programs",
 BOOKTITLE = "Proc. {EUROCAL} '85", YEAR = 1985,
 MONTH = "April"}

@ARTICLE{Gates:85a,
 AUTHOR = "Barbara L. Gates",
 TITLE = "Gentran:  An Automatic Code Generation Facility
for {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "24-42", MONTH = "August"}

@TECHREPORT{Gates:85b,
 AUTHOR = "Barbara L. Gates",
 TITLE = "Gentran User's Manual - {REDUCE} Version",
 INSTITUTION = "Twente University of Technology, Department of
Computer Science, The Netherlands", TYPE = "Memorandum",
 YEAR = 1985, NUMBER = "INF-85-11", MONTH = "June"}

@TECHREPORT{Gates:85c,
 AUTHOR = "Barbara L. Gates",
 TITLE = "Gentran Design and Implementation, {REDUCE} Version",
 INSTITUTION = "Twente University of Technology, Department of Computer
Science, The Netherlands", YEAR = 1985, TYPE = "Memorandum",
 NUMBER = "INF-85-12", MONTH = "August"}

@INPROCEEDINGS{Gates:86,
 AUTHOR = "Barbara L. Gates",
 TITLE = "A Numerical Code Generation Facility for {REDUCE}",
 BOOKTITLE = "Proc. {SYMSAC} '86",
 YEAR = 1986, PAGES = "94-99", MONTH = "July"}

@TECHREPORT{Gebauer:85,
 AUTHOR = "R{\"u}diger Gebauer and H. Michael M{\"o}ller",
 TITLE = "A Fast Variant of {Buchberger's} Algorithm",
 INSTITUTION = "Universit{\"a}t Heidelberg and
Fernuniversit{\"a}t {Hagen}", YEAR = 1985, MONTH = "October"}

@ARTICLE{Gebauer:88,
 AUTHOR = "R{\"u}diger Gebauer and H. Michael M{\"o}ller",
 TITLE = "On an Installation of {Buchberger's} Algorithm",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1988, VOLUME = 6, NUMBER = "2 and 3", PAGES = "275-286"}

@ARTICLE{George:68,
 AUTHOR = "D. J. George",
 TITLE = "A Covariant Theory of the Disintegration of the
Deuteron by Pions and Photons at High Energy",
 JOURNAL = "Phys. Rev.",
 YEAR = 1968, VOLUME = 167, PAGES = "1357-1364"}

@ARTICLE{Gerdt:80,
 AUTHOR = "V. P. Gerdt",
 TITLE = "Analytical Calculations in High Energy Physics by Computer",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1980, VOLUME = 20, PAGES = "85-90",
 COMMENT = {A review, comparing {SCHOONSCHIP, ASHMEDAI and REDUCE-2}.}}

@ARTICLE{Gerdt:80a,
 AUTHOR = "V. P. Gerdt and O. V. Tarasov and D. V. Shirkov",
 TITLE = "Analytical Calculations on Digital Computers for Applications
in Physics and Mathematics",
 JOURNAL = "Sov. Phys. USP",
 YEAR = 1980, VOLUME = 23, PAGES = "59-77",
 COMMENT = {General review of applications in many languages.}}

@TECHREPORT{Gerdt:80b,
 AUTHOR = "V. P. Gerdt",
 TITLE = "On Global Structure of the General Solution of the
{Chew-Low} Equations",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1980, TYPE = "Preprint", NUMBER = "P2-80-436"}

@ARTICLE{Gerdt:85,
 AUTHOR = "V. P. Gerdt and A. B. Shvachka and A. Yu. Zharkov",
 TITLE = "Computer Algebra Application for Classification of
Integrable Non-Linear Evolution Equations",
 JOURNAL = "J. Symb. Comp.",
 YEAR = 1985, VOLUME = 1, PAGES = "101-107"}

@TECHREPORT{Gerdt:85a,
 AUTHOR = "V. P. Gerdt and N. A. Kostov and P. P. Raychev
and R. P. Roussev",
 TITLE = "Calculation of the Matrix Elements of the
{Hamiltonian} of the Interacting Vector Boson Model Using
Computer Algebra - Basic Concepts of the Interacting Vector
Boson Model and Matrix Elements of the {SU(3)-Quadrupole}
Operator",
 INSTITUTION = "Institute for Nuclear Research and Nuclear
Energy, Bulgarian Academy of Sciences, Sofia, Bulgaria",
 YEAR = 1985, NUMBER = "E4-85-262"}

@TECHREPORT{Gerdt:85b,
 AUTHOR = "V. P. Gerdt and N. A. Kostov and P. P. Raychev",
 TITLE = "Calculation of the Matrix Elements of the
{Hamiltonian} of the Interacting Vector Boson Model Using
Computer Algebra - Matrix Elements of the {Hamiltonian} and
Some {U(6)-Clebsch-Gordon} Coefficients",
 INSTITUTION = "Institute for Nuclear Research and Nuclear
Energy, Bulgarian Academy of Sciences, Sofia, Bulgaria",
 YEAR = 1985, NUMBER = "E4-85-263"}

@TECHREPORT{Gerdt:85c,
 AUTHOR = "V. P. Gerdt and N. A. Kostov and P. P. Raychev
and R. P. Roussev",
 TITLE = "Calculation of the Matrix Elements of the
{Hamiltonian} of the Interacting Vector Boson Model
Using Computer Algebra - Matrix Elements of the {Hamiltonian} -
Analytical Results",
 INSTITUTION = "Institute for Nuclear Research and Nuclear
Energy, Bulgarian Academy of Sciences, Sofia, Bulgaria",
 YEAR = 1985, NUMBER = "E4-85-264"}

@TECHREPORT{Gerdt:86,
 AUTHOR = "V. P. Gerdt and M. G. Meshcheryakov and D. V. Shirkov",
 TITLE = "Computers in Theoretical Physics",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1986, NUMBER = "P2-86-848",
 ABSTRACT = {The paper is written on the basis of the report presented by
two authors ({M.G. Meshcheryakov} and {D.V. Shirkov}) at the 60th session
of the JINR Scientific Council, June 5, 1986.  It reviews the usage of
computer mathematics in theoretical and mathematical investigations
carried out in the Joint Institute.  Recommendations are given on further
development of the JINR Computer Center in accordance with the program of
theoretical researches in nearest Five-Year Plan.}}

@INPROCEEDINGS{Gerdt:87,
 AUTHOR = "V. P. Gerdt and A. B. Shabat and S. I. Svinolupov
and A. Yu. Zharkov",
 TITLE = "Computer Algebra Application for Investigating
Integrability of Nonlinear Evolution Systems",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "81-92",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{Gerdt:87a,
 AUTHOR = "V. P. Gerdt and N. A. Kostov and Z. T. Kostova",
 TITLE = "Computer Algebra and Computation of {Puiseux} Expansions of
Algebraic Functions",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "206-207",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{Gerdt:89,
 AUTHOR = "V. P. Gerdt and N. A. Kostov",
 TITLE = "Computer Algebra in the theory of Ordinary Differential Equations
of Halphen type",
 BOOKTITLE = "Proc. Computers and Mathematics '89",
 EDITOR = "E. Kaltofen and S. M. Watt",
 YEAR = 1989, PAGES = "279-288", PUBLISHER = "Springer-Verlag, New York"}

@TECHREPORT{Gerdt:89a,
 AUTHOR = "V. P. Gerdt and Z. T. Kostova and N. A. Kostov and I. P. Yudin",
 TITLE = "Algebraic-Numeric Calculations of Proton Trajectories in Bending
Magnets of Synchrotron Accelerator",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1989, TYPE = "Preprint", NUMBER = "E11-89-755",
 ABSTRACT = {We study a solution of nonlinear differential equation of the
second degree which describes the trajectories of the charged particles in
the fully inhomogeneous field of cyclic accelerator.  We give the clear
mathematical statement of the problem and algorithm of solving it.  We
realize this algorithm on the Computer Algebra System {REDUCE 3.2}.  Our
algorithm is based both on the existence of exact solution in terms of
hyperelliptic integral and on the existence of power series solution of
specific inversion problem.  We use the known {REDUCE} procedures of
operation on generalized power series.  Using the {FORTRAN} code we give the
numerical analysis of these series in the close relation to the concrete
physical situation.  We apply our results to the beam dynamics modeling
of the protons in the bending magnets in synchrotron accelerator.}}

@TECHREPORT{Gerdt:89b,
 AUTHOR = "V. P. Gerdt and A. Yu. Zharkov",
 TITLE = "Solving the Polynomial System Arising in Classification of
Integrable Coupled {KdV-like} Systems",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1989, TYPE = "Preprint", NUMBER = "P5-89-231",
 ABSTRACT = {A system of algebraic equations which follows from the
necessary integrability conditions for the {ten-parametric} family of
coupled {KdV-like} nonlinear evolution systems is considered.  The method
for solving this system based on the structure of the canonical local
conservation laws densities is described.  Computer algebra system
{REDUCE} was used to find all the solutions.  As a result we obtain the
complete list of integrable coupled {KdV-like} systems.}}

@InProceedings{Gerdt90,
  author =      "V. P. Gerdt and A. Yu. Zharkov",
  title =       "Computer Generation of Necessary Integrability
                 Conditions for Polynomial-Nonlinear Evolution Systems",
  booktitle =   "Proceedings of the International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "250-254",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@InProceedings{Gerdt90a,
  author =      "Vladimar P. Gerdt and Nikolai V. Khutornoy and Alexey
                 Yu. Zharkov",
  title =       "Solving Algebraic Systems which arise as Necessary
                 Integrability Conditions for Polynomial-Nonlinear
                 evolution Equations",
  booktitle =   "Proceedings of the International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "299",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@ARTICLE{Gerdt:90b,
 AUTHOR = "V. P. Gerdt and A. Yu. Zharkov",
 TITLE = "Computer Classification of Integrable Coupled {KdV-Like} Systems",
 JOURNAL = "J. Symb. Comp.",
 YEAR = 1990, VOLUME = 10, PAGES = "203-207",
 ABSTRACT = {The foundations of the symmetry approach to the classification
problem of integrable {non-linear} evolution systems are briefly described.
Within the framework of the symmetry approach the {ten-parametric} family
of the third order {non-linear} evolution coupled {KdV-like} systems is
investigated.  The necessary integrability conditions lead to an
{over-determined} {non-linear} algebraic system.  To solve that system an
effective method based on its structure has been used.  This allows us
to obtain the complete list of integrable systems of a given type. All
computation has been completed on the basis of computer algebra systems
{FORMAC} and {REDUCE}.}}

@INPROCEEDINGS{Gerdt:90c,
 AUTHOR = "V. P. Gerdt and N. A. Kostov and A. Yu. Zharkov",
 TITLE = "Nonlinear Evolution Equations and Solving Algebraic Systems:
The Importance of Computer Algebra",
 YEAR = 1990,
 BOOKTITLE = "International Conference on Solitons and Its Applications",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "120-128"}
 ABSTRACT = {In the present paper we study the application of computer
algebra to solve the nonlinear polynomial systems which arise in
investigation of nonlinear evolution equations.  We consider several
systems which are obtained in classification of integrable nonlinear
evolution equations with uniform rank.  Other polynomial systems are related
with the finding of algebraic curves for finite-gap elliptic potentials of
{Lame} type and generalizations.  All systems under consideration are
solved using the method based on construction of the {Groebner} basis for
corresponding polynomial ideals.  The computations have been carried out
using computer algebra systems.}}

@INPROCEEDINGS{Gerdt:91,
 AUTHOR = "V. P. Gerdt and A. Yu. Zharkov",
 TITLE = "Lie-B{\"a}cklund Symmetries of Coupled Nonlinear
Schr{\"o}dinger Equations",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "313-314",
 YEAR = 1991}

@TECHREPORT{Gerdt:91a,
 AUTHOR = "V. P. Gerdt and P. Tiller",
 TITLE = "A Reduce Program for Symbolic Computation of Puiseux Expansions",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1991, TYPE = "Preprint", NUMBER = "E5-91-401"}
 ABSTRACT = {The program is described for computation of Puiseux expansions
of alebraic functions.  The Newton polygon method is used for construction
of initial coefficients of all the Puiseux series at the given point.  The
program is written in computer algebra language Reduce.  Some illustrative
examples are given.}}

@TECHREPORT{Gerdt:91b,
 AUTHOR = "V. P. Gerdt",
 TITLE = "Computer Algebra Tools for Higher Symmetry Analysis of Nonlinear
Evolution Equations",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1991, TYPE = "Preprint", NUMBER = "E5-91-402"}
 ABSTRACT = {This paper presents a computer-aided approach and a software
package for symbolic algebraic computation to solve the problem of
verifying the existence of the canonical Lie-B{\"a}cklund symmetries
for multicomponent quasilinear evolution equations with polynomial-
nonlinearity and computing a given order symmetry if any.  In the presence
of arbitrary numerical parameters the problem is reduced to investigation
and solving of nonlinear algebraic equations in those parameters.  It is
remarkable that in all the known cases these algebraic equations are
completely solvable by the Gr{\"o}bner basis technique implemented as a part
of the software package.}}

@ARTICLE{Gervois:74,
 AUTHOR = "A Gervois and Y. Pomeau",
 TITLE = "Logarithmic Divergence in the Virial Expansion
of Transport Coefficients of Hard Spheres",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1974, VOLUME = 9, PAGES = "2196-2213"}

@TECHREPORT{Gladd:82,
 AUTHOR = "N. T. Gladd",
 TITLE = "Computational Aspects of Research on the
Relativistic {Whistler} Instability",
 INSTITUTION = "Jaycor", YEAR = 1982,
 NUMBER = "J530-82-020", MONTH = "June"}

@INPROCEEDINGS{Gladkih:83,
 AUTHOR = "I. Gladkih and E. Lovas",
 TITLE = "On the Application of Computer Algebra Languages in the {Central
Research Institute for Physics}",
 BOOKTITLE = "Proceedings of the International Conference on Systems and
Techniques of Analytical Computing and Their Applications in Theoretical
Physics, {D11-83-511, Dubna}", YEAR = 1983}

@INPROCEEDINGS{Gladkih:84,
 AUTHOR = "I. Gladkih and M. Zimanyi",
 TITLE  = "Comparison of systems for Symbolic Computing in use in the
{Central Research Institute for Physics} (in {Russian})",
 BOOKTITLE = "Proceedings of the International Conference on {Computer-Based}
Scientific Research, Plovdiv", YEAR =  1984}

@ARTICLE{Goldman:89,
 AUTHOR = "V. V. Goldman and J. A. van Hulzen",
 TITLE = "Automatic Code Vectorization of Arithmetic Expressions by
Bottom-Up Structure Recognition",
 JOURNAL = "Computer Algebra and Parallelism", EDITOR = "J. Della Dora
and J. Fitch",
 YEAR = 1989, PAGES = "119-132", PUBLISHER = "Academic Press, London"}

@INPROCEEDINGS{Golley,
 AUTHOR = "Bruce W. Golley and Joseph Petrolito",
 TITLE = "An Alternative Finite Strip Technique for the Static Analysis of
Single-Span, Multi-Span and Continuous Plates",
 YEAR = 1982,
 BOOKTITLE = "Proc. International Conference on
Finite Element Methods"}

@ARTICLE{Good:75,
 AUTHOR = "D. Good and R. L. London and W. W. Bledsoe",
 TITLE = "An Interactive Program Verification System",
 JOURNAL = "Sigplan Notices",
 YEAR = 1975, VOLUME = 10, NUMBER = 6, PAGES = "482-492"}

@ARTICLE{Goto:77,
 AUTHOR = "E. Goto and T. Soma",
 TITLE = "{MOL} (Moving Objective Lens) Formulation of
Deflective Aberration Free System",
 JOURNAL = "Optik",
 YEAR = 1977, VOLUME = 48, PAGES = "255-270"}

@INPROCEEDINGS{Goto:78,
 AUTHOR = "E. Goto and T. Soma",
 TITLE = "Electron Beam Lithography for Advanced {LSI} Fabrication",
 YEAR = 1978, PAGES = "1223-1228",
 BOOKTITLE = "Proc. 1978 National Computer Conference,
{AFIPS} Press, New Jersey"}

@ARTICLE{Gould:84,
 AUTHOR = "H. W. Gould and M. E. Mays",
 TITLE = "Series Expansions of Means",
 JOURNAL = "Journ. of Mathematical Analysis and Applications",
 YEAR = 1984, VOLUME = 101, NUMBER = 2, PAGES = "611-621",
 MONTH = "July"}

@PHDTHESIS{Gragert:81,
 AUTHOR = "Peter Gragert",
 TITLE = "Symbolic Computations in Prolongation Theory",
 SCHOOL = "Twente University of Technology, The Netherlands",
 YEAR = 1981}

@BOOK{Grammaticos,
 AUTHOR = "B. Grammaticos and A. Voros",
 TITLE = "Semi-Classical Approximations for Nuclear
{Hamiltonians}:  {II}. {Spin-dependent} Potentials",
 ABSTRACT = {A systematic semi-classical expansion procedure for physical
quantities in nuclei, based on the Thomas-Fermi approximation
to the Hartree-Fock equations and constructed in a previous
work, is extended here to the realistic case where the
effective one-body {Hamiltonian} for nucleons contains
spin-dependent terms.}}

@TECHREPORT{Grammaticos:78,
 AUTHOR = "B. Grammaticos and A. Voros",
 TITLE = "Semi-classical Approximations for Nuclear
{Hamiltonians} {I}. {Spin-independent} Potentials",
 INSTITUTION = "CEN, Saclay", YEAR = 1978, TYPE = "Preprint",
 NUMBER = "DPh-T/78-75", MONTH = "August",
 COMMENT = {Submitted to Annals of Physics},
 ABSTRACT = {A systematic procedure for calculating semi-classical
expansions of physically interesting quantities is presented.}}

@ARTICLE{Grammaticos:85,
 AUTHOR = "B. Grammaticos and B. Dorizzi and A. Ramani and J. Hietarinta",
 TITLE = "Extending integrable {Hamiltonian} systems from 2 to {N}
dimensions",
 JOURNAL = "Phys. Lett.",
 YEAR = 1985, VOLUME = "109A", PAGES = "81-84",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@ARTICLE{Greenland:84,
 AUTHOR = "P. T. Greenland",
 TITLE = "Comparison Between Phase Diffusion and Random Telegraph Signal
Models of Laser Bandwidth",
 JOURNAL = "Journ. Phys. B",
 YEAR = 1984, VOLUME = 17, PAGES = "1919-1925",
 COMMENT = {{REDUCE} calculation of correlation matrix for molecular physics.
Tedious, but simple result.}}

@ARTICLE{Grimm,
 AUTHOR = "R. Grimm and H. K{\"u}hnelt",
 TITLE = "Using {REDUCE} in Problems of Supersymmetry and Supergravity",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1980, VOLUME = 20, PAGES = "77",
 COMMENT = {Describes how {REDUCE} may be used with advantage in tedious
calculations of supersymmetry and supergravity.}}

@INPROCEEDINGS{Griss:74,
 AUTHOR = "M. L. Griss",
 TITLE = "The Algebraic Solution of Large Sparse Systems of Linear
Equations Using {REDUCE} 2",
 YEAR = 1974, PAGES = "105-111",
 BOOKTITLE = "Proc. ACM 74",
 ABSTRACT = {This paper discusses some of the problems encountered during the
solution of a large system of sparse linear equations with algebraic
coefficients, using {REDUCE} 2.}}

@ARTICLE{Griss:74a,
 AUTHOR = "M. L. Griss",
 TITLE = "The Algebraic Solution of Sparse Linear Systems Via Minor
Expansion",
 JOURNAL = "ACM TOMS 2",
 YEAR = 1976, PAGES = "31-49",
 ABSTRACT = {An improved algorithm for computing the determinants of a (large)
sparse matrix of polynomials is described.}}

@INPROCEEDINGS{Griss:75,
 AUTHOR = "Martin L. Griss",
 TITLE = "The {REDUCE} System for Computer Algebra",
 BOOKTITLE = "Proc. ACM 75",
 YEAR = 1975, PAGES = "4-5",
 ABSTRACT = {A brief description of {REDUCE} is presented.}}

@INPROCEEDINGS{Griss:76,
 AUTHOR = "Martin L. Griss",
 TITLE = "The Definition and Use of Data-Structures in {REDUCE}",
 BOOKTITLE = "Proc. SYMSAC 76",
 YEAR = 1976, PAGES = "53-59",
 ABSTRACT = {This paper gives a brief description and motivation of the mode
analyzing and data-structuring extensions to the algebraic language
{REDUCE}.}}

@INPROCEEDINGS{Griss:76a,
 AUTHOR = "Martin L. Griss",
 TITLE = "An Efficient Sparse Minor Expansion Algorithm",
 BOOKTITLE = "Proc. ACM 76",
 YEAR = 1976, PAGES = "429-434",
 ABSTRACT = {An improved algorithm for computing the minors of a (large)
sparse matrix of polynomials is described, with emphasis on efficiency and
optimal ordering.  A possible application to polynomial resultant
computation is discussed.}}

@INPROCEEDINGS{Griss:77,
 AUTHOR = "Martin L. Griss",
 TITLE = "Efficient Expression Evaluation in Sparse Minor
Expansion, Using Hashing and Deferred Evaluation",
 YEAR = 1977, PAGES = "169-172",
 BOOKTITLE = "Proc. 10th Hawaii International Conference on
Systems Sciences, Western Periodicals, Calif.",
 ABSTRACT = {Efficient computation of the determinant of a matrix with
symbolic entries using minor expansion requires careful control of expression
evaluation.  The use of hashing and deferred evaluation to avoid
excess computation is explored.}}

@ARTICLE{Griss:77a,
 AUTHOR = "M. L. Griss",
 TITLE = "Efficient Recursive Minor Expansion",
 JOURNAL = "ACM TOMS",
 YEAR = 1977,
 ABSTRACT = {The use of a "memo" facility to develop an efficient recursive
minor expansion algorithm (RMEM) is discussed.  The method is simple and
efficient, and can be implemented as an interesting non-trivial
recursive procedure.  The method is particularly attractive for
sparse symbolic matrices, and can also be used to enhance other
minor expansion methods developed for sparse symbolic matrices.}}

@ARTICLE{Griss:78,
 AUTHOR = "Martin L. Griss",
 TITLE = "Using an Efficient Sparse Minor Expansion Algorithm to Compute
Polynomial Subresultants and the Greatest Common Denominator",
 JOURNAL = "IEEE Trans on Computers",
 YEAR = 1978, VOLUME = "C-27", NUMBER = 10, PAGES = "945-950",
 ABSTRACT = {In this paper, the use of an efficient sparse minor expansion
method to directly compute the subresultants needed for the {GCD} of two
polynomials is described.  The sparse minor expansion method (applied
either to Sylvester's or Bezout's matrix) naturally computes the
coefficients of the subresultants in the order corresponding to
a {PRS}, avoiding wasteful recomputation as much as possible.  It is
suggested that this is an efficient method to compute the Resultant
and {GCD} of Sparse Polynomials.}}

@INPROCEEDINGS{Griss:78a,
 AUTHOR = "Martin L. Griss and Robert R. Kessler",
 TITLE = "{REDUCE}/1700:  A Micro-coded Algebra System",
 YEAR = 1978, VOLUME = 11, PAGES = "130-138",
 BOOKTITLE = "Proc. Micro, {IEEE}",
 ABSTRACT = {In this paper, we report on the status of an ongoing project
aimed at producing a micro-coded Algebra machine.}}

@ARTICLE{Griss:79,
 AUTHOR = "Martin L. Griss and Anthony C. Hearn",
 TITLE = "Portable {LISP} Compiler",
 JOURNAL = "Software - Practice and Experience", VOLUME = 11,
 PAGES = "541-605", YEAR = 1979,
 ABSTRACT = {This paper describes the development of a portable {LISP}
compiler in the sense that only Standard {LISP} functions are used in its
definition and the output is a sequence of standard macro calls
easily implementable on current computers.}}

@TECHREPORT{Griss:79a,
 AUTHOR = "Martin L. Griss and Robert R. Kessler",
 TITLE = "A Micro-programmed Implementation of {Standard} {LISP} and
{REDUCE} on the {Burroughs B1700/B1800} Computer",
 INSTITUTION = "University of Utah", YEAR = 1979, TYPE = "Report",
 MONTH = "February",
 ABSTRACT = {This paper describes the implementation of a microcoded {LISP}
"machine" (the MTLISP) for the Burroughs B1700/B1800 computers.
This interpreter supports a complete Standard {LISP} and {REDUCE}
Algebra system, as well as a variety of experimental {LISP-like}
systems.}}

@INPROCEEDINGS{Grozin:83,
 AUTHOR={A.G.Grozin},
 TITLE={Calculation of one-loop diagrams of {$1 \to 2$} decays with REDUCE},
 BOOKTITLE={Proc. Int. Conf. on Computer Algebra in Theoretical Physics,
Dubna},
 YEAR = 1983, PAGES = {226-231},
  COMMENT = {To appear in Phys. Lett. B}}

@TECHREPORT{Grozin:88,
 AUTHOR = "A. G. Grozin",
 TITLE = "Solving Physical Problems with {REDUCE.}  {1. REDUCE}
Language {2. Classical} Nonlinear Oscillator",
 INSTITUTION = "Institute of Nuclear Physics 630090, Novosibirsk,
{USSR}", YEAR = 1988, TYPE = "Preprint", NUMBER = "88-115",
 ABSTRACT = {This preprint is the first part of the problem book on using
{REDUCE} in physics.  It contains many examples useful for the
construction of programs for solving physical problems of very
different nature.  This part contains examples illustrating {REDUCE}
language (sect. 1) and the problem of classical nonlinear
oscillator (sect. 2).  To be published (with additions) as a book with
"Nauka" publishers, Moscow.}}

@TECHREPORT{Grozin:88a,
 AUTHOR = "A. G. Grozin",
 TITLE = "Solving Physical Problems with {REDUCE.}  {3. Nonlinear}
Water Waves {4. Calculation} of the Curvature Tensor {5. Angular}
Momentum Addition",
 INSTITUTION = "Institute of Nuclear Physics 630090, Novosibirsk,
{USSR}", YEAR = 1988, TYPE = "Preprint", NUMBER = "88-136",
 ABSTRACT = {This preprint is the second part of the problem book on using
{REDUCE} in physics.  It contains many examples useful for the construction of
programs for solving physical problems of very different nature.  This
part contains the problem of nonlinear water waves (sect. 3), the
calculation of the curvature tensor (sect. 4) and angular momentum
addition (sect. 5).}}

@TECHREPORT{Grozin:88b,
 AUTHOR = "A. G. Grozin",
 TITLE = "Solving Physical Problems with {REDUCE.}  {6. Quantum}
Nonlinear Oscillator {7. Rotator} in a Weak Field {8. Radiative}
Transitions in Charmonium",
 INSTITUTION = "Institute of Nuclear Physics 630090, Novosibirsk,
{USSR}", YEAR = 1988, TYPE = "Preprint", NUMBER = "88-140",
 ABSTRACT = {This preprint is the last part of the problem book on using
{REDUCE} in physics.  It contains many examples useful for the construction of
programs for solving physical problems of very different nature.  This
part contains the problem of quantum nonlinear oscillator (sect. 6),
rotator in a weak field (sect. 7) and radiative transitions in
charmonium (sect. 8).}}

@TECHREPORT{Grozin:90,
 AUTHOR = {A.G.Grozin},
 TITLE = {{REDUCE} in elementary particle physics. Introduction},
 INSTITUTION = {Institute of Nuclear Physics, Novosibirsk},
 YEAR = 1990, NUMBER = {INP 90-42},
 COMMENT = {These 5 preprints together with the previous 3 will be published
as a book "Solving physical problems with REDUCE"}}

@TECHREPORT{Grozin:90a,
 AUTHOR = {A.G.Grozin},
 TITLE = {{REDUCE} in elementary particle physics. Quantum electrodynamics},
 INSTITUTION = {Institute of Nuclear Physics, Novosibirsk},
 YEAR = 1990, NUMBER = {INP 90-71}}

@TECHREPORT{Grozin:90b,
 AUTHOR = {A.G.Grozin},
 TITLE = {{REDUCE} in elementary particle physics. Quantum chromodynamics},
 INSTITUTION = {Institute of Nuclear Physics, Novosibirsk},
 YEAR = 1990, NUMBER = {INP 90-62}}

@TECHREPORT{Grozin:91,
 AUTHOR = {A.G.Grozin},
 TITLE = {{REDUCE} in elementary particle physics. Weak interactions},
 INSTITUTION = {Institute of Nuclear Physics, Novosibirsk},
 YEAR = 1991, NUMBER = {INP 91-56}}

@TECHREPORT{Grozin:91a,
 AUTHOR = {A.G.Grozin},
 TITLE = {{REDUCE} in elementary particle physics. Radiative corrections},
 INSTITUTION = {Institute of Nuclear Physics, Novosibirsk},
 YEAR = 1991, NUMBER = {INP 91-46}}

@ARTICLE{Gunion:72,
 AUTHOR = "J. F. Gunion and S. J. Brodsky and R. Blankenbecler",
 TITLE = "Composite Theory of Large Angle Scattering and New
Tests of Parton Concepts",
 JOURNAL = "Phys. Lett.",
 YEAR = 1972, VOLUME = "39B", PAGES = "649-653"}

@TECHREPORT{Gunion:73,
 AUTHOR = "J. F. Gunion and S. J. Brodsky and R. Blankenbecler",
 TITLE = "Large Angle Scattering and the Interchange Force",
 INSTITUTION = "SLAC",
 YEAR = 1973, TYPE = "Report", NUMBER = "SLAC-PUB-1183"}

@ARTICLE{Gunion:85,
 AUTHOR = "J. F. Gunion and Z. Kunszt",
 TITLE = "Improved Analytic Techniques for Tree Graph Calculations and
the $g g q {\bar q} l {\bar l}$ subprocess",
 JOURNAL = "Phys. Lett.",
 YEAR = 1985, VOLUME = "161B", PAGES = "333-340"}

@ARTICLE{Hadinger:87,
 AUTHOR = "G. Hadinger and Y. S. Tergimen",
 TITLE = "Recurrence Relations for the {Dunham} Coefficients and Analytic
Expressions of the Diagonal Radial Matrix Elements for an Anharmonic
Oscillator",
 JOURNAL = "Journ. Chem. Phys.",
 YEAR = 1987, VOLUME = 87, NUMBER = 4, PAGES = "2143-2150",
 COMMENT = {"As an illustrative application, all the set of $Y_{n}$
coefficients previously published are found again by using the
computer algebraic manipulation language {REDUCE}.  A number of diagonal
matrix elements of {CO, HBr and HCl} have been symbolically computed and
compared with previous available results."  Their method depends on
some algebraic manipulation, and the main point is that automation
gives a simpler formulation of the problem.}}

@ARTICLE{Handy:87,
 AUTHOR = "N. C. Handy",
 TITLE = "The Derivation of Vibration-Rotation Kinetic Energy Operators,
in Internal Coordinates",
 JOURNAL = "Mol. Phys.",
 YEAR = 1987, VOLUME = 61, PAGES = "207-223",
 COMMENT = {{REDUCE USED} to produce a straightforward method for the
derivation of kinetic energy operators in molecular vibration-rotation.  He
notes in the introduction "The purpose of this paper is to derive a simple and
straightforward procedure for which it is possible to make the
computer do all the hard work.  After many years of investigating this
problem, this author believes that this must be the reliable way to
proceed."}}

@PHDTHESIS{Harper:87,
 AUTHOR = "David Harper",
 TITLE = "Dynamics of the Outer Satellites of Saturn",
 SCHOOL = "Univ. of Liverpool, England",
 YEAR = 1987}

@TECHREPORT{Harper:89,
 AUTHOR = "David Harper and Chris Wooff and David Hodgkinson",
 TITLE = "A Guide to Computer Algebra Systems",
 INSTITUTION = "Computer Laboratory, The University of Liverpool,
Liverpool, England", YEAR = 1989, MONTH = "September", TYPE = "Report"}

@ARTICLE{Harper:89a,
 AUTHOR = "David Harper",
 TITLE = "{Vector33:}  A {REDUCE} Program for Vector Algebra and Calculus
in Orthogonal Curvilinear Coordinates",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1989, VOLUME = 54, NUMBER = "2 and 3", PAGES = "295-305",
 MONTH = "June and July"}

@ARTICLE{Harrington:77,
 AUTHOR = "Steven J. Harrington",
 TITLE = "A Symbolic Limit Evaluation Program in {REDUCE}",
 YEAR = 1977,
 ABSTRACT = {A program for the automatic evaluation of algebraic
limits, implemented in {MODE-REDUCE}, is described.  The program
incorporates many of the techniques previously employed, including
the top-down recursive evaluation, power series expansion, and
L'Hopital's rule.  It also introduces the concept of a special
algebraic form for limits.}}

@ARTICLE{Harrington:77a,
 AUTHOR = "S. J. Harrington",
 TITLE = "{REDUCE} Solution to Problem \#8",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = "1977 and 1978", VOLUME = "11 and 12", NUMBER = "4 and 1",
 PAGES = "7-8", MONTH = "November and February"}

@ARTICLE{Harrington:79,
 AUTHOR = "Steven J. Harrington",
 TITLE = "A New Symbolic Integration System in {REDUCE}",
 JOURNAL = "Comp. Journ.",
 YEAR = 1979, VOLUME = 22, NUMBER = 2, PAGE = "127-131",
 ABSTRACT = {A new integration system, employing both algorithmic and
pattern match integration schemes is presented.  The organization of the
system differs from that of earlier programs in its emphasis on the
algorithmic approach to integration, its modularity, and its ease of
revision.  The new {Norman-Risch} algorithm and its implementation at the
University of Cambridge are employed, supplemented by a powerful
collection of simplification and transformation rules.  The facility for
user defined integrals and functions is also included.  The program is
both fast and powerful, and can be easily modified to incorporate
anticipated developments in symbolic integration.}}

@ARTICLE{Harrington:79a,
 AUTHOR = "Steven J. Harrington",
 TITLE = "A Symbolic Limit Evaluation Program in {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1979, VOLUME = 13, NUMBER = 1, PAGES = "27-31", MONTH = "February"}

@ARTICLE{Hartley:91,
 AUTHOR = "David Hartley and Robin W. Tucker",
 TITLE = "A Constructive Implementation of the {Cartan-K{\"a}hler} Theory
of Exterior Differential Systems",
 JOURNAL = "J. Symb. Comp.",
 YEAR = 1991, VOLUME = 12, NUMBER = 6, PAGES = "655-667",
 MONTH = "December",
 ABSTRACT = {An efficient algorithm for the construction of a regular chain
of involutive integral elements for a general exterior differential system
is presented.  It is based upon the existence theorems of the
{Cartan-}K{"\a}hler theory, and may be used to analyse partial differential
equations by formulating them as exterior differential systems.}}

@ARTICLE{Hasenfratz:80,
 AUTHOR = "Anna Hasenfratz and Peter Hasenfratz",
 TITLE = "The Connection Between the Parameters of Lattice and
Continuum {QCD}",
 JOURNAL = "Phys. Lett.",
 YEAR = 1980, VOLUME = "93B", NUMBER = "1,2", PAGES = "165-169",
 MONTH = "June"}

@INPROCEEDINGS{Hearn:68,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "{REDUCE}: A User-Oriented Interactive System for Algebraic
Simplification",
 YEAR = 1968, PAGES = "79-90",
 EDITOR = "M. Klerer and J. Reinfelds",
 BOOKTITLE = "Interactive Systems for Experimental Applied Mathematics",
 PUBLISHER = "Academic Press", ADDRESS = "New York"}

@ARTICLE{Hearn:69,
 AUTHOR = "A. C. Hearn and P. K. Kuo and D. R. Yennie",
 TITLE = "Radiative Corrections to an Electron-Positron Scattering
Experiment",
 JOURNAL = "Phys. Rev.",
 YEAR = 1969, VOLUME = 187, PAGES = "2088-2096"}

@INPROCEEDINGS{Hearn:69a,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "The Problem of Substitution",
 YEAR = 1969, PAGES = "3-19",
 EDITOR = "R.G. Tobey",
 BOOKTITLE = "Proc. of the 1968 Summer Institute on Symbolic Mathematical
Computation",
 PUBLISHER = "IBM Boston Prog. Center", ADDRESS = "Cambridge, Mass",
 COMMENT = "IBM Programming Laboratory Report No. FSC-69-0312"}

@ARTICLE{Hearn:71,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Applications of Symbolic Manipulation in Theoretical Physics",
 JOURNAL = "Comm. ACM",
 YEAR = 1971, VOLUME = 14, PAGES = "511-516"}

@INPROCEEDINGS{Hearn:71a,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "REDUCE 2: A System and Language for Algebraic Manipulation",
 YEAR = 1971, PAGES = "128-133",
 EDITOR = "S.R. Petrick",
 BOOKTITLE = "Proc. of Second Symposium on Symbolic and
Algebraic Manipulation",
 PUBLISHER = "ACM, New York"}

@INPROCEEDINGS{Hearn:71b,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Calculation of Traces of Products of Gamma Matrices",
 YEAR = 1971, PAGES = "I-30 - I-44",
 BOOKTITLE = "Proc. of the Second Colloquium on Advanced Computing
Methods in Theoretical Physics, {CNRS}, Marseilles",
 ABSTRACT = {A survey of the algorithms available for the calculation of
traces of products of Dirac gamma matrices is presented.}}

@INPROCEEDINGS{Hearn:71c,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "The Computer Solution of Algebraic Problems by Pattern Matching",
 YEAR = 1971, PAGES = "I-45 - I-57",
 BOOKTITLE = "Proc. of the Second Colloquium on Advanced Computing
Methods in Theoretical Physics, {CNRS}, Marseilles",
 ABSTRACT = {This paper discusses computer techniques for the solution of
algebraic  problems in theoretical physics and related areas by pattern
matching.}}

@INPROCEEDINGS{Hearn:72,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Computer Solution of Symbolic Problems in Theoretical Physics",
 YEAR = 1972, PAGES = "567-596",
 BOOKTITLE = "Computing as a Language of Physics, {IAEA}, Vienna",
 ABSTRACT = {A survey of the computing techniques currently available for
the solution of nonnumerical problems in theoretical physics and related
areas is presented.}}

@ARTICLE{Hearn:72a,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Improved Non-modular Polynomial {GCD} Algorithm",
 JOURNAL = "SIGSAM Bulletin",
 YEAR = 1972, PAGES = "10-15",
 ABSTRACT = {An improved non-modular algorithm for the calculation of the
greatest common divisor of two multivariate polynomials is presented.}}

@ARTICLE{Hearn:72b,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "A {REDUCE} Solution of Problem \#2 - The {Y(2n)} Functions",
 JOURNAL = "SIGSAM Bulletin",
 YEAR = 1972, VOLUME = 14,
 ABSTRACT = {A {REDUCE} solution to {SIGSAM} Problem \#2 is described.}}

@INPROCEEDINGS{Hearn:73,
 AUTHOR = "Anthony C. Hearn and R{\"u}diger G. K. Loos",
 TITLE = "Extended Polynomial Algorithms",
 YEAR = 1973, PAGES = "147-152",
 BOOKTITLE = "Proc. {ACM} 73",
 ABSTRACT = {It is shown that standard polynomial algorithms may be
applied to a much wider class of functions by making a straightforward
generalization of the concept of the exponent.  The implementation of a
computer algebra system from a standard set of polynomial programs which
allows for any coefficient or exponent structure is also discussed.}}

@INPROCEEDINGS{Hearn:73a,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "The {REDUCE} Program for Computer Algebra",
 YEAR = 1973,
 BOOKTITLE = "Proc. of the Third Colloquium on Advanced Computing Methods
in Theoretical Physics, {CNRS}, Marseilles",
 ABSTRACT = {The status of the {REDUCE} program for computer algebra in 1973
is illustrated by a discussion of some aspects of its design philosophy.}}

@INPROCEEDINGS{Hearn:74,
 AUTHOR = "Anthony C. Hearn",
 TITLE = " Polynomial and Rational Function Representations",
 YEAR = 1974, PAGE = "211",
 BOOKTITLE = "Proc. Math Software II, Purdue University",
 ABSTRACT = {A survey of some current methods for computer manipulation of
polynomials and rational functions is presented.  Particular emphasis
is placed on the desirability of writing programs which avoid explicit
reference to the data structures used in the manipulation."}}

@INPROCEEDINGS{Hearn:74a,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "A Mode Analyzing Algebraic Manipulation Program",
 YEAR = 1974, PAGES = "722-724",
 BOOKTITLE = "Proc. {ACM} 74",
 COMMENT = {Describes a version of the {REDUCE} program for algebraic
manipulation which performs a complete mode analysis as a separate extension
of the parse.}}

@ARTICLE{Hearn:76,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Scientific Applications of Symbolic Computation",
 JOURNAL = "Computer Science and Scientific Comp.",
 YEAR = 1976, PAGES = "83-108",
 ABSTRACT = {This paper reviews the use of symbolic computation systems for
problem solving in scientific research.}}

@INPROCEEDINGS{Hearn:76a,
 AUTHOR = "A. C. Hearn",
 TITLE = "A New {REDUCE} Model for Algebraic Simplification",
 YEAR = 1976, PAGES = "46-52",
 BOOKTITLE = "Proc. {SYMSAC} 76, {ACM}",
 ABSTRACT = {This paper shows how the general concepts of mode analysis can
play a useful role in the design and implementation of programs
for algebraic simplification.}}

@INPROCEEDINGS{Hearn:76b,
 AUTHOR = "A. C. Hearn",
 TITLE = "Symbolic Computation",
 YEAR = 1976, PAGES = "201-211",
 BOOKTITLE = "Proc. {CERN} 1976 Computing School, {CERN} Geneva",
 COMMENT = {Lecture Notes.}}

@INPROCEEDINGS{Hearn:77,
 AUTHOR = "A. C. Hearn",
 TITLE = "The Structure of Algebraic Computations",
 YEAR = 1977, PAGES = "1-15",
 BOOKTITLE = "Proc. of the Fourth Colloquium on Advanced Comp.
Methods in Theor. Physics. St. Maximin, France",
 ABSTRACT = {Most algebraic computations which arise from physical problems
have considerable structure in their specification because of the many
physical conservation laws and the nature of our approximation techniques.
The exploitation of this structure is often the reason why hand
calculations of non-trivial problems are possible.  However, most
available algebra systems do not preserve such structure in a consistent
manner, and consequently produce results which are far less comprehensible
than equivalent hand calculations.  In this paper we shall describe
techniques which can utilize the algebraic structure more effectively and
apply them to several examples.}}

@INPROCEEDINGS{Hearn:78,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Algebraic Manipulation by Computer",
 YEAR = 1978, PAGES = "96-116",
 BOOKTITLE = "Proc. Intern. Meeting on Programm. and Math. Meth. for
Solving Phys. Probs., Dubna, USSR",
 ABSTRACT = {This paper reviews the use of algebraic manipulation by computer
as a tool for scientific problem solving.}}

@INPROCEEDINGS{Hearn:79,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Non-Modular Computation of Polynomial {GCDs} Using Trial
Division",
 YEAR = 1979, VOLUME = 72, PAGES = "227-239",
 BOOKTITLE = "Proc. {EUROSAM} 79",
 ABSTRACT = {This paper describes a new algorithm for the determination of
the {GCD} of two multivariate polynomials by non-modular means.}}

@ARTICLE{Hearn:79a,
 AUTHOR = "Anthony C. Hearn and Arthur C. Norman",
 TITLE = "A One-Pass Prettyprinter",
 JOURNAL = "Sigplan Notices, ACM 12",
 YEAR = 1979, VOLUME = 14, PAGES = "50-58",
 ABSTRACT = {We propose a new method for program formatting which is
described in terms of two coroutines.}}

@INPROCEEDINGS{Hearn:80,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "The Personal Algebra Machine",
 YEAR = 1980, PAGES = "621-628",
 BOOKTITLE = "Information Processing 80, Proc. {IFIP}
Congress 80"}

@ARTICLE{Hearn:81,
 AUTHOR = "Anthony C. Hearn and S. Watanabe",
 TITLE = "Analytic Integration by Computer",
 JOURNAL = "Information Processing Society of Japan 22",
 YEAR = 1981, PAGES = "639-650"}

@INPROCEEDINGS{Hearn:81a,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Symbolic Computation and its Application to
High-Energy Physics",
 YEAR = 1981, PAGES = "390-406",
 BOOKTITLE = "Proc. 1980 {CERN} School of Computing, Geneva"}

@INPROCEEDINGS{Hearn:82,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "{REDUCE} - A Case Study in Algebra System Development",
 YEAR = 1982, VOLUME = 144, PAGES = "263-272",
 BOOKTITLE = "Proc. of {EUROCAM} '82, Lecture Notes on Comp.
Science"}

@INPROCEEDINGS{Hearn:82a,
 AUTHOR = "Anthony C. Hearn and M. L. Griss and E. Benson",
 TITLE = "Current Status of a Portable {LISP} Compiler",
 YEAR = 1982,
 BOOKTITLE = "Proc. {SIGPLAN} '82 Symp. on Compiler
Construction, ACM", PAGES = "276-283"}

@INPROCEEDINGS{Hearn:85,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Structure:  The Key to Improved Algebraic Computation",
 YEAR = 1985,
 BOOKTITLE = "Proc. of the Second {RIKEN} International
Symposium on Symbolic and Algebraic Computation by Computers",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "215-230"}

@INPROCEEDINGS{Hearn:86,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Optimal Evaluation of Algebraic Expressions",
 BOOKTITLE = "Proc. of {AAECC}-3, Lecture Notes on Comp. Science",
 PUBLISHER = "Springer Verlag",
 YEAR = 1986, VOLUME = 229, PAGES = "392-403"}

@TECHREPORT{Hearn:91,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "{REDUCE} User's Manual, {Version} 3.4",
 INSTITUTION = "RAND",
 YEAR = 1991, TYPE = "Report",
 NUMBER = "CP 78", MONTH = "July"}

@ARTICLE{Hermann:83,
 AUTHOR = "R. Hermann",
 TITLE = "Geometric Construction and Properties of Some Families of
Solutions of Nonlinear Partial Differential Equations",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1983,  VOLUME = 24, NUMBER = "3", PAGES = "510-521",
 COMMENT = {First of series of papers on 19th century pde theory.  The
presentation is aimed at including systems such as {MACSYMA} and {REDUCE}
as tools.  This paper is on Lagrange-Charpit method. "I have in mind
developing the differential algebraic aspects of the formalism, going
beyond the 19th century with the aid of symbolic computer systems".}}

@ARTICLE{Hess:84,
 AUTHOR = "P. O. Hess and W. Greiner",
 TITLE = "The Collective Modes of Nuclear Molecules",
 JOURNAL = "Il Nuovo Cimento",
 YEAR = 1984, VOLUME = "83A", PAGES = "76-177",
 COMMENT = {A long paper, admits use of {REDUCE} (on page 101) to invert
11 x 11 matrix.}}

@TECHREPORT{Hettich:77,
 AUTHOR = "R. P. Hettich and J. A. van Hulzen",
 TITLE = "Approximation with a Class of Rational Functions",
 INSTITUTION = "Department of Applied Mathematics, Twente
University of Technology, The Netherlands",
 YEAR = 1977, TYPE = "Memorandum",
 NUMBER = 165, MONTH = "May"}

@ARTICLE{Hietarinta:83,
 AUTHOR = "J. Hietarinta",
 TITLE = "A search for integrable two-dimensional {Hamiltonian} systems
with polynomial potential",
 JOURNAL = "Phys. Lett.",
 YEAR = 1983, VOLUME = "96A", PAGES = "273-278",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@ARTICLE{Hietarinta:83a,
 AUTHOR = "J. Hietarinta",
 TITLE = "Integrable Families of {Henon-Heiles} Type {Hamiltonians} and a
New Duality",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1983, VOLUME = 28, PAGES = "3670-3672",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@ARTICLE{Hietarinta:84,
 AUTHOR = "J. Hietarinta",
 TITLE = "Classical versus quantum integrability",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1984, VOLUME = 25, PAGES = "1833-1840",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@ARTICLE{Hietarinta:84a,
 AUTHOR = "J. Hietarinta",
 TITLE = "New integrable {Hamiltonians} with transcendental invariants",
 JOURNAL = "Phys. Rev. Lett.",
 YEAR = 1984, VOLUME = 52, PAGES = "1057-1060",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@ARTICLE{Hietarinta:84b,
 AUTHOR = "J. Hietarinta and B. Grammaticos and B. Dorizzi and A. Ramani",
 TITLE = "Coupling-Constant Metamorphosis and Duality between
Integrable {Hamiltonian} Systems",
 JOURNAL = "Phys. Rev. Lett.",
 YEAR = 1984, VOLUME = 53, PAGES = "1707-1710",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@ARTICLE{Hietarinta:85,
 AUTHOR = "J. Hietarinta",
 TITLE = "How to construct integrable {Fokker-Planck} and
electromagnetic {Hamiltonians} from ordinary integrable {Hamiltonians}",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1985, VOLUME = 26, PAGES = "1970-1975",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@ARTICLE{Hietarinta:87,
 AUTHOR = "J. Hietarinta",
 TITLE = "Direct methods for the search of the second invariant",
 JOURNAL = "Physics Reports",
 YEAR = 1987, VOLUME = 147, PAGES = "87-154",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@ARTICLE{Hietarinta:87a,
 AUTHOR = "J. Hietarinta",
 TITLE = "A search of bilinear equations passing {Hirota's} three-soliton
condition: {I.} {KdV}-type bilinear equations",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1987, VOLUME = 28, PAGES = "1732-1742",
 COMMENT = {{REDUCE} is used to check when polynomials in 6 to 12 variables
vanish on a affine manifold defined by {LET-rules}.  Large scale
computation.}}

@ARTICLE{Hietarinta:87b,
 AUTHOR = "J. Hietarinta",
 TITLE = "A search of bilinear equations passing {Hirota's} three-soliton
condition: {II.} {mKdV}-type bilinear equations",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1987, VOLUME = 28, PAGES = "2094-2101",
 COMMENT = {{REDUCE} is used to check when polynomials in 6 to 12 variables
vanish on a affine manifold defined by {LET-rules}.  Large scale
computation.}}

@ARTICLE{Hietarinta:87c,
 AUTHOR = "J. Hietarinta",
 TITLE = "A search of bilinear equations passing {Hirota's} three-soliton
condition: {III.} {Sine-Gordon}-type bilinear equations",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1987, VOLUME = 28, PAGES = "2586-2592",
 COMMENT = {{REDUCE} is used to check when polynomials in 6 to 12 variables
vanish on a affine manifold defined by {LET-rules}.  Large scale
computation.}}

@ARTICLE{Hietarinta:88,
 AUTHOR = "J. Hietarinta",
 TITLE = "A search of bilinear equations passing {Hirota's} three-soliton
condition: {IV.} Complex bilinear equations",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1988, VOLUME = 29, PAGES = "628-635",
 COMMENT = {{REDUCE} is used to check when polynomials in 6 to 12 variables
vanish on a affine manifold defined by {LET-rules}.  Large scale computation.
computation.}}

@ARTICLE{Hietarinta:89,
 AUTHOR = "J. Hietarinta and B. Grammaticos",
 TITLE = "On the $\hbar^{2}$-correction terms in quantum integrability",
 JOURNAL = "J. Phys. A: Mat. Gen.",
 YEAR = 1989, VOLUME = "TBD", PAGES = "TBD",
 COMMENT = {{REDUCE} is used to construct and verify constants of motion.}}

@INPROCEEDINGS{Hietarinta:91,
 AUTHOR = "J. Hietarinta",
 TITLE = "From an analytical formula to a movie by way of {REDUCE} and {C}",
 BOOKTITLE = "Proc. of the Workshop on Symbolic and Numeric Computation",
 PUBLISHER = "Research Reports, Computing Centre of Helsinki University",
 YEAR = 1991, PAGES = "117-126"}

@TECHREPORT{Hietarinta:92,
 AUTHOR = "Jarmo Hietarinta",
 TITLE = "Solving the {Yang-Baxter} equation in 2 dimensions with massive
use of factorizing Gr{"\o}bner basis computations",
 INSTITUTION = "University of Turku, Finland", YEAR = 1992,
 MONTH = "January", TYPE = "Preprint",
 COMMENT = {Submitted to ISSAC '92},
 ABSTRACT = {The complete solution to the constant (quantum) Yang-Baxter
equation was recently obtained in the two dimensional case
(= all indices range over 1,2).  This amounts to solving a set of 64
equations in 16 variables.  We describe here how the problem was solved,
first by breaking it into smaller subproblems by using the symmetries of
the equation, and then by solving each subproblem by computing the
factorized Gr{"\o}bner basis using the {'grobner'-}package written by Melenk,
M{"\o}ller and Neun for REDUCE 3.4.}}.

@TECHREPORT{Hietarinta:92a,
 AUTHOR = "Jarmo Hietarinta",
 TITLE = "Solving the two-dimensional constant quantum {Yang-Baxter}
  equation",
 INSTITUTION = "University of Turku, Finland", YEAR = 1992,
 MONTH = "May", TYPE = "Report", NUMBER = "TURKU-FL-R7"}

@BOOK{Hirota:89,
 AUTHOR = "Ryogo Hirota and Masaaki Ito",
 TITLE = "Introduction to {REDUCE --- Doing} Symbolic Computation on {PC}",
 PUBLISHER = "Science sha, Tokyo", MONTH = "June", YEAR = 1989,
 COMMENT = {(In Japanese).}}

@TECHREPORT{Horowitz:75,
 AUTHOR = "E. Horowitz and D. R. Musser",
 TITLE = "The Synthesis and Use of Algebraic Specifications of Data
Structures",
 INSTITUTION = "University of Southern California",
 YEAR = 1975, TYPE = "Preprint"}

@ARTICLE{Horwitz:83,
 AUTHOR = "B. Horwitz",
 TITLE = "Unequal Diameters and Their Effects on Time Varying Voltages
in Branched Neurons",
 JOURNAL = "BioPhys. J.",
 YEAR = 1983, VOLUME = 41, PAGES = "51-66",
 COMMENT = {Theoretical biophysics.  Much algebra, and used {REDUCE} to
decrease mental labor.  "Crucial point is that the existence of such computer
techniques allows higher-order correction terms to be used."}}

@ARTICLE{Hughes:90,
 AUTHOR = "D. I. Hughes",
 TITLE = "Symbolic Computation with Fermions",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1990, VOLUME = 10, NUMBER = 6, PAGES = "657-664", MONTH = "December",
 ABSTRACT = {A set of {REDUCE} routines for manipulating operators which
anticommute amongst themselves is described.  These routines have
applications in theories such as supergravity where anticommuting operators
are used to represent fermions.  The Dirac bracket of the supersymmetry
constraints arising in a quantum cosmological model based on N = 1
supergravtiy coupled to a massless scalar multiplet is calculated as an
example.}}

@INPROCEEDINGS{Hulshof:84,
 AUTHOR = "B. J. A. Hulshof and J. A. van Hulzen",
 TITLE = "Automatic Error Cumulation Control",
 BOOKTITLE = "Proc. {EUROSAM} 1984, Lecture Notes
in Computer Science", YEAR = 1984, VOLUME = 174, PAGES = "260-271",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{Hulshof:85,
 AUTHOR = "B. J. A. Hulshof and J. A. van Hulzen",
 TITLE = "An Expression Compression Package for {REDUCE} based on
Factorization and Controlled Expansion",
 BOOKTITLE = "Proc. {EUROCAL} 1985, Lecture Notes
in Computer Science", YEAR = 1985, VOLUME = 204, PAGES = "315-316",
 PUBLISHER = "Springer-Verlag"}

@TECHREPORT{Hulshof:81,
 AUTHOR = "B. J. A. Hulshof and J. A. van Hulzen and J. Smit",
 TITLE = "Code Optimization Facilities Applied in the {Netform} Context",
 INSTITUTION = "Department of Applied Mathematics, Twente
University of Technology, The Netherlands",
 YEAR = 1981, TYPE = "Memorandum", NUMBER = 368,
 MONTH = "December"}

@ARTICLE{Hulshof:83,
 AUTHOR = "B. J. A. Hulshof and J. A. van Hulzen",
 TITLE = "Some {REDUCE} Facilities for Pretty Printing Subscripts and Formal
Derivatives",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "16-20", MONTH = "February"}

@TECHREPORT{Husberg:81,
 AUTHOR = "N. Husberg",
 TITLE = "Preliminary {II} {REDUCE}-2 and {Analitik-74}, a Comparison",
 INSTITUTION = "Helsinki University of Technology Computing
Center", YEAR = 1981, MONTH = "November"}

@TECHREPORT{Idesawa:77,
 AUTHOR = "M. Idesawa and T. Yatagai",
 TITLE = "General Theory of Projection-Type {Moir\'e} Topography",
 INSTITUTION = "Institute of Physical and Chemical Research,
Wako-Shi, Saitama", YEAR = 1977, TYPE = "Scientific Papers",
 NUMBER = 71,
 ABSTRACT = {The configuration of equi-order surfaces in the projection-type
{Moire} topography is described in terms of system parameters
without any restrictions on the measurement condition.}}

@INPROCEEDINGS{Ilyin:87,
 AUTHOR = "V. A. Ilyin and A. P. Kryukov",
 TITLE = "{DIMREG} - The Package for Calculations in the Dimensional
Regularization with {4-dimensional} $\gamma^{5}$ -matrix in Quantum Field
Theory",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "225-232",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Ilyin:89,
 AUTHOR = "V. A. Ilyin and A. P. Kryukov and A. Ya. Rodioniov and
A. Yu. Taranov",
 TITLE = "Fast Algorithm for Calculation of {Dirac}'s Gamma-Matrices Traces",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1989, VOLUME = 23, NUMBER = 4, PAGES = "15-24", MONTH = "October"}

@INPROCEEDINGS{Ilyin:91,
 AUTHOR = "V. A. Ilyin and A. P. Kryukov",
 TITLE = "Symbolic Simplification of Tensor Expressions Using Symmetries,
Dummy Indices and Identities",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "224-228",
 YEAR = 1991,
 ABSTRACT = {The algorithm based on simple geometrical ideas is suggested
for simplification of tensor expressions which takes into account
symmetries, dummy indices, and linear identities with many terms.  The
results of the realization in REDUCE system are adduced.}}

@INPROCEEDINGS{Ilyin:91a,
 AUTHOR = "V. A. Ilyin and A. P. Kryukov and A. Ya. Rodionov and A Yu.
Taranov",
 TITLE = "{PC} Implementation of Fast {Dirac} Matrix Trace Calculations",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "456-457",
 YEAR = 1991,
 COMMENT = {We present an implementation of fast algorithm for Dirac
matrix trace calculations.  This implementation is made for {IBM}       i
compatible {PC} and works under {REDUCE 3.3.1}.  Name of package is
{CVIT}.  The algorithm itself was described in [1].  It is based on intense
use of Fierz identities in N-dimensional space (N is arbitrary natural
number or symbol) and may be considered as an extension of well known
Kahane algorithm [2] on higher space dimensions.}}

@TECHREPORT{Inada:80,
 AUTHOR = "Nobuyuki Inada",
 TITLE = "Fortran-Based {LISP} System for {REDUCE}",
 INSTITUTION = "Information Science Laboratory, The Institute
of Physical and Chemical Research",
 YEAR = 1980}

@TECHREPORT{Ioakimidis:90,
 AUTHOR = "N. I. Ioakimidis",
 TITLE = "Construction of the Equation of Caustics in Dynamic Plane
Elasticity Problems with the Help of {REDUCE}",
 INSTITUTION = "Division of Applied Mathematics and Mechanics, School of
Engineering, University of Patras, Greece",
 YEAR = 1990}
 ABSTRACT = {The method of caustics has become a very efficient tool in
crack, hole and many additional plane elasticity problems.  Unfortunately,
the fundamental equation of the caustics frequently requires complicated
algebraic computations including that of a Jacobian determinant.  Here we
show that computer algebra software can prove very efficient in these
computations, using as a vehicle for this illustration the already known
fundamental equation of caustics in dynamic plane elasticity (both for crack
problems in fracture mechanics as well as for hole and additional problems).
We have used the programming capabilities of {REDUCE}, a very popular
computer algebra system, for our algebraic computations.  Moreover, we
illustrate the "learning" abilities of {REDUCE} especially for the
derivation of the complex form of this equation.  The case of static plane
elasticity results simply as a special case of dynamic plane elasticity.
Additional possibilities are suggested in brief.}}

@TECHREPORT{Ioakimidis:90a,
 AUTHOR = "N. I. Ioakimidis",
 TITLE = "Construction of Singular Integral Equations for Interacting
Straight Cracks by Using {REDUCE}",
 INSTITUTION = "Division of Applied Mathematics and Mechanics, School of
Engineering, University of Patras, Greece",
 YEAR = 1990}
 ABSTRACT = {The method of singular integral equations has been applied to
the solution of crack problems in plane and antiplane elasticity
hundreds of times during the last twenty years.  Here we revisit the case of
an arbitrary number of interacting straight cracks in plane elasticity and
we illustrate the possibility of constructing (algebraically) the
corresponding system of singular integral equations by using computer
algebra software.  We present a procedure (computer program) by using
{REDUCE} as well as several examples of application of the present approach,
extensions and generalizations of which follow rather trivially.}}

@ARTICLE{Ito:85,
 AUTHOR = "M. Ito",
 TITLE = "A {REDUCE} Program for Evaluating a {Lax} Pair Form",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1985, VOLUME = 34, PAGES = "325-331",
 COMMENT = {{REDUCE} in nonlinear equations.}}

@ARTICLE{Ito:85a,
 AUTHOR = "M. Ito and F. Kako",
 TITLE = "A {REDUCE} Program for Finding Conserved Densities of Partial
Differential Equations with Uniform Rank",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1985, VOLUME = 38, PAGES = "415-419"}

@ARTICLE{Ito:88,
 AUTHOR = "Masaaki Ito",
 TITLE = "A {REDUCE} Program for {Hirota's} Bilinear Operator and
{Wronskian} Operations",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1988, VOLUME = 50, NUMBER = 3, PAGES = "321-330", MONTH = "August"}

@ARTICLE{Ito:90,
 AUTHOR = "Nobuyasu Ito and Tetsuhiko Chikyu",
 TITLE = "Multi-Spin-Flip Dynamics of the {Ising} Chain",
 JOURNAL = "Physica A",
 YEAR = 1990, VOLUME = 166, PAGES = "193-205",
 ABSTRACT = {Two kinds of multi-spin-flip discrete-time dynamics of the
Ising chain are solved analytically.  One dynamics is the two sublattice
type flip and each sublattice contains {\em n} sequential spins
alternately.  The other has the overlapped multi-spin-flip sequence.  The
state of {\em n} spins at the next time step is selected from ${2}^{n}$
states using the heat-bath type transition probability.  These dynamics of
the Ising chain are equivalent to the statics of the square-lattice Ising
model with a 1 x 2 unit cell or of the triangular-lattice Ising model.
The analytic solutions of the single spin relaxation time of these
dynamics are obtained using these equivalences.}}

@ARTICLE{Ito:90a,
 AUTHOR = "Nobuyasu Ito",
 TITLE = "Discrete-Time and Single-Spin-Flip Dynamics of the {Ising} Chain",
 JOURNAL = "Progress of Theoretical Physics",
 YEAR = 1990, VOLUME = 83, NUMBER = 4, PAGES = "682-692", MONTH = "April",
 ABSTRACT = {Some stochastic dynamics of the Ising chain are discussed
analytically and their flip-sequence dependences are studied in the
present paper.  The dynamics are the discrete-time and single-spin-flip
dynamics.  The flip sequence is of sequential or sublattice-type.  Their
relaxation times of single spin expectation functions are calculated.  The
sequential-flip dynamics of {\em n}-site chain has the same correlation
time as the {\em n}-sublattice dynamics.  The relaxation becomes slow when
this {\em n} is made large.  The static models equivalent to these dynamic
models are the Ising models on a triangular lattice with a skew boundary
condition which has the same couplings in two directions.  Spin-spin
correlation lengths in the direction perpendicular to the anisotropic
direction are obtained for these equivalent models.  They depend only on
the ratio of the lattice width to boundary skew.}}

@ARTICLE{Jansen:86,
 AUTHOR = "Paul Jansen and Peter Weidner",
 TITLE = "High-Accuracy Arithmetic Software--Some Tests of the
{ACRITH} Problem-Solving Routines",
 JOURNAL = "{ACM} {TOMS}",
 YEAR = 1986, VOLUME = 12, NUMBER = 1, PAGES = "62-70", MONTH = "March",
 COMMENT = {A criticism of {ACRITH}, shows {REDUCE} bigfloats are more
accurate and comparable in speed.}}

@ARTICLE{Janssen:87,
 AUTHOR = "M. H. M. Janssen and D. H. Parker and S. Stolte",
 TITLE = "Saturation in Laser-Induced Fluorescence:  Effects on
Alignment Parameters",
 JOURNAL = "Chemical Phys.",
 YEAR = 1987, VOLUME = 113, PAGES = "357-382",
 COMMENT = {"Computer algebra programs are used to generate simple analytical
expressions which account for the influence of saturation on
determining alignment parameters."  The system is {REDUCE}.}}

@ARTICLE{Jeffrey:84,
 AUTHOR = "D. J. Jeffrey and Y. Onishi",
 TITLE = "The Forces and Couples Acting on Two Nearly Touching Spheres
in Low-{Reynolds}-Number Flow",
 JOURNAL = "Z. Ang. Math. Phys.",
 YEAR = 1984, VOLUME = 35, PAGES = "634-641",
 COMMENT = {Extends previous result from linear term to
O$\epsilon$ in $\epsilon$.  "Otherwise the only new principle in the
calculation is the handling of long algebraic expressions, which was
accomplished by using the computer algebra systems {CAMAL} and {REDUCE}."}}

@ARTICLE{Kadlecsik:88,
 AUTHOR = "J. Kadlecsik",
 TITLE = "New Approaches to the Axisymmetric Vacuum",
 JOURNAL = "Zeitschrift {f\"{u}r} Physik C. Particles and Fields",
 YEAR = 1988, VOLUME = 41, PAGES = "265-269"}

@TECHREPORT{Kadlecsik:92,
 AUTHOR = "Jo{\'o}zsef Kadlecsik",
 TITLE = "Tensor Manipulation Package for General Relativity Calculations",
 INSTITUTION = "Central Research Institute for Physics, Budapest",
 YEAR = 1992, TYPE = "Preprint", NUMBER = "KFKI-1992-05/B+M",
 ABSTRACT = {An experimental computer program is presented, which manipulates
tensor expressions symbolically in general relativity calculations.}}

@ARTICLE{Kagan:85,
 AUTHOR = "Y. Y. Kagan and L. Knopoff",
 TITLE = "The First-Order Statistical Moment of the Seismic Moment Tensor",
 JOURNAL = "Geophys. J. R. Astron. Soc.",
 YEAR = 1985, VOLUME = 81, PAGES = "429-444"}

@ARTICLE{Kagan:88,
 AUTHOR = "Y. Y. Kagan",
 TITLE = "Static Sources of Elastic Deformation in a Homogeneous
Half-Space",
 JOURNAL = "J. Geophys. Res.",
 YEAR = 1988, VOLUME = 93, NUMBER = "B9", PAGES = "10,560-10,574",
 MONTH = "September"}

@TECHREPORT{Kahn:69,
 AUTHOR = "M. E. Kahn",
 TITLE = "The Near-Minimum-Time Control of Open Loop Articulated
Kinematic Chains",
 INSTITUTION = "Stanford University, Computer Science Dept.",
 YEAR = 1969, TYPE = "Report", NUMBER = "AIM-106"}

@TECHREPORT{Kamal:81,
 AUTHOR = "A. N. Kamal and J. Kodaira and T. Muta",
 TITLE = "Gluon Jets From Heavy Paraquarkonium",
 INSTITUTION = "University of Alberta, Canada and Stanford
University, California and  Fermi National Accelerator
Laboratory, Illinois",
 YEAR = 1981, NUMBER = "SLAC-PUB-2725", MONTH = "April"}

@TECHREPORT{Kamel:69,
 AUTHOR = "A. A. Kamel",
 TITLE = "Perturbation Method in the Theory of Non-Linear Oscillations",
 INSTITUTION = "Stanford University, Dept. of Aeronautics
and Astronautics", YEAR = 1969, TYPE = "Report"}

@TECHREPORT{Kamel:69a,
 AUTHOR = "A. A. Kamel",
 TITLE = "Perturbation Theory Based on {Lie} Transforms and Its
Application to the Stability of Motion Near {Sun}-Perturbed
{Earth-Moon} Triangular Libration Points",
 INSTITUTION = "Stanford University, Dept. of Aeronautics and
Astronautics", YEAR = 1969, TYPE = "Report", NUMBER = "391"}

@INPROCEEDINGS{Kamel:78,
 AUTHOR = "A. A. Kamel",
 TITLE = "Synchronous Satellite Ephemeris Due to Earth's
Triaxiality and Luni-Solar Effects",
 YEAR = 1978, MONTH = "August",
 BOOKTITLE = "{AIAA/AAS} Astrodynamics Conference,
Palo Alto, CA",
 COMMENT = {Synchronous satellite ephemeris is developed in terms of
non-singular orbital elements.}}

@ARTICLE{Kanada:81,
 AUTHOR = "Yasumasa Kanada and Tateaki Sasaki",
 TITLE = "{LISP-based} {big-float} system is not slow",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1981, VOLUME = 15, NUMBER = 2, PAGES = "13-19", MONTH = "May"}

@TECHREPORT{Kanada:75,
 AUTHOR = "Y. Kanada",
 TITLE = "Implementation of {HLISP} and Algebraic Manipulation
Language {REDUCE} 2",
 INSTITUTION = "University of Tokyo Information Science Lab",
 YEAR = 1975, TYPE = "Report", NUMBER = "75-01"}

@ARTICLE{Kaneko:89,
 AUTHOR = "Toshiaki Kaneko and Setsuya Kawabata",
 TITLE = "A Preprocessor for {Fortran} Source Code Produced by {REDUCE}",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1989, VOLUME = 55, NUMBER = 2, PAGES = "141-147",
 MONTH = "September", PUBLISHER = "North Holland Publishing Company"}

@ARTICLE{Kaps:85,
 AUTHOR = "P. Kaps and S. W. H. Poon and T. D. Bui",
 TITLE = "Rosenbrock Methods for Stiff {ODEs}:  A Comparison of {Richardson}
Extrapolation and Embedding Techniques",
 JOURNAL = "Computing",
 YEAR = 1985, VOLUME = 34, PAGES = "17-40",
 COMMENT = {Reference to {REDUCE} but not in text.}}

@INPROCEEDINGS{Karr:85,
 AUTHOR = "Michael Karr",
 TITLE = "Canonical Form for Rational Exponential Expressions",
 BOOKTITLE = "Proc. {EUROCAL} 1985, Lecture Notes
in Computer Science", YEAR = 1985, VOLUME = 204, PAGES = "585-594",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{Katsura:85,
 AUTHOR = "Shigetoshi Katsura",
 TITLE = "Application of the Formula Manipulating System to Statistical
 Mechanics", YEAR = 1985,
 BOOKTITLE = "Proc. of the Second {RIKEN} International
Symposium on Symbolic and Algebraic Computation by Computers",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "155-180"}

@PHDTHESIS{Kauffman:73,
 AUTHOR = "S. K. Kauffman",
 TITLE = "Ortho-Positronium Annihilation:  Steps Toward Computing
the First Order Radiative Corrections",
 SCHOOL = "California Institute of Technology",
 YEAR = 1973}

@INPROCEEDINGS{Kazasov:87,
 AUTHOR = "C. Kazasov",
 TITLE = "Laplace Transformations in {REDUCE} 3",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "132-133",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Keady:85,
 AUTHOR = "Grant Keady",
 TITLE = "The Power Concavity of Solutions of Some Semilinear Elliptic
{Boundary-Value} Problems",
 JOURNAL = "Bull. Austral. Math. Soc.",
 YEAR = 1985, VOLUME = 31, PAGES = "181-184"}

@ARTICLE{Keener:83,
 AUTHOR = "James P. Keener",
 TITLE = "Oscillatory coexistence in the {chemostat:} a codimension two
unfolding",
 JOURNAL = "{SIAM} J. Appl. Math.",
 YEAR = 1983, VOLUME = 43, NUMBER = 5, PAGES = "1005-1018"}

@ARTICLE{Keener:85,
 AUTHOR = "James P. Keener",
 TITLE = "Oscillatory coexistence in a food chain model with competing
predators",
 JOURNAL = "J. Math. Biology",
 YEAR = 1985, VOLUME = 22, PAGES = "123-135"}

@ARTICLE{Keener:89,
 AUTHOR = "James P. Keener",
 TITLE = "Knotted scroll wave filaments in excitable media",
 JOURNAL = "Physica D 34",
 YEAR = 1989, PAGES = "378-390"}

@ARTICLE{Keener:90,
 AUTHOR = "James P. Keener",
 TITLE = "Knotted vortex filaments in an ideal fluid",
 JOURNAL = "J. Fluid Mech.",
 YEAR = 1990, VOLUME = 211, PAGES = "629-651"}

@ARTICLE{Kendall:88,
 AUTHOR = "W. S. Kendall",
 TITLE = "Symbolic Computation and the Diffusion of Shapes of Triads",
 JOURNAL = "Adv. Appl. Prob.",
 YEAR = 1988, VOLUME = 20, PAGES = "775-797"}

@TECHREPORT{Kendall:89,
 AUTHOR = "W. S. Kendall",
 TITLE = "The Diffusion of {Euclidean} Shape",
 INSTITUTION = "University of Warwick, Dept. of Statistics", YEAR = 1989,
 TYPE = "Research Report", NUMBER = 161}

@TECHREPORT{Kendall:89a,
 AUTHOR = "W. S. Kendall",
 TITLE = "Probability, Convexity, and Harmonic Maps with Small Image I:
Uniqueness and Fine Existence",
 INSTITUTION = "University of Warwick, Dept. of Statistics", YEAR = 1989,
 TYPE = "Research Report", NUMBER = 162}

@ARTICLE{Kendall:90,
 AUTHOR = "W. S. Kendall",
 TITLE = "Computer Algebra and Stochastic Calculus",
 JOURNAL = "Notices A.M.S.",
 YEAR = 1990, VOLUME = 37, PAGES = "1254-1256"}

@TECHREPORT{Kendall:91,
 AUTHOR = "Wilfred S. Kendall",
 TITLE = "Computer Algebra and Stochastic Calculus",
 INSTITUTION = "University of Warwick, Dept. of Statistics", YEAR = 1991,
 TYPE = "Research Report", NUMBER = 203}

@TECHREPORT{Kendall:91a,
 AUTHOR = "Wilfred S. Kendall",
 TITLE = "Symbolic {It\^{o}} Calculus:  An Introduction",
 INSTITUTION = "University of Warwick, Dept. of Statistics", YEAR = 1991,
 TYPE = "Research Report", NUMBER = 217}
 ABSTRACT = {The ito procedures are an implementation of stochastic calculus
for the computer algebra package {REDUCE}.  In this paper it is explained
how the implementation of ito grows naturally out of the formulation of
stochastic calculus using modules of stochastic differentials.  Two examples
are given of ito in action:  a simple example concerning various exponential
martingales and a more involved example concerning the escape rate of the
Bessel process of dimension exceeding 2.  A basic subset of the ito
procedures is listed in six appendices; details are given of how to obtain
the full set from the author.}}

@INPROCEEDINGS{Kerner:75,
 AUTHOR = "W. Kerner and R. C. Grimm",
 TITLE = "{MHD} Spectra for {Tokamaks} with Non-circular Cross Sections",
 YEAR = 1975,
 BOOKTITLE = "Proc. Seventh Conference on
Numerical Simulation of Plasmas, Courant Institute, {NYU}"}

@ARTICLE{Kersten:83,
 AUTHOR = "P. H. M. Kersten",
 TITLE = "Infinitesimal Symmetries and Conserved Currents for Nonlinear
{Dirac} Equation",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1983, VOLUME = 24, PAGES = "2374-2376",
 COMMENT = {Harrison-Estabrook and computer algebra, in {REDUCE}.  Very like
{EXCALC} but predates it.}}

@ARTICLE{Kersten:84,
 AUTHOR = "P. Kersten and R. Martini",
 TITLE = "The Harmonic Map and Killing Fields for Self-Dual {SU(3)}
{Yang-Mills} Equations",
 JOURNAL = "J. Phys. A",
 YEAR = 1984, VOLUME = 17, PAGES = "L227-L230",
 COMMENT = {%"{\ldots}and the determination of the general solution of the
killing fields have been achieved by symbolic computations in a semi-automatic
way using software developed in the symbolic language {REDUCE}{\ldots}"}}

@ARTICLE{Kersten:86,
 AUTHOR = "P. H. M. Kersten",
 TITLE = "Creating and Annihilating {Lie-B\"acklund} Transformations
of the {Federbush} Model",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1986, VOLUME = 27, PAGES = "1139-1144",
 COMMENT = {"We want to stress that all computations have been worked out on
a {DEC-20} computer using {REDUCE} and a software package to do these
calculations."  Lie algebra and Gragert's package.}}

@ARTICLE{Kersten:86a,
 AUTHOR = "P. H. M. Kersten and H. M. M. Ten Eikelder",
 TITLE = "Infinite Hierarchies of t-independent and t-dependent
Conserved Functionals of the {Federbush} Model",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1986, VOLUME = 27, PAGES = "2140-2145",
 COMMENT = {"We want to stress that all computations have been worked out on
a {DEC-20} computer using {REDUCE} and a software package to do these
calculations."}}

@ARTICLE{Kersten:86b,
 AUTHOR = "P. H. M. Kersten and H. M. M. Ten Eikelder",
 TITLE = "An Infinite Number of Infinite Hierarchies of Conserved
Quantities of the {Federbush} Model",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1986, VOLUME = 27, PAGES = "2791-2796"}

@ARTICLE{Killalea:80,
 AUTHOR = "M. K. Killalea and B. J. McCoy",
 TITLE = "Concentration Distribution and Spatial Moments of
Moving Macromolecules Undergoing Isomerization",
 JOURNAL = "Biopolymers",
 YEAR = 1980, VOLUME = 19, PAGES = "1875-1886"}

@TECHREPORT{Kinoshita:72,
 AUTHOR = "T. Kinoshita and P. Cvitanovic",
 TITLE = "Sixth Order Radiative Corrections to the Electron Magnetic Moment",
 INSTITUTION = "Cornell Lab. for Nuclear Studies", YEAR = 1972,
 TYPE = "Report", NUMBER = "CLNS-197", MONTH = "October"}

@TECHREPORT{Kinoshita:73,
 AUTHOR = "T. Kinoshita and P. Cvitanovic",
 TITLE = "Feynman-{Dyson} Rules in Parametric Space",
 INSTITUTION = "Cornell Lab. for Nuclear Studies", YEAR = 1973,
 TYPE = "Report", NUMBER = "CLNS-209", MONTH = "January"}

@ARTICLE{Kitatani:86,
 AUTHOR = "H. Kitatani and S. Miyashita and M. Suzuki",
 TITLE = "Reentrant Phenomena in Some {Ising} Spin Systems - Rigorous
Results and Effects of an External Field",
 JOURNAL = "J. Phys. S. Japan",
 YEAR = 1986, VOLUME = 55, NUMBER = 3, PAGES = "865-876",
 COMMENT = {{REDUCE} used to calculate formula before numerical
calculation.}}

@TECHREPORT{Kobayashi:84,
 AUTHOR = "Hidestune Kobayashi",
 TITLE = "Weierstrass Points on a Curve, $X^{7}_{0}+X^{7}_{1}
+X^{7}_{2}=0$",
 INSTITUTION = "Research Institute of Science and Technology, Nihon
University", YEAR = 1984, TYPE = "Preprint", NUMBER = 28, MONTH = "March"}

@INPROCEEDINGS{Kobayashi:88,
 AUTHOR = "H. Kobayashi and S. Moritsugu and R. W. Hogan",
 TITLE = "Solving Systems of Algebraic Equations",
 BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag",
 YEAR = 1988, VOLUME = 358, PAGES = "139-149"}

@INPROCEEDINGS{Kodaira:85,
 AUTHOR = "Hiroshi Kodaira and Hiroshi Toshima",
 TITLE = "Gini Coefficient of Wealth in Life Cycle Model",
 YEAR = 1985,
 BOOKTITLE = "Proc. of the Second {RIKEN} International
Symposium on Symbolic and Algebraic Computation by Computers",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "119-151"}

@ARTICLE{Koh:82,
 AUTHOR = "I. G. Koh and Y. D. Kim and Y. J. Park and C. H. Kim and
Y. S. Kim",
 TITLE = "Complete Set of {SU(5)} Monopole Solution",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1982, VOLUME = 23, PAGES = "1210-1212",
 COMMENT = {Calculation checked by {REDUCE} after hand calculation.}}

@ARTICLE{Koelbig:81,
 AUTHOR = "K. S. K{\"o}lbig and F. Schwarz",
 TITLE = "On Positive Function Series",
 JOURNAL = "Computing",
 YEAR = 1981, VOLUME = 27, PAGES = "319-337",
 COMMENT = {{REDUCE} for algebra on constraints on a functional form and
Jacobi polynomials.}}

@ARTICLE{Koelbig:81b,
 AUTHOR = "K. S. K{\"o}lbig",
 TITLE = "A Program for Computing the Conical functions of the
First Kind ${P}^{m}_{-1/2+i\tau}(x)$ for $m = 0$ and $m = 1$",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1981, VOLUME = 23, PAGES = "51-61",
 PUBLISHER = "North Holland Publishing Company"}

@ARTICLE{Koelbig:82,
 AUTHOR = "K. S. K{\"o}lbig",
 TITLE = "Closed Expressions for $\int_{0}^{1} t^{-1} $log$^{n-1}t\,
 $log$^{p}(1 - t) dt$",
 JOURNAL = "Math. Comp.",
 YEAR = 1982, VOLUME = 39, NUMBER = 160, PAGES = "647-654",
 MONTH = "October",
 COMMENT = {Closed form of integral for easy calculation.  Used {REDUCE} for
manipulations.  This class includes dilog, Spence functions etc.
Remarks that {REDUCE} is easier than {FORTRAN}.}}

@ARTICLE{Koelbig:82a,
 AUTHOR = "K. S. K{\"o}lbig and W. R{\"u}hl",
 TITLE = "Complex Zeros of the Partition Function for
Two-Dimensional {U(N)} Lattice Gauge Theories",
 JOURNAL = "Z. Phys. C - Particles and Fields",
 YEAR = 1982, VOLUME = 12, PAGES = "135-143",
 COMMENT = {The Complex Zeros of the Partition Function for Two-Dimensional
U(N) Lattice Gauge Theories.}}

@ARTICLE{Koelbig:83,
 AUTHOR = "K. S. K{\"o}lbig",
 TITLE = "On the Integral $\int_{0}^{\pi/2} $log$^{n}$cos$\,x\,$
log$^{p}$sin$\,x\,dx$",
 JOURNAL = "Math. Comp.",
 MONTH = "April",
 YEAR = 1983, VOLUME = 40, PAGES = "565-570",
 COMMENT = {A formula is derived for the integral in the title which allows
easy evaluation by formula manipulation on a computer.}}

@ARTICLE{Koelbig:83a,
 AUTHOR = "K. S. K{\"o}lbig",
 TITLE = "On the Integral $\int_{0}^{\infty} e^{-\mu t} t^{\nu -1}
   $log$^{m} t dt$",
 JOURNAL = "Math. Comp.",
 YEAR = 1983, VOLUME = 41, PAGES = "171-182",
 COMMENT = {A recurrence relation is given for the integral in the title.}}

@ARTICLE{Koelbig:84,
 AUTHOR = "K. S. K{\"o}lbig and B. Schorr",
 TITLE = "Asymptotic Expansions for the {Landau} Density and
Distribution Function",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1984, VOLUME = 32, PAGES = "121-131"}

@ARTICLE{Koelbig:84a,
 AUTHOR = "K. S. K{\"o}lbig and B. Schorr",
 TITLE = "A Program Package for the {Landau} Distribution",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1984, VOLUME = 31, PAGES = "97-111"}

@TECHREPORT{Koelbig:84b,
 AUTHOR = "K. S. K{\"o}lbig",
 TITLE = "Some Problems Involving Special Functions
Arising From Physics at {CERN}",
 INSTITUTION = "CERN, Data Handling Division",
 YEAR = 1984, NUMBER = "DD 84-14", MONTH = "September"}

@TECHREPORT{Koelbig:85,
 AUTHOR = "K. S. K{\"o}lbig",
 TITLE = "On the Integral $\int_{0}^{1} x^{\nu -1} (1 - x)^{-\lambda}
 $ln$^{m} x dx$",
 INSTITUTION = "CERN, Data Handling Division",
 YEAR = 1985, NUMBER = "DD/85/18", MONTH = "September"}

@ARTICLE{Koelbig:85a,
 AUTHOR = "K. S. K{\"o}lbig",
 TITLE = "Explicit Evaluation of Certain Definite Integrals Involving
Powers of Logarithms",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1985, VOLUME = 1, NUMBER = 1, PAGES = "109-114", MONTH = "March"}

@ARTICLE{Koelbig:86,
 AUTHOR = "K. S. K{\"o}lbig",
 TITLE = "On the Integral $\int_{0}^{\infty} x^{\nu -1}
 (1 + \beta x)^{-\lambda} $ln$^{m} x dx$",
 JOURNAL = "Journal of Comp. and Appl. Math.",
 YEAR = 1986, VOLUME = 14, PAGES = "319-344"}

@ARTICLE{Kolar:90,
 AUTHOR = "M. Kol{\'a}\u{r} and M. K. Ali",
 TITLE = "Trace maps associated with general {two-letter} substitution
rules",
 JOURNAL = "Physical Review {A}",
 YEAR = 1990, VOLUME = 42, NUMBER = 12, PAGES = "7112-7124",
 MONTH = "December",
 ABSTRACT = {Spectral properties, as determined by trace maps, of the
one-dimensional chains (layered structures) constructed according to
general two-letter substitution rules are investigated.  In all trace maps
thus obtained an important role is played by the quantity
$I=x^{2}+y^{2}+z^{2}-xyz-4$ However, only a very small fraction of all
such trace maps are similar to the Fibonacci golden-mean trace map in that
I is their invariant.  In addition to the known case of the precious-mean
lattices (precious means are ratios of the form
$^{1}_{2}[m+(m^{2}+4)^{1/2}]$, m being any positive integer; m=1 gives the
golden mean), we have identified two new large clases of substitution
rules that give trace maps with invariant I.  One of them is a superset of
the precious-mean lattices.  All other cases represent a vast assortment
of different trace maps (and thus the potential for various hitherto
unexplored spectral properties) with a unifying feature that the set I=0
plays the role of an attractor in the trace space.  In most (but not all)
cases, two chains with identical trace maps (and thus identical spectra)
are locally isomorphic.  Generally, local isomorphism equivalence classes
seem to be subsets of identical spectrum equivalence classes.}}

@TECHREPORT{Kornyak:87,
 AUTHOR = "V. V. Kornyak and R. N. Fedorova",
 TITLE = "A {REDUCE} Program to Calculate Determining Equations of
{Lie-Baecklund} Symmetries of Differential Equations",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1987, NUMBER = "P11-87-19"}

@ARTICLE{Kotorynski:86,
 AUTHOR = "W. P. Kotorynski",
 TITLE = "Steady Laminar Flow Through a Twisted Pipe of Elliptical
Cross-Section",
 JOURNAL = "Computers and Fluids",
 YEAR = 1986, VOLUME = 14, PAGES = "433-444",
 COMMENT = {Used {REDUCE} to perform the calculations for steady flow through
twisted pipes, but who also remarked that the techniques he developed
for this problem are applicable to a variety of other pipe flow tasks.}}

@ARTICLE{Krack:82,
 AUTHOR = "K. Krack",
 TITLE = "Rechnerunterst{\"u}tzte {Entwicklung} der {Mittelbreitenformeln}
und Absch{\"a}tzung ihrer ellipsoidischen {Anteile} zur L{\"o}sung der
zweiten geod{\"a}tischen {Hauptaufgabe} auf dem {Rotationsellipsoid}",
 JOURNAL = "Z. Vermessungswes.",
 YEAR = 1982, VOLUME = 107, PAGES = "502-513",
 COMMENT = {(In German) Used {REDUCE} to develop the Gauss mid-latitude
formulae for inverse positioning to the 7th order (Geodesy).}}

@PHDTHESIS{Kraus:73,
 AUTHOR = "J. Kraus",
 TITLE = "Delbr{\"u}ckstreuung und Pr{\"u}fung der
Quantenelektrodynamik",
 SCHOOL = "Ludwig-Maximilians-Universit{\"a}t zu M{\"u}nchen",
 YEAR = 1973}

@ARTICLE{Kredel:88,
 AUTHOR = "Heinz Kredel",
 TITLE = "Admissible termorderings used in Computer Algebra Systems",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1988, VOLUME = 22, NUMBER = 1, PAGES = "28-31", MONTH = "January"}

@ARTICLE{Kruse:83,
 AUTHOR = "Hans-Guenther Kruse and Karin Ohlsen",
 TITLE = "About the Realization of an Extended, but Really Interactive
{REDUCE} by Integration of a Small Editing and Executing System",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "21-25", MONTH = "February"}

@TECHREPORT{Kryukov,
 AUTHOR = "A. P. Kryukov and A. Ya. Rodionov",
 TITLE = "Usage of {REDUCE} for Computations of Group-Theoretical Weight of
{Feynman} Diagrams in Non-Abelian Gauge Theories",
 INSTITUTION = "Institute of Nuclear Physics, Moscow, USSR", YEAR = "TBD"}

@ARTICLE{Kryukov:84,
 AUTHOR = "A. P. Kryukov",
 TITLE = "An Antitranslator of the {RLISP} Language",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1984, VOLUME = 18, NUMBER = 3, PAGES = "12-15", MONTH = "August"}

@ARTICLE{Kryukov:85,
 AUTHOR = "A. P. Kryukov and A. Ya. Rodionov",
 TITLE = "Dynamic-Debugging System for the {REDUCE} Programs",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 2, PAGES = "34-37", MONTH = "May"}

@ARTICLE{Kryukov:85a,
 AUTHOR = "A. P. Kryukov and A. Ya. Rodionov",
 TITLE = "Interactive {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "43-45", MONTH = "August"}

@TECHREPORT{Kryukov:87,
 AUTHOR = "A. P. Kryukov and A. Ya. Rodionov and V. A. Rostovtsev",
 TITLE = "Pattern Compilation in {REDUCE}",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1987, NUMBER = "P11-87-302"}

@INPROCEEDINGS{Kryukov:87a,
 AUTHOR = "A. P. Kryukov and A. Ya. Rodionov",
 TITLE = "{CTS} - Algebraic Debugging System for {REDUCE} Programs",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "233-243",
 PUBLISHER = "Springer-Verlag"}

@TECHREPORT{Kryukov:88,
 AUTHOR = "A. P. Kryukov and A. Ya. Rodionov and V. A. Rostovtsev",
 TITLE = "New Programming Tools for Computing Substitution
Rules in {REDUCE} System",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1988, NUMBER = "P11-88-402",
 COMMENT = {New programming tools allowing to compile patterns in
{REDUCE} system are described.  A guide for using
these tools and examples of their working are presented.}}

@ARTICLE{Kryukov:88a,
 AUTHOR = "A. P. Kryukov and A. Ya. Rodionov",
 TITLE = "Program {``COLOR''} for Computing the Group-Theoretic Weight
of {Feynman} Diagrams in {Non-Abelian} Gauge Theories",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1988, VOLUME = 48, NUMBER = 2, PAGES = "327-334", MONTH = "February"}

@TECHREPORT{Kryukov:88b,
 AUTHOR = "A. P. Kryukov and D. A. Slavnov",
 TITLE = "The Role of the $gg \rightarrow c\overline{c}g$ Process in the
Cross Section of Production of Charmed Particles (in {Russian})",
 INSTITUTION = "Moscow State University",
 YEAR = 1988, NUMBER = "88-49/70", TYPE = "Preprint"}

@BOOK{Kryukov:91,
 AUTHOR = "A. P. Kryukov and A. Ya. Rodionov and A. Yu. Taranov and
E. Shablygin",
 TITLE = "Programming in R-Lisp",
 PUBLISHER = "Radio and Connective Publishers, Moscow", YEAR = 1991,
 ABSTRACT = {Various Lisp dialects become more and more popular as
high-level programming languages.  In this book basic Lisp concepts, its
data structures and build in functions are introduced using R-Lisp.
R-Lisp is the implementation language of a famous REDUCE computer algebra
system.  All concepts are illustrated by simple but by no means trivial
programming examples.  The description of compiler and full function
reference are included.  The book will be interesting for beginners as
well as Lisp programmers. In Russian}}

@TECHREPORT{Kuppers:71,
 AUTHOR = "G. Kuppers and D. Pfirsch and H. Tasso",
 TITLE = "{M.H.D.} - Stability of Axisymmetric Plasmas",
 INSTITUTION = "Max-Planck-Institut fuer Plasmaphysik",
 YEAR = 1971, TYPE = "Report", NUMBER = "CN -28/F-14"}

@ARTICLE{Lambin:84,
 AUTHOR = "P. Lambin and J. P. Vigneron",
 TITLE = "Computation of Crystal {Green's} Functions in the Complex-Energy
Plane with the Use of the Analytical Tetrahedron Method",
 JOURNAL = "Phys. Rev. B",
 YEAR = 1984, VOLUME = 29, NUMBER = 6, PAGES = "3430-3437",
 COMMENT = {Crystallography, {REDUCE}, quantum theory.}}

@TECHREPORT{Lang:79,
 AUTHOR = "C. B. Lang and W. Porod",
 TITLE = "Symmetry Breaking and $\pi$ {K} Amplitudes in the Unphysical
Region",
 INSTITUTION = "Institut f{\"u}r Theor. Physik, Univ. Graz",
 YEAR = 1979, TYPE = "Report", NUMBER = "UNIGRAZ-UTP 08/79",
 ABSTRACT = {We apply two different methods of analytic continuation
(fixed-t and hyperbolic dispersion relations with discrepancy) to
determine the expansion parameters of the pi K amplitudes in the
unphysical region near the symmetry point.},
 COMMENT = {To be published in Phys. Rev. D, September, 1979.}}

@TECHREPORT{Laursen:79,
 AUTHOR = "M. L. Laursen and M. A. Samuel",
 TITLE = "The n-Bubble Diagram Contribution to the g-2 of the Electron -
{Mathematical} Structure of the Analytical Expression",
 INSTITUTION = "Oklahoma State Univ. Quantum Theoretical Research Group",
 YEAR = 1979, TYPE = "Research Note", NUMBER = "96",
 ABSTRACT = {We obtain an exact integrated expression for the contribution
of the mass-independent n-bubble diagram to the leptonic g-2.}}

@TECHREPORT{Laursen:80,
 AUTHOR = "Morten L. Laursen and Mark A. Samuel",
 TITLE = "Borel Transform Technique and the {n-Bubble} Diagram
Contribution to the Lepton Anomaly",
 INSTITUTION = "Oklahoma State Univ. Quantum Theoretical Research Group",
 YEAR = 1980, TYPE = "Research Note", NUMBER = 10, MONTH = "August",
 ABSTRACT = {By using the {Borel} transform technique we calculate
analytically the muon anomaly from the mass-dependent n-bubble diagram in the
limit where the mass ratio is large.}}

@ARTICLE{Laursen:81,
 AUTHOR = "M. L. Laursen and M. A. Samuel",
 TITLE = "The n-bubble Diagram Contribution to g-2",
 JOURNAL = "J. Maths. Phys.",
 YEAR = 1981, VOLUME = 22, PAGES = "1114-1126",
 COMMENT = {Exact integration for contribution to mass indep. {n-bubble}
diagram to {leptonic g-2}.  {REDUCE} used to calculate explicitly to {n=13},
involves summing series and rational coefficients.}}

@ARTICLE{Lecourtier:85,
 AUTHOR = "Y. Lecourtier and A. Raksanyi",
 TITLE = "Algebraic Manipulation Routines for Testing Structural Properties",
 JOURNAL = "IFAC Identification and System Parameter Estimation",
 YEAR = 1985, PAGES = "543-549"}

@ARTICLE{Lee:85,
 AUTHOR = "H-C Lee and M. S. Milgram",
 TITLE = "On the Axial Gauge:  Ward Identities and the Separation of
Infrared and Ultraviolet Singularities by Analytical Regularization",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1985, VOLUME = 26, PAGES = "1793-1804",
 COMMENT = {Yang-Mills theories on the axial gauge.  Uses {SCHOONSCHIP} and
{REDUCE}.}}

@ARTICLE{Leler:85,
 AUTHOR = "Wm Leler and Neil Soiffer",
 TITLE = "An Interactive Graphical Interface for {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "17-23", MONTH = "August"}

@ARTICLE{Lepage:83,
 AUTHOR = "G. P. Lepage and P. B. Mackenzie and K. H. Streng and
P. M. Zernas",
 TITLE = "Multiphoton Decays of Positronium",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1983, VOLUME = 28, PAGES = "3090-3091",
 COMMENT = {Same as Adkins and Brown (1983) but independent of it.}}

@INPROCEEDINGS{Levi:70,
 AUTHOR = "I. Levi and N. Hoff",
 TITLE = "Non-Symmetric Creep Buckling of Circular
Cylindrical Shells in Axial Compression",
 YEAR = 1970, MONTH = "August",
 BOOKTITLE = "Proc. Intern. Symp. in Creep Effect in Structures,
Gotenburg, Sweden"}

@INPROCEEDINGS{Levi:71,
 AUTHOR = "I. M. Levi",
 TITLE = "Symbolic Algebra by Computer - Applications to
Structural Mechanics",
 YEAR = 1971, MONTH = "April",
 BOOKTITLE = "{AIAA/ASME} 12th Structures, Structural Dynamics
and Materials Conference, Anaheim, California"}

@ARTICLE{Liebermann:75,
 AUTHOR = "R. Liebermann",
 TITLE = "Traces of High Energy Processes in Strong Magnetic Fields",
 JOURNAL = "J. Comp. Phys.",
 YEAR = 1975}

@ARTICLE{Liska:84,
 AUTHOR = "R. Liska",
 TITLE = "Program for Stability and Accuracy Analysis of
Finite Difference Methods",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1984, VOLUME = 34, PAGES = "175-186"}

@INPROCEEDINGS{Liska:87,
 AUTHOR = "R. Liska and D. Drska",
 TITLE = "Evaluation of Plasma Fluid Equations Collision Integrals Using
{REDUCE}",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = 178,
 PUBLISHER = "Springer-Verlag"}

@InProceedings{Liska90,
  author =      "R. Liska and L. Drska",
  title =       "{FIDE}: A {REDUCE} package for automation of {FI}nite
                 difference method for solving {pDE}",
  booktitle =   "Proceedings of the 1990 International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "169-176",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@INPROCEEDINGS{Liska:91,
 AUTHOR = "Richard Liska and Michail Yu. Shashkov",
 TITLE = "Algorithms for Difference Schemes Construction on Non-orthogonal
Logically Rectangular Meshes",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt",
 PUBLISHER = "ACM Press", ADDRESS = "Maryland", PAGES = "419-426",
 YEAR = 1991,
 ABSTRACT = {The paper deals with the formalization of the basic operator
method for construction of difference schemes for the numerical solving
of partial differential equations.  The strength of the basic operator
method lies on the fact that it produces fully conservative difference
schemes.  The difference mesh can be non-orthogonal but has to be logically
orthogonal.  Algorithms for working with grid functions and grid operators
in symbolic form which are necessary in the basic operator method are
described.  The algorithms have been implemented in the computer algebra
system REDUCE.}}

@ARTICLE{Lloyd:90,
 AUTHOR = "N. G. Lloyd and J. M. Pearson",
 TITLE = "{REDUCE} and the Bifurcation of Limit Cycles",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1990, VOLUME = 9, NUMBER = 2, PAGES = "215-224", MONTH = "February"}

@INPROCEEDINGS{Loe:85,
 AUTHOR = "Kia Fock Loe and Noritaka Ohsawa and Eiichi Goto",
 TITLE = "Circuit Simulation Code Generation by Computer Algebra",
 YEAR = 1985,
 BOOKTITLE = "Proc. of the Second {RIKEN} International
Symposium on Symbolic and Algebraic Computation by Computers",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "87-103"}

@INPROCEEDINGS{London:74,
 AUTHOR = "R. London and D. R. Musser",
 TITLE = "The Application of a Symbolic Mathematical System
to Program Verification",
 YEAR = 1974, PAGES = "265-273",
 BOOKTITLE = "Proc. {ACM} 74"}

@ARTICLE{Loos:72,
 AUTHOR = "R{\"u}diger Loos",
 TITLE = "Analytic Treatment of Three Similar {Fredholm} Integral
Equations",
 JOURNAL = "SIGSAM Bulletin",
 YEAR = 1972, VOLUME = 11, PAGES = "32-40",
 ABSTRACT = {A {REDUCE} solution to {SIGSAM} Problem \#1 is presented.}}

@INPROCEEDINGS{Lottati,
 AUTHOR = "Itzhak Lottati and Isaac Elishakoff",
 TITLE = "Refined Dynamical Theories of Beams, Plates
and Shells and Their Applications",
 BOOKTITLE = "Proc. Euromech-Colloquium 219"}

@ARTICLE{Louw:86,
 AUTHOR = "J. A. Louw and F. Schwarz and W. H. Steeb",
 TITLE = "First Integrals and {Yoshida} Analysis of {Nahm}'s Equation",
 JOURNAL = "J. Phys. A",
 YEAR = 1986, VOLUME = 19, PAGES = "L569-L573",
 COMMENT = {Monopole solutions in Yang-Mills theories explicitely given in
special cases.  {REDUCE} used for polynomial first integrals and
Kowalewski exponents.  An application of spde.}}

@ARTICLE{Luegger:73,
 AUTHOR = "J. Luegger and H. Melenk",
 TITLE = "Darstellung und {Bearbeitung} Umfangreicher {LISP-Programme}",
 JOURNAL = "Angewandte Informatik",
 YEAR = 1973, MONTH = "June", PAGES = "257-263"}

@TECHREPORT{Luegger:91,
 AUTHOR = "Joachim L{\"u}gger and Wolfgang Dalitz",
 TITLE = "Verteilung mathematischer {Software} mittels elektronischer
{Netze:} {Die} elektronische {Softwarebibliothek} {eLib}",
 INSTITUTION = "Konrad-Zuse-Zentrum {f\"u}r Informationstechnik Berlin",
 YEAR = 1991, MONTH = "February", TYPE = "Preprint", NUMBER = "TR 91-2"}

@TECHREPORT{Lukacs,
 AUTHOR = "B. Luk{\'a}cs and Z. Perj{\'e}s and
A. Sebesty{\'e}n and A. Valentini",
 TITLE = "Stationary Vacuum Fields with a Conformally Flat
Three-Space, II. Proof of Axial Symmetry",
 INSTITUTION = "Central Research Institute for Physics,
Budapest, Hungary",
 YEAR = 1982, NUMBER = "KFKI-1982-19"}

@ARTICLE{Lukaszuk:87,
 AUTHOR = "L. L{\'u}kaszuk and D. M. Siemienczuk and L. Szymanowski",
 TITLE = "Evaluation of Helicity Amplitudes",
 JOURNAL = "Phys. Rev. D",
 YEAR = 1987, VOLUME = 35, PAGES = "326-329"}

@PHDTHESIS{Lux:75,
 AUTHOR = "Augustin Lux",
 TITLE = "Etude d'un Modele Abstrait pour une Machine {LISP} et de
son Implantation",
 SCHOOL = "Universit{\'e} Scientifique et Medicale de Grenoble",
 YEAR = 1975, MONTH = "March",
 COMMENT = {Thesis presented to Universit{\'e} Scientifique et Medicale de
Grenoble, Institut National Polytechnique de Grenoble.}}

%                          REDUCE BIBLIOGRAPHY

%                              Part 3:  M-Z

% Copyright (c) 1990 The RAND Corporation.  All Rights Reserved.

% Additions and corrections are solicited.  Please send them, in the
% same format as these entries if possible, to reduce at rand.org.


@BOOK{MacCallum:86,
 AUTHOR = "M. A. H. MacCallum",
 TITLE = "Dynamical Spacetimes and Numerical Relativity",
 PUBLISHER = "Cambridge UP", YEAR = 1986}

@TECHREPORT{MacCallum:86a,
 AUTHOR = "M. A. H. MacCallum",
 TITLE = "Algebraic Computing in Relativity",
 INSTITUTION = "Queen Mary College, University of London",
 YEAR = 1986, NUMBER = "TAU 86-04"}

@INPROCEEDINGS{MacCallum:87,
 AUTHOR = "M. A. H. MacCallum",
 TITLE = "Symbolic Computation in Relativity Theory",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "34-43",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{MacCallum:88,
 AUTHOR = "M. A. H. MacCallum",
 TITLE = "An Ordinary Differential Equation Solver for {REDUCE}",
 BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag",
 YEAR = 1988, VOLUME = 358, PAGES = "196-205"}

@ARTICLE{MacCallum:89,
 AUTHOR = "Malcolm A. H. MacCallum",
 TITLE = "Comments on the performance of algebra systems in general
relativity and a recent paper by {Nielsen} and {Pedersen}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1989, VOLUME = 23, NUMBER = 2, PAGES = "22-25", MONTH = "April"}

@BOOK{MacCallum:91,
 AUTHOR = "Malcolm MacCallum and Francis Wright",
 TITLE = "Algebraic Computing with {REDUCE}",
 PUBLISHER = "Oxford University Press", YEAR = 1991}

@PHDTHESIS{Mack:73,
 AUTHOR = "D. Mack",
 TITLE = "Nichtnumerische Verfahren und deren Anwendung
in der Elementarteilchen-Physik",
 SCHOOL = "University of Tuebingen",
 YEAR = 1973}

@ARTICLE{Mack:73a,
 AUTHOR = "D. Mack and H. Mitter",
 TITLE = "Calculation of Electron-Electron-Bremsstrahlung Cross-Sections",
 JOURNAL = "Phys. Lett.",
 YEAR = 1973, VOLUME = "44A", PAGES = "71-72"}

@ARTICLE{Maclaren:89,
 AUTHOR = "N. M. Maclaren",
 TITLE = "The Generation of Sequences of Multiple Independent Sequences
of Pseudorandom Numbers",
 JOURNAL = "Applied Statistics {JRSS Series C}",
 YEAR = 1989, VOLUME = 38, NUMBERS = 2, PAGES = "351-359"}

@MASTERSTHESIS{Maguire:81,
 AUTHOR = "Gerald Quentin {Maguire Jr.}",
 TITLE = "Program Transformation in {REDUCE} Using Rule Sequencing",
 SCHOOL = "Department of Computer Science, The University of Utah",
 YEAR = 1981, MONTH = "March"}

@INPROCEEDINGS{Malm:82,
 AUTHOR = "Bengt Malm",
 TITLE = "A Program in {REDUCE} for Finding Explicit Solutions",
 BOOKTITLE = "Proc. {EUROCAM} 1982, Lecture Notes
in Computer Science", YEAR = 1982, VOLUME = 144, PAGES = "289-293",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Marti:78,
 AUTHOR = "Jed Marti",
 TITLE = "The {META/REDUCE} Translator Writing System",
 JOURNAL = "Sigplan Notices",
 YEAR = 1978, VOLUME = 13, PAGES = "42-49",
 COMMENT = {The {META/REDUCE} translator writing system operates in a
{LISP} and {REDUCE} syntax.  The language supports: {BNF} like syntax,
recursive descent parsing schemes, lexical primitives, symbol table
primitives and automatic syntax error message generation.}}

@ARTICLE{Marti:79,
 AUTHOR = "J. B. Marti and A. C. Hearn and M. L. Griss and C. Griss",
 TITLE = "Standard {Lisp} Report",
 JOURNAL = "Sigplan Notices, ACM",
 YEAR = 1979, VOLUME = 14, NUMBER = 10, PAGES = "48-68",
 ABSTRACT = {A description of Standard {LISP} primitive data structures and
functions is presented.}}

@ARTICLE{Marti:80,
 AUTHOR = "J. Marti and A. C. Hearn and M. L. Griss and C. Griss",
 TITLE = "Standard {Lisp} Report",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1980, VOLUME = 14, NUMBER = 1, PAGES = "23-41", MONTH = "February"}

@ARTICLE{Marti:83,
 AUTHOR = "Jed Marti and John Fitch",
 TITLE = "{REDUCE} 2 for {CP/M}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "26-27", MONTH = "February"}

@ARTICLE{Marti:85,
 AUTHOR = "Jed B. Marti and Anthony C. Hearn",
 TITLE = "{REDUCE} as a {LISP} Benchmark",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "8-16", MONTH = "August"}

@INPROCEEDINGS{Marti:85a,
 AUTHOR = "Jed B. Marti",
 TITLE = "The Role of Explanation in Symbolic Computation",
 YEAR = 1985,
 BOOKTITLE = "Proc. of the Second {RIKEN} International
Symposium on Symbolic and Algebraic Computation by Computers",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "13-34"}

@INPROCEEDINGS{Marti:88,
 AUTHOR = "J. Marti",
 TITLE = "A Graphics Interface to {REDUCE}",
 BOOKTITLE = "Proc. {AAECC-6} 1988, Lecture Notes in Computer Science",
 YEAR = 1988, VOLUME = 357, PAGES = "274-296",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{Marzinkewitsch:91,
 AUTHOR = "Reiner Marzinkewitsch",
 TITLE = "Operating Computer Algebra Systems by Handprinted Input",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland",
 PAGES = "411-413",
 ABSTRACT = {A prototype of a workstation is presented for calculation
with mathematical formulas by hand and support by computer algebra systems.
Keywords:  Character recognition, neural network, computer algebra system,
context free grammar, parsing of two dimensional structures.}}

@ARTICLE{Matveev:87,
 AUTHOR = "V. A. Matveev and Ya. Z. Darbaidze and
Z. V. Merebashvili and L. A. Slepchenko",
 TITLE = "Gluon Fusion in {SUSY QCD}",
 JOURNAL = "Phys. Lett. B",
 YEAR = 1987, VOLUME = 191, NUMBER = "1 and 2", PAGES = "179-181",
 MONTH = "June"}

@ARTICLE{Maurer:86,
 AUTHOR = "M. Maurer and A. Hayd and H. J. Kaeppeler",
 TITLE = "Quasi-Analytical Method for Solving Nonlinear Differential
Equations for Turbulent Self-Confined Magneto-Plasma",
 JOURNAL = "J. Comp. Phys.",
 YEAR = 1986, VOLUME = 66, PAGES = "151-172",
 COMMENT = {Mixed {REDUCE} and {FORTRAN}.  Enthusiastic about this style of
mixed working.}}

@TECHREPORT{Mazepa:85,
 AUTHOR = "N. E. Mazepa and S. I. Serdyukova",
 TITLE = "The Stability Investigation of Some Difference Boundary Problem
with the Application of Symbolic Computation System",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1985, NUMBER = "E5-85-39"}

@ARTICLE{Mazzarella:85,
 AUTHOR = "Giuseppe Mazzarella",
 TITLE = "Improved Simplification of Odd and Even Functions in {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 2, PAGES = "29-30", MONTH = "May"}

@ARTICLE{McCrea:81,
 AUTHOR = "J. D. McCrea",
 TITLE = "The {Petrov} Type of a Static Vacuum Spacetime Near a
Normal-Dominated Singularity",
 JOURNAL = "J. Phys.",
 YEAR = 1981, VOLUME = "A14", PAGES = "1351-1356"}

@ARTICLE{McCrea:82,
 AUTHOR = "J. D. McCrea",
 TITLE = "A Stationary Cylindrically Symmetric Electrovac Spacetime",
 JOURNAL = "J. Phys.",
 YEAR = 1982, VOLUME = "A15", PAGES = "1587-1590"}

@ARTICLE{McCrea:83,
 AUTHOR = "J. D. McCrea",
 TITLE = "Static, Vacuum, Cylindrical and Plane Symmetric Solutions
of the Quadratic {Poincar{\'e}} Gauge Field Equations",
 JOURNAL = "J. Phys.",
 YEAR = 1983, VOLUME = "A16", PAGES = "997-1004"}

@ARTICLE{McCrea:84,
 AUTHOR = "J. D. McCrea",
 TITLE = "A {NUT}-Like Solution of the Quadratic-{Poincar{\'e}} Gauge
Field Equations",
 JOURNAL = "Phys. Lett.",
 YEAR = 1984, VOLUME = "100A", PAGES = "397-399"}

@INPROCEEDINGS{McCrea:84a,
 AUTHOR = "J. D. McCrea",
 TITLE = "The Use of {REDUCE} in Finding Exact Solutions of the
Quadratic {Poincar{\'e}} Gauge Field Equations",
 BOOKTITLE = "Classical General Relativity",
 PUBLISHER = "Cambridge University", YEAR = 1984, PAGES = "173-182"}

@INPROCEEDINGS{McCrea:87,
 AUTHOR = "J. D. McCrea",
 TITLE = "{Poincar{\'e}} Gauge Theory of Gravitation:  Foundations,
Exact Solutions and Computer Algebra",
 YEAR = 1987, PAGES = "16",
 BOOKTITLE = "Differential Geometric Methods in Mathematical
Physics, Proc. {14th} International Conference,
Salamanca, 1985 (Springer Lecture Notes in Mathematics, No. 1251)"}

@ARTICLE{McCrea:87a,
 AUTHOR = "J. D. McCrea and P. Baekler and M. Guerses",
 TITLE = "A {Kerr}-Like Solution of the {Poincar{\'e}} Gauge Field
Equations",
 JOURNAL = "Il Nuovo Cim",
 YEAR = 1987, VOLUME = "99B", PAGES = "171-177"}

@ARTICLE{McCrea:88,
 AUTHOR = "J. D. McCrea and E. W. Mielke and F. W. Hehl",
 TITLE = "A Remark on the Axisymmetric {Chen} et al. Solution of the
{Poincar{\'e}} Gauge Theory",
 JOURNAL = "Phys. Lett.",
 YEAR = 1988, VOLUME = "127A", PAGES = "65-69"}

@ARTICLE{McIsaac:85,
 AUTHOR = "Kevin McIsaac",
 TITLE = "Pattern Matching Algebraic Identities",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 2, PAGES = "4-13", MONTH = "May"}

@TECHREPORT{Melenk:88,
 AUTHOR = "H. Melenk and H. M. M{\"o}ller and W. Neun",
 TITLE = "On {Gr{\"o}bner} Bases Computation on a Supercomputer
Using {REDUCE}",
 INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik
Berlin",
 YEAR = 1988, TYPE = "Preprint", NUMBER = "SC 88-2", MONTH = "January"}

@ARTICLE{Melenk:89,
 AUTHOR = "H. Melenk and H. M. M{\"o}ller and W. Neun",
 TITLE = "Symbolic Solution of Large Stationary Chemical
Kinetics Problems",
 JOURNAL = "Impact of Computing in Science and Engineering",
 YEAR = 1989, VOLUME = 1, NUMBER = 2, PAGES = "138-167", MONTH = "June"}

@TECHREPORT{Melenk:89a,
 AUTHOR = "Herbert Melenk and Winfried Neun",
 TITLE = "Implementation of {Portable Standard LISP} for the {SPARC}
Processor",
 INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin",
 YEAR = 1989, TYPE = "Preprint", NUMBER = "SC 89-6", MONTH = "July"}

@ARTICLE{Melenk:89b,
 AUTHOR = "Herbert Melenk and Winfried Neun",
 TITLE = "Parallel Polynomial Operations in the Large {Buchberger}
Algorithm",
 JOURNAL = "Computer Algebra and Parallelism", EDITOR = "J. Della Dora
and J. Fitch",
 YEAR = 1989, PAGES = "143-158", PUBLISHER = "Academic Press, London"}

@ARTICLE{Mirie:84,
 AUTHOR = "R. M. Mirie and C. H. Su",
 TITLE = "Internal Solitary Waves and Their Head-On Collision Part I",
 JOURNAL = "J. Fluid Mechanics",
 YEAR = 1984, VOLUME = 147, PAGES = "213-231",
 COMMENT = {Lengthy calculation "acknowledge the use of {REDUCE-2}."
Perturbation and integration.}}

@INPROCEEDINGS{Molenkamp:91,
 AUTHOR = "J.H.J. Molenkamp and V.V. Goldman and J.A. van Hulzen",
 TITLE = "An Improved Approach to Automatic Error Cumulation Control",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland",
 PAGES = "414-418",
 ABSTRACT = {For evaluation of arithmetical expressions using multiple
precision floating-point arithmetic, a method is given to automatically
perform error cumulation control prior to the actual computations.
Individual errors and their effects are identified, and it is shown how to
compute these effects efficiently via automatic differentiation.  In the
presented approach these effects are used to determine which precisions have
to be chosen during the real computations, in order to limit error cumulation
to admissible, user chosen error bounds.}}

@TECHREPORT{Moller:89,
 AUTHOR = "H. Michael M{\"o}ller",
 TITLE = "Multivariate Rational Interpolation Reconstruction of Rational
Functions",
 INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik
Berlin",
 YEAR = 1989, TYPE = "Preprint", NUMBER = "SC 89-4", MONTH = "July"}

@INPROCEEDINGS{Moritsugu:85,
 AUTHOR = "S. Moritsugu and N. Inada and E. Goto",
 TITLE = "Symbolic {Newton} Iteration and its Application",
 YEAR = 1985,
 BOOKTITLE = "Proc. of the Second {RIKEN} International
Symposium on Symbolic and Algebraic Computation by Computers",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "105-117"}

@TECHREPORT{Moritsugu:88,
 AUTHOR = "S. Moritsugu and E. Goto",
 TITLE = "A Proposal for Improvement of Facilities of {REDUCE}",
 INSTITUTION = "Department of Information Science,
University of Tokyo, Japan",
 YEAR = 1988, MONTH = "December"}

@ARTICLE{Moritsugu:89,
 AUTHOR = "Shuichi Moritsugu and Eiichi Goto",
 TITLE = "A Note on the Preconditioning for Factorization of Homogeneous
Polynomials",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1989, VOLUME = 23, NUMBER = 1, PAGES = "9-12", MONTH = "January"}

@ARTICLE{Moritsugu:89a,
 AUTHOR = "Shuichi Moritsugu and Makoto Matsumoto",
 TITLE = "A Note on the Numerical Evaluation of Arctangent Function",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1989, VOLUME = 23, NUMBER = 3, PAGES = "8-12", MONTH = "July"}

@ARTICLE{Muroa:91,
 AUTHOR = "Hirokazu Murao",
 TITLE = "Vectorization of symbolic determinant calculation",
 JOURNAL = "Supercomputer",
 YEAR = 1991, VOLUME = "43,VIII-3", PAGES = "36-48"}

@ARTICLE{Mueller:81,
 AUTHOR = "R. M{\"u}ller and H. J. W. M{\"u}ller-Kirsten",
 TITLE = "Iteration of Single- and Two-Channel {Schr{\"o}dinger} Equations",
 JOURNAL = "J. Math. Phys.",
 YEAR = 1981, VOLUME = 22, PAGES = "733-749",
 ABSTRACT = {{\dots} we describe an iteration procedure which has already
been applied to a large number of other problems.  With the help of
{REDUCE} it is now possible to do these algebraic computations on the
computer, so that the necessary expressions are obtained within a
reasonable time.}}

@ARTICLE{Murzin:85,
 AUTHOR = "F. A. Murzin",
 TITLE = "Syntactic Properties of the {REFAL} Language",
 JOURNAL = "Int. J. Computer Maths.",
 YEAR = 1985, VOLUME = 17, PAGES = "123-139",
 COMMENT = {{SNOBOL-like} special purpose algebra system.  Designed for
Cartan  work.  "{REFAL} is rather an unusual programming language.  It is
natural to ask in which situations it is useful."  Concludes {MACSYMA}
or {REDUCE} for standard manipulations, {REFAL} for nonstandard.}}

@TECHREPORT{Nagata:82,
 AUTHOR = "Morio Nagata and Makoto Shibayama",
 TITLE = "{COSMOS:}  A Conversational Algebraic System",
 INSTITUTION = "Department of Administration Engineering,
Keio University",
 YEAR = 1982, TYPE = "Technical Report", NUMBER = "No. 8201",
 MONTH = "March"}

@INPROCEEDINGS{Nagata:85,
 AUTHOR = "Morio Nagata and Makoto Shibayama",
 TITLE = "An Interactive Algebraic System for Personal Computing",
 YEAR = 1985,
 BOOKTITLE = "IEEE International Symposium on New Directions
in Computing"}

@BOOK{Nakamura:89,
 AUTHOR = "Hideharu Nakamura and Shouichi Matsui",
 TITLE = "Symbolic Computation in Structural Mechanics using {REDUCE}",
 PUBLISHER = "Gihodo Shuppan Company Ltd.", ADDRESS = "1-11-41,
Akasaka, Minato-Ku, 107 Tokyo, {Japan}", YEAR = 1989}

@ARTICLE{Nakashima:84,
 AUTHOR = "T. T. Nakashima and R. E. D. McClung and B. K. John",
 TITLE = "A Simple Method for the Determination of the Deuterium
Decoupler Pulse Angle",
 JOURNAL = "J. Magnetic Resonance",
 YEAR = 1984, VOLUME = 56, PAGES = "262-274",
 COMMENT = {{REDUCE} used in theoretical part.  "All density matrix
calculations presented here were performed on a digital computer using
REDUCE-2." Essentially matrix products.}}

@ARTICLE{Nakashima:84a,
 AUTHOR = "T. T. Nakashima and R. E. D. McClung and B. K. John",
 TITLE = "Experimental and Theoretical Investigation of
$_{2}D-_{13}C$ DEPT Spectra on $CD_{N}$",
JOURNAL = "J. Magnetic Resonance",
 YEAR = 1984, VOLUME = 58, PAGES = "27-36",
 COMMENT = {"All calculations were performed using {REDUCE-2}."}}

@ARTICLE{Namba:86,
 AUTHOR = "Kenji Namba",
 TITLE = "Some Improvements on {Utah} {Standard} {Lisp}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1986, VOLUME = 20, NUMBER = "1 and 2", PAGES = "29-36",
 MONTH = "February and May"}

@ARTICLE{Nemeth:82,
 AUTHOR = "G. N{\'e}meth and M. Zim{\'a}nyi",
 TITLE = "Polynomial Type {Pad\'e} Approximants",
 JOURNAL = "Math. Comp.",
 YEAR = 1982, VOLUME = 38, PAGES = "553-565",
 COMMENT = {Looking for approximants where $R_{n}(x)$ is
$P_{n}(x)$/P_{n-1}(x)$.  Applied in special functions.  Used
REDUCE and FORMAC mainly for bignum calculations.}}

@INPROCEEDINGS{Nemeth:87,
 AUTHOR = "G. N{\'e}meth and M. Zim{\'a}nyi",
 TITLE = "Computation of Generalized {Pad\'e} Approximants",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "450-451",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Neun:89,
 AUTHOR = "W. Neun and H. Melenk",
 TITLE = "Implementation of the {LISP-}Arbitrary Precision Arithmetic
for a {Vector} Processor",
 JOURNAL = "Computer Algebra and Parallelism", EDITOR = "J. Della Dora
and J. Fitch",
 YEAR = 1989, PAGES = "75-89", PUBLISHER = "Academic Press, London"}

@ARTICLE{Neutsch:85,
 AUTHOR = "W. Neutsch and E. Schr{\"u}fer and A. Jessner",
 TITLE = "Note on Efficient Integration on the Hypersphere",
 JOURNAL = "J. Comp. Phys.",
 YEAR = 1985, VOLUME = 59, PAGES = "167-175",
 COMMENT = {{REDUCE} used for integration on 4-D hypersphere.  {REDUCE}
use rather small.}}

@ARTICLE{Neutsch:86,
 AUTHOR = "W. Neutsch and E. Schr{\"u}fer",
 TITLE = "Simple Integrals for Solving {Kepler}'s Equation",
 JOURNAL = "Astrophysics and Space Science",
 YEAR = 1986, VOLUME = 125, PAGES = "77-83",
 COMMENT = {Uses {REDUCE} to verify calculations to give integral form which
is numerically good, involving only rationals and exponentials.}}

@ARTICLE{Ng:89,
 AUTHOR = "Tze Beng Ng",
 TITLE = "Computation of the Cohomology of ${B\hat{S}O_{n}<16>}$ for
$23 \leq n \leq 26$ using {REDUCE}",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1989, VOLUME = 7, NUMBER = 1, PAGES = "93-99", MONTH = "January"}

@ARTICLE{Niki:84,
 AUTHOR = "Naoto Niki and Sadanori Konishi",
 TITLE = "Higher Order Asymptotic Expansions for the
Distribution of the Sample Correlation Coefficient",
 JOURNAL = "Comm. Statist.-Simula. Comp.",
 YEAR = 1984, VOLUME = 13, NUMBER = 2, PAGES = "169-182"}

@TECHREPORT{Nikityuk:87,
 AUTHOR = "N. M. Nikityuk",
 TITLE = "Some Questions of Using Coding Theory and Analytical
Calculation Methods on Computers",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1987, NUMBER = "E11-87-10"}

@ARTICLE{Noor:79,
 AUTHOR = "A. K. Noor and C. M. Andersen",
 TITLE = "Computerized Symbolic Manipulation in Structural Mechanics -
Progress and Potential",
 JOURNAL = "Computers and Structures",
 YEAR = 1979, VOLUME = 10, PAGES = "95-118",
 COMMENT = {Concentrates on {MACSYMA} but mentions {FORMAC} and {REDUCE}
as also having been used in structures.  Mainly finite elements.  Includes
program and output.}}

@INPROCEEDINGS{Norman:77,
 AUTHOR = "A. C. Norman and P. M. A. Moore",
 TITLE = "Implementing the New {Risch} Integration Algorithm",
 YEAR = 1977, MONTH = "March",
 BOOKTITLE = "Proc. of the Fourth Colloquium on Advanced Comp.
Methods in Theor. Phys., St. Maximin, France"}

@ARTICLE{Norman:78,
 AUTHOR = "Arthur Norman",
 TITLE = "Towards a {REDUCE} solution to {SIGSAM} Problem 7",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1978, VOLUME = 12, NUMBER = 4, PAGES = "14-18", MONTH = "November"}

@INPROCEEDINGS{Norman:79,
 AUTHOR = "A. C. Norman and J. H. Davenport",
 TITLE = "Symbolic Integration - The Dust Settles?",
 BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes
in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "398-407",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Norman:83,
 AUTHOR = "Arthur C. Norman and Paul S. Wang",
 TITLE = "A Comparison of the {Vaxima} and {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "28-30",
 MONTH = "February"}

@InProceedings{Norman90,
  author =      "A. C. Norman",
  title =       "A Critical-Pair/Completion based Integration Algorithm",
  booktitle =   "Proceedings of the International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "201-205",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@ARTICLE{Norton:80,
 AUTHOR = "Lewis M. Norton",
 TITLE = "A Note About {Laplace} Transform Tables for Computer Use",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1980, VOLUME = 14, NUMBER = 2, PAGES = "30-31", MONTH = "May"}

@TECHREPORT{Nucci:90,
 AUTHOR = "M. C. Nucci",
 TITLE = "Interactive {REDUCE} Programs for Calculating Classical,
Non-Classical and {Lie-B{\"a}cklund} Symmetries of Differential Equations",
 INSTITUTION = "Georgia Institute of Technology, School of Mathematics",
 YEAR = 1990, TYPE = "Preprint", NUMBER = "Math: 062090-051"}

@BOOK{Ochiai:90,
 AUTHOR = "Mitsuyuki Ochiai and Kiyokazu Nagatomo",
 TITLE = "Linear Algebra using {REDUCE}",
 PUBLISHER = "Kindai Kagaku sha, Tokyo", MONTH = "January", YEAR = 1990,
 COMMENT = {In Japanese.}}

@ARTICLE{Ogilvie:82,
 AUTHOR = "J. F. Ogilvie",
 TITLE = "Applications of Computer Algebra in Physical Chemistry",
 JOURNAL = "Computers in Chemistry",
 YEAR = 1982, VOLUME = 6, NUMBER = 4, PAGES = "169-172",
 COMMENT = {After distinguishing between algebraic and numerical
computing, the author outlines the facilities of some
algebraic or symbolic processors and provides some
instances of how some important features can be applied
to problems in physical chemistry.}}

@ARTICLE{Ogilvie:89,
 AUTHOR = "J. F. Ogilvie",
 TITLE = "Computer algebra in modern physics",
 JOURNAL = "Computers in Physics",
 YEAR = 1989, MONTH = "January/February", PAGES = "66-74"}

@TECHREPORT{Ono:1979,
 AUTHOR = "Kiyoshi Ono",
 TITLE = "{BFORT} -- A {Fortran} System with Arbitrary
Precision Integer and Real Arithmetic",
 INSTITUTION = "Department of Physics, University of Tokyo",
 YEAR = 1979, MONTH = "January"}

@TECHREPORT{Ozieblo,
 AUTHOR = "A. Ozieblo",
 TITLE = "Application of {REDUCE 2} in General Theory of Relativity",
 INSTITUTION = "Cyfronet - Krakow, Poland",
 COMMENT = {Application of {REDUCE 2} in all calculations typical for
General Theory of Relativity is shown here.  The most
spectacular usage of {REDUCE 2} appears to be in various
aspects of tensor calculus including differentiation
operations.}}

@InProceedings{Padget90,
  author =      "Julian Padget and Alan Barnes",
  title =       "Univariate Power Series Expansions in {REDUCE}",
  booktitle =   "Proceedings of the International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "82-87",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@ARTICLE{Pankau:73,
 AUTHOR = "E. Pankau and W. Nakel",
 TITLE = "Measurement of the Absolute Cross Section of the
Elementary Process of Electron-Electron Bremsstrahlung at 300 {keV}",
 JOURNAL = "Phys. Lett.",
 YEAR = 1973, VOLUME = "44A", PAGES = "65-67"}

@ARTICLE{Pankau:73a,
 AUTHOR = "E. Pankau and W. Nakel",
 TITLE = "Eine {Koinzidenzmessung} zum {Elementarprozess}
der {Elektron-Elektron-Bremsstrahlung} bei 300 {keV}",
 JOURNAL = "Z. Physik",
 YEAR = 1973, VOLUME = 264, PAGES = "139-153"}

@ARTICLE{Parsons:68,
 AUTHOR = "R. G. Parsons",
 TITLE = "An Estimate of the Sixth Order Contribution to the
Anomalous Magnetic Moment of the Electron",
 JOURNAL = "Phys. Rev.",
 YEAR = 1968, VOLUME = 168, PAGES = "1562-1567"}

@TECHREPORT{Parsons:71,
 AUTHOR = "R. G. Parsons",
 TITLE = "S-Channel Transformation Matrices for Helicity and
Invariant Amplitudes for lambda + N to O + B",
 INSTITUTION = "Center for Particle Theory, University of Texas",
 YEAR = 1971, TYPE = "Memo", NUMBER = "CPT-88", MONTH = "January"}

@ARTICLE{Pasini:91,
 AUTHOR = "P. Pasini and F. Semeria and C. Zannoni",
 TITLE = "Symbolic computation of orientational correlation function
moments",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1991, VOLUME = 12, NUMBER = 2, PAGES = "221-231", MONTH = "August"}
 COMMENTS = {Symbolic manipulation (REDUCE and SCHOONSCHIP) has been
applied to the analytic evaluation of the coefficients in the Taylor series
expansion of time-correlation functions.  These expressions are derived
for cylindrically and biaxially symmetric particles reorienting in a
uniaxial fluid.  The possibility of using computer algebra to determine
correlation-function moments should make it applicable to various problems
in statistical physics.}}

@ARTICLE{Pattnaik:83,
 AUTHOR = "P. C. Pattnaik and G. Fletcher and J. L. Fry",
 TITLE = "Improved Numerical Stability for Norm-Conserving ion-{Ure}
Pseudopotentials",
 JOURNAL = "Phys. Rev. B",
 YEAR = 1983, VOLUME = 28, NUMBER = 6, PAGES = "3364-3365",
 COMMENT = {{REDUCE} and {FORTRAN}; inverting a matrix algebraically would
be more accurate than a numerical inverse, and used {REDUCE} for this part of
their work.}}

@ARTICLE{Pearce:81,
 AUTHOR = "P. D. Pearce and R. J. Hicks",
 TITLE = "The Application of Algebraic Optimisation Techniques to
Algebraic Mode Programs for {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1981, VOLUME = 15, NUMBER = 4, PAGES = "15-22",
 MONTH = "November"}

@ARTICLE{Pearce:83,
 AUTHOR = "P. D. Pearce and R. J. Hicks",
 TITLE = "Data Structures and Execution Times of Algebraic Mode
Programs for {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "31-37", MONTH = "February"}

@ARTICLE{Perjes:84,
 AUTHOR = "Z. Perj{\'e}s",
 TITLE = "Stationary Vacuum Fields with a Conformally Flat
Three-Space.  {III}. {Complete} Solution",
 JOURNAL = "General Relativity and Gravitation",
 YEAR = 1984, VOLUME = 18, PAGES = "531-547",
 COMMENT = {{REDUCE} used to perform the necessary calculations.}}

@ARTICLE{Perjes:84a,
 AUTHOR = "Z. Perj{\'e}s and B. Luk{\'a}cs and A. Sebesty{\'e}n
and A. Valentini",
 TITLE = "Solution of the Stationary Vacuum Equations of
Relativity for Conformally Flat 3-Spaces",
 JOURNAL = "Phys. Lett.",
 YEAR = 1984, VOLUME = {100A}, NUMBER = 8, PAGES = "405-406",
 MONTH = "February"}

@TECHREPORT{Perjes:84b,
 AUTHOR = "Z. Perj{\'e}s",
 TITLE = "Improved Characterization of the {Kerr} Metric",
 INSTITUTION = "Hungarian Academy of Sciences, Central
Research Institute for Physics",
 YEAR = 1984, NUMBER = "KFKI-1984-115"}

@TECHREPORT{Perjes:84c,
 AUTHOR = "Z. Perj{\'e}s",
 TITLE= "Stationary Vacuum Fields with a Conformally Flat Three-Space.
{IV}. {Complete} Solution",
 INSTITUTE = "Institute for Nuclear Study, University of Tokyo",
 YEAR = 1984,  NUMBER = "INS-REP.-487", MONTH = "January"}

@TECHREPORT{Perjes:86,
 AUTHOR = "Z. Perj{\'e}s",
 TITLE = "Ernst Coordinates",
 INSTITUTION = "Hungarian Academy of Sciences, Central
Research Institute for Physics",
 YEAR = 1986, TYPE = "Preprint", NUMBER = "KFKI-1986-33/B"} ,

@ARTICLE{Perjes:86a,
 AUTHOR = "Z. Perj{\'e}s",
 TITLE = "Stationary Vacuum Fields with a Conformally
Flat Three-Space.  {II}. {Proof} of Axial Symmetry",
 JOURNAL = "General Relativity and Gravitation",
 YEAR = 1986, VOLUME = 18, NUMBER = 5, PAGES = "511-530",
 MONTH = "May"}

@ARTICLE{Perjes:88,
 AUTHOR = "Z. Perj{\'e}s",
 TITLE  = "Approaches to  Axisymmetry by  Man and  Machine",
 BOOK = "Relativity Today",
 YEAR = 1988, EDITOR = "Z. Perjes", PUBLISHER = "World Scientific,
 Singapore"}

@ARTICLE{Perlt:90,
 AUTHOR = "H. Perlt and J. Ranft and J. Heinrich",
 TITLE = "Calculation of {QED} graphs with the {Spinor} technique",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1990, VOLUME = 56, NUMBER = 3, PAGES = "385-390", MONTH = "January"}

@TECHREPORT{Perrottet:78,
 AUTHOR = "M. Perrottet",
 TITLE = "Signature for {W} Boson Production From Jet Analysis
In e+e- $\rightarrow$ {W+W-} $\rightarrow$ Hadrons",
 INSTITUTION = "CPT 2, CNRS, Marseille", YEAR = 1978,
 TYPE = "Preprint", NUMBER = "78/P.1019", MONTH = "June",
 ABSTRACT = {We have computed the ratio
o(e+e- $\rightarrow$ W+W- $\rightarrow$ Hadrons)/ o(e+e- $\rightarrow$
G,Z $\rightarrow$ Hadrons) as a function of the {CM} energy in the
Weinberg-Salam model.}}

@TECHREPORT{Pesic:73,
 AUTHOR = "P. D. Pesic",
 TITLE = "Two-Photon Cross Section for {W}-Pair Production
by Colliding Beams",
 INSTITUTION = "Stanford University", YEAR = 1973, TYPE = "Report",
NUMBER = "SLAC-PUB-1188",
 COMMENT = {Stanford University Linear Accelerator Report.}}

@PHDTHESIS{Pictiaw:69,
 AUTHOR = "Chen Pictiaw",
 TITLE = "An Analytical Investigation of Infinitesimal Spatial
Motion Theory and its Application to Three-Dimensional Linkages",
 SCHOOL = "Dept. of Mech. Eng., Stanford University",
 YEAR = 1969, MONTH = "March"}

@ARTICLE{Piessens:84,
 AUTHOR = "R. Piessens",
 TITLE = "A Series Expansion for the First Positive Zero of the {Bessel}
Function",
 JOURNAL = "Math. Comp.",
 YEAR = 1984, VOLUME = 42, PAGES = "195-197",
 COMMENT = {Gives explicit series for first positive zero for 4 terms, using
{REDUCE}.}}

@ARTICLE{Piessens:86,
 AUTHOR = "R. Piessens and S. Ahmed",
 TITLE = "Note on Approximation for the Turning Points of {Bessel}
Functions",
 JOURNAL = "J. Comp. Phys.",
 YEAR = 1986, VOLUME = 64, PAGES = "253-257",
 COMMENT = {{REDUCE} used to differentiate and give expansions.}}

@ARTICLE{Pignataro:85,
 AUTHOR = "M. Pignataro and A. Luongo and N. Rizzi",
 TITLE = "On the Effect of the Local Overall Interaction on the
Postbuckling of Uniformly Compressed Channels",
 JOURNAL = "Thin-Walled Structures",
 YEAR = 1985, VOLUME = 3, PAGES = "292-321",
 COMMENT = {{REDUCE} generating {FORTRAN}, but also used to investigate the
form of the solutions.}}

@MASTERSTHESIS{Podgorzak:84,
 AUTHOR = "E. Podg{\'o}rak and I. Romanowska",
 TITLE = "Application of {REDUCE} 2 to the Construction of
Recurrence Relations",
 SCHOOL = "Institute of Computer Science, University of Wroclaw",
 YEAR = "1984"}

@ARTICLE{Price:84,
 AUTHOR = "S. L. Price and A. J. Stone and M. Alderton",
 TITLE = "Explicit Formulae for the Electrostatic Energy, Forces and
Torques Between a Pair of Molecules of Arbitrary Symmetry",
 JOURNAL = "Molecular Phys.",
 YEAR = 1984, VOLUME = 52, PAGES = "987-1001",
 COMMENT = {"The substitution of the complex multipoles and the S
functions into the expression for the electrostatic energy was
facilitated by the use of the symbolic algebraic manipulation program
{REDUCE}."  Involves heavy calculations.}}

@TECHREPORT{Quarton,
 AUTHOR = "D. C. Quarton and A. D. Garrad",
 TITLE = "Some Comments on the Stability Analysis of Horizontal
Axis Wind Turbines",
 INSTITUTION = "Wind Energy Group, Taylor Woodrow Construction Ltd."}

@TECHREPORT{Quarton:84,
 AUTHOR = "D. C. Quarton and A. D. Garrad",
 TITLE = "Symbolic Computing as a Tool in Wind Turbine Dynamics",
 INSTITUTION = "Wind Energy Group, Taylor Woodrow Construction Ltd.",
 YEAR = 1984,
 COMMENT = {Presented at the European Wind Energy Conference and Exhibition
22-26 Oct 1984, Hamburg.}}

@MASTERSTHESIS{Rao:85,
 AUTHOR = "R. H. Rao",
 TITLE = "Deformation of a Fluid-Filled Cylindrical Membrane by a
Slow Viscous Shear Flow",
 SCHOOL = "Washington University",
 ADDRESS = "Dept. of Mech. Eng., Washington University, St. Louis",
 YEAR = "1985",
 COMMENT = {Draws attention to the use of classical perturbation
techniques combined with computer algebra as an alternative to
numerical calculation.}}

@BOOK{Rayna:87,
 AUTHOR = "G. Rayna",
 TITLE = "{REDUCE}:  A System for Computer Algebra",
 PUBLISHER = "Springer-Verlag",
 YEAR = 1987}

@INPROCEEDINGS{Renner:91,
 AUTHOR = "Friedrich Renner",
 TITLE = "Nonlinear Evolution Equations and the {Painlev{\'e}} Analysis:
A constructive Approach with {REDUCE}",
 YEAR = 1991, MONTH = "July",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland",
 PAGES = "289-294",
 ABSTRACT = {A number of necessary conditions for a class of nonlinear
partial differential equations to pass the Painlev{\'e} test with the
Kruskal ansatz is given.  Using these we can (theoretically) construct all
evolution equations of certain form and this property with a computer algebra
package based on {REDUCE}.}}

@ARTICLE{Reusch:86,
 AUTHOR = "M. F. Reusch and G. H. Neilson",
 TITLE = "Torodially Symmetric Polynomial Multipole Solutions
of the Vector {Laplace} Equation",
 JOURNAL = "J. Comp. Phys.",
 YEAR = 1986, VOLUME = 64, PAGES = "416-432",
 COMMENT = {{REDUCE} (plasma MHD) algebraic form of multipoles, then
numerical.}}

@PHDTHESIS{Rink:71,
 AUTHOR = "R. A. Rink",
 TITLE = "Application of a Digital Computer to Solve Analytically
Special Classes of Linear and Nonlinear Differential Equations",
 SCHOOL = "Stanford University",
 YEAR = 1971}

@ARTICLE{Rizzi:85,
 AUTHOR = "N. Rizzi and A. Tatone",
 TITLE = "Symbolic Manipulation in Buckling and Postbuckling Analysis",
 JOURNAL = "Computers and Structures",
 YEAR = 1985, VOLUME = 21, PAGES = "691-700",
 COMMENT = {Gives {REDUCE} program and output for generating {FORTRAN}.}}

@ARTICLE{Rodionov:84,
 AUTHOR = "A. Ya. Rodionov",
 TITLE = "Work with {non-commutative} variables in the {REDUCE-2}
system for analytical calculations",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1984, VOLUME = 18, NUMBER = 3, PAGES = "16-19", MONTH = "August"}

@ARTICLE{Rodionov:87,
 AUTHOR = "A. Ya. Rodionov and A. Yu. Taranov",
 TITLE = "Computation of Covariant Derivatives of the Geodetic
Interval within the Coincident Arguments",
 JOURNAL = "Class. Quantum Grav.",
 YEAR = 1987, VOLUME = 4, PAGES = "1767-1775",
 COMMENT = {Used {REDUCE} to calculate the geodetic interval of the
Riemannian manifold by calculating the multiple covariant derivatives of
orders 7 and 8.  Direct use of {REDUCE} was not sufficient, but some
investigations of the structure of the problem produced some
recurrence relations.}}

@INPROCEEDINGS{Rodionov:87a,
 AUTHOR = "A. Ya. Rodionov and A. Yu. Taranov",
 TITLE = "Combinatorial Aspects of Simplification of Algebraic Expressions",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "192-201",
 PUBLISHER = "Springer-Verlag"}

@TECHREPORT{Rodionov:88,
 AUTHOR = "A. Ya. Rodionov and A. Yu. Taranov",
 TITLE = "{RTENSOR - Packet} for work with tensoric expressions",
 INSTITUTION = "Moscow State University, Scientific Research Institute
of Nuclear Physics", YEAR = 1988, TYPE = "Preprint", NUMBER = "88-29/50"}

@INPROCEEDINGS{Roelofs:91,
 AUTHOR = "Marcel Roelofs and Peter K.H. Gragert",
 TITLE = "Implementation of multilinear operators in {REDUCE} and
applications in mathematics",
 YEAR = 1991, MONTH = "July",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland",
 PAGES = "390-396",
 ABSTRACT = {In this paper we introduce and implement a concept for dealing
with mathematical bases of linear spaces and mappings (multi)linear with
respect to such bases, in {REDUCE}.  Using this concept we give some
examples how to implement some well known (multi)linear mappings in
mathematics with very little effort.  Moreover we implement a procedure
operatorcoeff similar to the standard {REDUCE} procedure coeff, but now
for linear spaces instead of polynomial rings.}}

@BOOK{Rogers:89,
 AUTHOR = "C. Rogers and W. F. Ames",
 TITLE = "Nonlinear Boundary Value Problems in Science and Engineering",
 PUBLISHER = "Academic Press, Inc.",
 YEAR = 1989}

@ARTICLE{Roque:88,
 AUTHOR = "Waldir L. Roque and Renato P. dos Santos",
 TITLE = "Computa\c{c}\~{a}o alg\'{e}brica: ``um assistente matem\~{a}tico''",
 JOURNAL = "Ci\^{e}ncia e Cultura",
 YEAR = 1988, VOLUME = 40, NUMBER = 9, PAGES = "843-852", MONTH =
"September",
 ABSTRACT = {In this paper we discuss in a simple and
informative way the theme ``algebraic computing'' in an attempt to encourage
the Brasilian scientific community to make use of this new tool{\ldots}. Many
algebraic computing systems have been developed in a variety of research
fields. Some of these systems, their main characteristics and applications
will be discussed.},
 COMMENT = {In Portuguese}}

@ARTICLE{Roque:91,
 AUTHOR = "Waldir L. Roque and Renato P. dos Santos",
 TITLE = "Computer algebra in spacetime embedding",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1991, VOLUME = 12, NUMBER = 3, PAGES = "381-389", MONTH =
"September",
 ABSTRACT = {In this paper we describe an algorithm to determine the vectors
normal to a space-time ${V}_{4}$ embedded in a pseudo-Euclidean manifold
${M}_{4+N}$.  An application of this algorithm is given considering the
Schwarzchild spacetime geometry embedded in a 6 dimensional pseudo-Euclidean
manifold, using the algebraic computing system REDUCE.}}

@ARTICLE{Ronveaux:88,
 AUTHOR = "A. Ronveaux and G. Thiry",
 TITLE = "Polynomial Solution of Recurrence Relation and Differential
Equation",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1988, VOLUME = 22, NUMBER = 4, PAGES = "9-19", MONTH = "October"}

@ARTICLE{Ronveaux:89,
 AUTHOR = "A. Ronveaux and G. Thiry",
 TITLE = "Differential Equations of Some Orthogonal Families in {REDUCE}",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1989, VOLUME = 8, NUMBER = 5, PAGES = "537-541", MONTH = "November"}

@INPROCEEDINGS{Rudenko:91,
 AUTHOR = "V.M. Rudenko and V.V. Leonov and A.F. Bragazin and
I.P Shmyglevsky",
 TITLE = "Application of Computer Algebra to the Investigation of the
Orbital Satellite Motion",
 YEAR = 1991, MONTH = "July",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland",
 PAGES = "450-451"}

@ARTICLE{Saez:83,
 AUTHOR = "A. E. Saez and B. J. McCoy",
 TITLE = "Transient Analysis of Packed-Bed Thermal Storage Systems",
 JOURNAL = "Int. J. Heat Mass Transfer",
 YEAR = 1983, VOLUME = 26, NUMBER = 1, PAGES = "49-54"}

@ARTICLE{Sage:88,
 AUTHOR = "Martin L. Sage",
 TITLE = "An Algebraic Treatment of Quantum Vibrations",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1988, VOLUME = 5, NUMBER = 3, PAGES = "377-384", MONTH = "June"}

@TECHREPORT{Sarlet:91,
 AUTHOR = "W. Sarlet and J. Vanden Bonne",
 TITLE = "{REDUCE-} procedures for the study of adjoint symmetries of
second-order differential equations",
 INSTITUTION = "University of Gent, Cage Computer Algebra Group",
 NUMBER = 7, YEAR = 1991, TYPE = "Preprint"}

@INPROCEEDINGS{Sasaki:79,
 AUTHOR = "Tateaki Sasaki",
 TITLE = "An Arbitrary Precision Real Arithmetic Package in {REDUCE}",
 BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes
in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "358-368",
 PUBLISHER = "Springer-Verlag",
 ABSTRACT = {A {REDUCE} arbitrary precision real arithmetic package is
described which will become a part of the kernel of an algebraic-numeric
system being developed for {REDUCE}.}}

@ARTICLE{Savage:90,
 AUTHOR = "Stuart B. Savage",
 TITLE = "Symbolic computation of the flow of granular avalanches",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1990, VOLUME = 9, NUMBER = 4, PAGES = "515-530", MONTH = "April"}

@ARTICLE{Sayers:87,
 AUTHOR = "C. M. Sayers",
 TITLE = "The Elastic Anisotropy of Polycrystalline Aggregates
of Zirconium and Its Alloys",
 JOURNAL = "J. Nuclear Materials",
 YEAR = 1987, VOLUME = 144, PAGES = "211-213",
 COMMENT = {Used {REDUCE} for calculations of tensor products.}}

@ARTICLE{Sayers:87a,
 AUTHOR = "C. M. Sayers",
 TITLE = "Elastic Wave Anisotropy in the Upper Mantle",
 JOURNAL = "Geophysical J. R. Ast. Soc.",
 YEAR = 1987, VOLUME = 88, PAGES = "417-424",
 COMMENT = {Used {REDUCE} in calculations.  "Theoretical expressions for
angular dependence of the longitudinal and shear wave velocities in an
axially symmetric aggregate{\ldots}"}}

@INPROCEEDINGS{Schlegel:91,
 AUTHOR = "H. Schlegel",
 TITLE = "Determination of the Root System of Semisimple {Lie} Algbras from
the {Dynkin} Diagram",
 YEAR = 1991, MONTH = "July",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland",
 PAGES = "239-240"}

@INPROCEEDINGS{Schmuck:77,
 AUTHOR = "P. Schmuck",
 TITLE = "Verification of the Transient, Two Phase Fluid
Flow Program {Kachina} using Computerized Similarity Analysis",
 YEAR = 1977, MONTH = "October",
 BOOKTITLE = "Second {GAMM} Conference on Numerical Methods
in Fluid Mechanics, k{\"o}ln"}

@TECHREPORT{Schoepf:91,
 AUTHOR = "Rainer Sch{\"o}pf and Peter Deuflhard",
 TITLE = "{OCCAL} A mixed symbolic-numeric Optimal Control {CALculator}",
 INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin",
 YEAR = 1991, TYPE = "Preprint", NUMBER = "SC 91-13", MONTH = "December",
 ABSTRACT = {The numerical solution of optimal control problems by indirect
methods (such as multiple shooting or collocation) requires a considerable
amount of analytic calculation to establish a numerically tractable system.
These analytic calculations, though being rather tedious in realistic
examples, are nowadays mostly still done by hand--and thus prone to
calculation errors.  The paper aims at automating this analytic processing
to a reasonable extent by means of a modern symbolic manipulation language
(here:  REDUCE).  In its present stage of development the package OCCAL
(mnemotechnically for Optimal Control CALculator) permits an interactive
use, covering tasks like automatic determination of control and, in case of a
singular control, of its order.  In simpler problems, the present version of
OCCAL automatically produces the full subroutine input for a MULtiple
shooting code (MULCON) with adaptive numerical CONtinuation.

In more complicated problems where singular sub-arcs may occur or where the
sequence of sub-arcs of the optimal trajectory is unclear OCCAL is a
significant help in reducing analytic pre-processing.  Examples illustrate
the performance of OCCAL/MULCON.}}

@ARTICLE{Schruefer:81,
 AUTHOR = "E. Schr{\"u}fer and H. Heintzmann",
 TITLE = "Lorentz-Covariant Eikonal Method in Magnetohydrodynamics
{II} - The Determination of the Wave Amplitude",
 JOURNAL = "Phys. Lett.",
 YEAR = 1981, VOLUME = {81A}, NUMBER = 9, PAGES = "501-506",
 MONTH = "February",
 COMMENT = {Used {REDUCE} for "rather tedious algebra."}}

@ARTICLE{Schruefer:82,
 AUTHOR = "E. Schr{\"u}fer",
 TITLE = "An Implementation of the Exterior Calculus in {REDUCE:}
A Status Report",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1982, VOLUME = 16, NUMBER = 4, PAGES = "27-31", MONTH = "November"}

@ARTICLE{Schruefer:87,
 AUTHOR = "E. Schr{\"u}fer and F. W. Hehl and J. D. McCrea",
 TITLE = "Exterior Calculus on the Computer:  The {REDUCE}-Package
{EXCALC} Applied to General Relativity and to the {Poincar{\'e}}
Gauge Theory",
 JOURNAL = "General Relativity and Gravitation",
 YEAR = 1987, VOLUME = 19, NUMBER = 2, PAGES = "197-218",
 MONTH = "February",
 COMMENT = {Application of {EXCALC/REDUCE}, including review of other
systems, and description of {EXCALC}.}}

@ARTICLE{Schruefer:88,
 AUTHOR = "E. Schr{\"u}fer",
 TITLE = "A Note on {Einstein} Metrics",
 JOURNAL = "SIGSAM Bulletin",
 YEAR = 1988, VOLUME = 22, NUMBER = 3, PAGES = "22-26", MONTH = "July"}

@ARTICLE{Schwarz:80,
 AUTHOR = "F. Schwarz",
 TITLE = "An Approximation Scheme for Constructing $\pi_{0}\pi$
Amplitudes from {ACU} Requirements",
 JOURNAL = "Fortschritte der Physik",
 YEAR = 1980, VOLUME = 28, PAGES = "201-235",
 COMMENT = {"To derive the equations expressing the threshold and the
asymptotic behaviour one relies heavily on the programming system
{REDUCE}."}}

@ARTICLE{Schwarz:82,
 AUTHOR = "F. Schwarz",
 TITLE = "Symmetries of the Two Dimensional {Korteweg-De Vries} Equation",
 JOURNAL = "J. Phys. S. Japan",
 YEAR = 1982, VOLUME = 51, NUMBER = 8, PAGES = "2387-2388",
 COMMENT = {{REDUCE} used in the {SPDE} package.}}

@ARTICLE{Schwarz:82a,
 AUTHOR = "F. Schwarz",
 TITLE = "A {REDUCE} Package for Determining {Lie} Symmetries of
Ordinary and Partial Differential Equations",
 JOURNAL = "Computer Physics Communications",
 YEAR = 1982,  VOLUME = 27, PAGES = "179-186",
 COMMENT = {Preliminary description of {REDUCE} packages {SODE} and
{SPDE}.}}

@ARTICLE{Schwarz:83,
 AUTHOR = "Fritz Schwarz",
 TITLE = "A {REDUCE} Package for Series Analysis by {Hadamard's}
Theorem and {QD} Schemes",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1983, VOLUME = 17, NUMBER = 1, PAGES = "38-44", MONTH = "February"}

@INPROCEEDINGS{Schwarz:83a,
 AUTHOR = "Fritz Schwarz",
 TITLE = "Automatically Determining Symmetries of Ordinary Differential
Equations",
 BOOKTITLE = "Proc. {EUROCAL} 1983, Lecture Notes
in Computer Science", YEAR = 1983, VOLUME = 162, PAGES = "45-54",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Schwarz:84,
 AUTHOR = "F. Schwarz",
 TITLE = "The {Riquier-Janet} Theory and Its Application to Nonlinear
Evolution Equations",
 JOURNAL = "Physica",
 YEAR = 1984, VOLUME = "11D", PAGES = "243-251",
 COMMENT = {Prologation methods in {REDUCE}.  Points to existence of
{REDUCE} system.}}

@ARTICLE{Schwarz:84a,
 AUTHOR = "F. Schwarz and W. H. Steeb",
 TITLE = "Symmetries and First Integrals for Dissipative Systems",
 JOURNAL = "J. Phys. {A:}  Math. Gen.",
 YEAR = 1984, VOLUME = 17, PAGES = "L819-L823"}

@ARTICLE{Schwarz:85,
 AUTHOR = "F. Schwarz",
 TITLE = "Automatically Determining Symmetries of Partial Differential
Equations",
 JOURNAL = "Computing",
 YEAR = 1985, VOLUME = 34, PAGES = "91-106",
 COMMENT = {Describes the {SPDE} package for {REDUCE}.}}

@ARTICLE{Schwarz:85a,
 AUTHOR = "Fritz Schwarz",
 TITLE = "An Algorithm for Determining Polynomial First Integrals of
Autonomous Systems of Ordinary Differential Equations",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1985, VOLUME = 1, NUMBER = 2, PAGES = "229-233", MONTH = "June"}

@ARTICLE{Schwarz:86,
 AUTHOR = "F. Schwarz",
 TITLE = "A {REDUCE} Package for Determining First Integrals of
Autonomous Systems of Ordinary Differential Equations",
 JOURNAL = "Computer Physics Communications",
 YEAR = 1986, VOLUME = 39, PAGES = "285-296",
 COMMENT = {Description of package {DISSYS} in {REDUCE}.}}

@INPROCEEDINGS{Schwarz:87,
 AUTHOR = "F. Schwarz",
 TITLE = "Symmetries and Involution Systems: Some Experiments in
Computer Algebra",
 YEAR = 1987, MONTH = "August",
 BOOKTITLE = "Topics in Soliton Theory and Exactly Solvable Nonlinear
Equations", PUBLISHER = "World Science Press", ADDRESS = "Singapore",
 COMMENT = {Description of algorithm {INVSYS} and applications.}}

@ARTICLE{Schwarz:88,
 AUTHOR = "F. Schwarz",
 TITLE = "Symmetries of Differential Equations: From {Sophus Lie} to
Computer Algebra",
 JOURNAL = "Siam Review",
 YEAR = 1988, VOLUME = 30, PAGES = "450-481",
 COMMENT = {Review article on applying the {REDUCE} package {SPDE}.}}

@ARTICLE{Seiler:91,
 AUTHOR = "Werner M. Seiler",
 TITLE = "{SUPERCALC-} a {REDUCE} package for commutator calculations",
 JOURNAL = "Computer Physics Communications",
 YEAR = 1991, VOLUME = 66, PAGES = "363-376",
 COMMENT = {A {REDUCE} package for commutator calculations in sypersymmetric
theories (including ordered products) and for infinite sums is presented
and an application to the computation of anomalies in string theory is
given.}}

@INPROCEEDINGS{Shablygin:87,
 AUTHOR = "E. Shablygin",
 TITLE = "Integral Equation with Hidden Eigenparameter Solver:
{REDUCE} and {FORTRAN} in Tandem",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "186-191",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Shmueli:83,
 AUTHOR = "U. Shmueli and A. J. C. Wilson",
 TITLE = "Generalized Intensity Studies:  The Subcentric Distribution
and Effects of Dispersion",
 JOURNAL = "Acta Cryst.",
 YEAR = 1983, VOLUME = "A39", PAGES = "225-233",
 COMMENT = {Uses {REDUCE} for series expansion to high order as convergence
is slow.}}

@ARTICLE{Shmueli:83a,
 AUTHOR = "U. Shmueli and U. Kaldor",
 TITLE = "Moments of the Trigonometric Structure Factor",
 JOURNAL = "Acta Cryst.",
 YEAR = 1983, VOLUME = "A39", PAGES = "615-621",
 COMMENT = {Eight moment of magnitude of trigonometric structure factor.
Used {REDUCE}.  Description of {REDUCE} in appendix.}}

@TECHREPORT{Shtokhamer:75,
 AUTHOR = "R. Shtokhamer",
 TITLE = "Canonical Form of Polynomials in the Presence of
Side Relations",
 INSTITUTION = "Technion",
 YEAR = 1975, NUMBER = "Technion-PH-76-25"}

@TECHREPORT{Shtokhamer:77,
 AUTHOR = "R. Shtokhamer",
 TITLE = "The Use of {``LET''} Statements in Producing Short
Comprehended Outputs",
 INSTITUTION = "Department of Physics, Technion-Israel
Institute of Technology, Haifa, Israel",
 YEAR = 1977, NUMBER = "Technion-PH-77-36",
 ABSTRACT = {It is shown that an algebraic implementation of {"LET"}
statements may be useful in producing comprehended outputs.
The suggested algorithm is based on solving large set of
linear equations over a field.}}

@INPROCEEDINGS{Smit:79,
 AUTHOR = "J. Smit",
 TITLE = "New Recursive Minor Expansion Algorithms, A Presentation in
a Comparative Context",
 BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes
in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "74-87",
PUBLISHER = "Springer-Verlag"}

@ARTICLE{Smit:81,
 AUTHOR = "J. Smit and J. A. van Hulzen and B. J. A. Hulshof",
 TITLE = "{NETFORM} and Code Optimizer Manual",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1981, VOLUME = 15, NUMBER = 4, PAGES = "23-32",
 MONTH = "November"}

@INPROCEEDINGS{Smit:82,
 AUTHOR = "J. Smit and J. A. van Hulzen",
 TITLE = "Symbolic Numeric Methods in Microwave Technology",
 BOOKTITLE = "Proc. {EUROCAM} 1982, Lecture Notes
in Computer Science", YEAR = 1982, VOLUME = 144, PAGES = "281-288",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{Smit:87,
 AUTHOR = "J. Smit and S. H Gerez and R. Mulder",
 TITLE = "Application of a Structured {LISP} System to Computer Algebra",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "149-160",
 PUBLISHER = "Springer-Verlag"}

@TECHREPORT{Soderstrand:72,
 AUTHOR = "M. A. Soderstrand and D. C. Huey",
 TITLE = "Sensitivities of Fourth-Order Filters Obtained by a
Low-Pass to Band-Pass Transformation",
 INSTITUTION = "University of California, Davis",
 YEAR = 1972, TYPE = "Report"}

@INPROCEEDINGS{Soderstrand:72a,
 AUTHOR = "M. A. Soderstrand and S. K. Mitra",
 TITLE = "Computer-aided Sensitivity Analysis of Higher Filters",
 YEAR = 1972, MONTH = "July",
 BOOKTITLE = "Proc. Second Symposium on Network Theory,
Herzegnovia, Yugoslavia"}

@TECHREPORT{Soderstrand:74,
 AUTHOR = "M. A. Soderstrand and J. F. Lathrop",
 TITLE = "Two Computer Programs for the Sensitivity Analysis
of Higher Order Filters",
 INSTITUTION = "Sandia Laboratories", YEAR = 1974,
 TYPE = "Report", NUMBER = "SLL-73-0225", MONTH = "January"}

@ARTICLE{Soma:77,
 AUTHOR = "T. Soma",
 TITLE = "Relativistic Aberration Formulas for Combined
Electric-Magnetic Focusing-Deflection System",
 JOURNAL = "Optik",
 YEAR = 1977, VOLUME = 49, PAGES = "255-262",
 COMMENT = {Existence of a vertical landing electron beam deflecting
system free of all deflection induced aberrations is
presented analytically.}}

@INPROCEEDINGS{Soma:85,
 AUTHOR = "Takashi Soma",
 TITLE = "Recent Applications of {REDUCE} in {RIKEN}",
 YEAR = 1985,
 BOOKTITLE = "Proc. of the Second {RIKEN} International
Symposium on Symbolic and Algebraic Computation by Computers",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "181-182"}

@INPROCEEDINGS{Spiridonova:87,
 AUTHOR = "M. Spiridonova",
 TITLE = "Some extensions and Applications of {REDUCE} System",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "136-137",
 PUBLISHER = "Springer-Verlag"}

@TECHREPORT{Squire,
 AUTHOR = "W. Squire",
 TITLE = "Some Applications of Symbolic Matrix Inversion",
 INSTITUTION = "Dept. of Mechanical and Aerospace Engineering,
West Virginia University"}

@ARTICLE{Steinberg:82,
 AUTHOR = "Stanly Steinberg",
 TITLE = "Mathematics and Symbol Manipulation",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1982, VOLUME = 16, NUMBER = 3, PAGES = "11-15", MONTH = "August"}

@ARTICLE{Steuerwald,
 AUTHOR = "J. Steuerwald and W. Kerner",
 TITLE = "A Contribution to the Efficient Solution of
Extensive Symbolic Computations",
 JOURNAL = "Comp. Phys. Comm."}

@ARTICLE{Stoutemyer:74,
 AUTHOR = "D. Stoutemyer",
 TITLE = "Automatic Error Analysis Using the Computer Symbolic
Manipulation Language",
 JOURNAL = "TOMS 3",
 YEAR = 1977, VOLUME = 3, NUMBER = 1, PAGES = "26-43",
 MONTH = "March",
 ABSTRACT = {This paper shows how the inherent error and the fixed-point
or floating-point roundoff of chopoff error of an expression can be
determined automatically using a computer algebra language such as
{REDUCE}.}}

@TECHREPORT{Stoutemyer:75,
 AUTHOR = "David R. Stoutemyer",
 TITLE = "Symbolic Computer Solution of an Equation in Finite Terms",
 INSTITUTION = "Dept. of Comp. Science, Univ. of Utah",
 TYPE = "Report", YEAR = 1975, NUMBER = "UCP-33",
 ABSTRACT = {This report contains a program listing together with
documentation, a demonstration, and discussion of a {REDUCE} program for the
exact solution of an equation in finite terms.  Capable of treating certain
equations involving elementary transcendental functions, radicals,
and polynomials, the program incorporates several solution techniques
not implemented in existing analogous programs written in other
computer algebra languages.  The program is also capable of solving
linear or linear fractional in the unknowns.  In this case it simply
used the built-in matrix equation solver, but permitting input as
lists of expressions rather than matrices, which is convenient for
sparse or small linear systems.}}

@ARTICLE{Stoutemyer:77,
 AUTHOR = "David R. Stoutemyer",
 TITLE = "Analytically Solving Integral Equations by Using Computer
Algebra",
 JOURNAL = "TOMS",
 YEAR = 1977, VOLUME = 3, NUMBER = 2, PAGES = "128-146",
 MONTH = "June",
 ABSTRACT = {This report describes how a computer algebra language, such as
{REDUCE}, may be used to automatically construct closed-form and series
analytical solutions of integral equations.}}

@ARTICLE{Stroscio:74,
 AUTHOR = "M. A. Stroscio and J. M. Holt",
 TITLE = "Radiative Corrections to the Decay Rate of Orthopositronium",
 JOURNAL = "Phys. Rev. A",
 YEAR = 1974, MONTH = "September", VOLUME = 10, PAGES = "749-755"}

@ARTICLE{Stuart:88,
 AUTHOR = "Robin G. Stuart",
 TITLE = "Algebraic Reduction of one-loop {Feynman} Diagrams to
Scalar Integrals",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1988, VOLUME = 48, NUMBER = 3, PAGES = "367-389", MONTH = "March"}

@ARTICLE{Stuart:90,
 AUTHOR = "Robin G. Stuart and A. G{\'o}ngora-T",
 TITLE = "Algebraic Reduction of one-loop {Feynman} Diagrams to
Scalar Integrals II",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1990, VOLUME = 56, NUMBER = 3, PAGES = "337-350", MONTH = "January"}

@ARTICLE{Suppes:89,
 AUTHOR = "Patrick Suppes and Shuzo Takahashi",
 TITLE = "An Interactive Calculus Theorem-prover for Continuity
Properties",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1989, VOLUME = 7, NUMBER = 6, PAGES = "573-590", MONTH = "June"}

@ARTICLE{Surguladze:89,
 AUTHOR = "L.R. Surguladze and F.V. Tkachov",
 TITLE = "{LOOPS:} Procedures for Multiloop Calculations in Quantum Field
Theory for the {REDUCE} System",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1989, VOLUME = 55, NUMBER = 2, PAGES = "205-215",
 MONTH = "September", PUBLISHER = "North Holland Publishing Company"}

@INPROCEEDINGS{Surguladze:91,
 AUTHOR = "Levan R. Surguladze and Mark A. Samuel",
 TITLE = "Algebraic Perturbative Calculations in High Energy Physics
Methods, algorithms, computer programs and physical applications",
 YEAR = 1991, MONTH = "July",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland",
 PAGES = "439-447",
 ABSTRACT = {The methods and algorithms for high order algebraic
perturbative calculations in theoretical high energy physics are briefly
reviewed.  The {SCHOONSCHIP} program {MINCER} and the {REDUCE} program
{LOOPS} for analytical computation of arbitrary massless, one-, two-
and three-loop Feynman diagrams of the propagator type are described.
The version of the program {LOOPS} for personal computers and the extended
version of the program {MINCER} for four-loop renormalization group
calculations are presented.  The new program for algebraic perturbative
calculations is also discussed.  This program is written on the new
algebraic programming system {FORM}.  Some recent results of application
to the high energy physics are given.}}

@ARTICLE{Tallents:84,
 AUTHOR = "G. J. Tallents",
 TITLE = "The Relative Intensities of Hydrogen-Like Fine Structure",
 JOURNAL = "J. Phys. B",
 YEAR = 1984, VOLUME = 17, PAGES = "3677-3691",
 COMMENT = {{REDUCE} used to check a formula; also checked numerically.}}

@InProceedings{Tao90,
  author =      "Qingsheng Tao",
  title =       "Symbolic and Algebraic manipulation for Formulae of
                 Interpolation and Quadrature",
  booktitle =   "Proceedings of the 1990 International Symposium on
                 Symbolic and Algebraic Computation",
  year =        "1990",
  editor =      "S. Watanabe and Morio Nagata",
  pages =       "306",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@TECHREPORT{Tasso:76,
 AUTHOR = "H. Tasso and J. Steuerwald",
 TITLE = "Subroutine for Series Solutions of Linear Differential Equations",
 INSTITUTION = "Max Planck Institut for Plasmaphysik",
 YEAR = 1976, NUMBER = "IPP 6/143"}

@TECHREPORT{Thas:89,
 AUTHOR = "C. Thas",
 TITLE = "A collection of {REDUCE} and {MACSYMA} programs about college
geometry.  Part 1",
 INSTITUTION = "State University of Gent",
 YEAR = 1989, NUMBER = 5, MONTH = "September"}

@TECHREPORT{Thas:89a,
 AUTHOR = "C. Thas",
 TITLE = "A collection of {REDUCE} and {MACSYMA} programs about college
geometry.  Part 2",
 INSTITUTION = "State University of Gent",
 YEAR = 1989, NUMBER = 5, MONTH = "September"}

@INPROCEEDINGS{Todd:88,
 AUTHOR = "P. H. Todd and G. W. Cherry",
 TITLE = "Symbolic Analysis of Planar Drawings",
 BOOKTITLE = "Proc. of {ISSAC} '88", PUBLISHER = "Springer-Verlag",
 YEAR = 1988, VOLUME = 358, PAGES = "344-355"}

@ARTICLE{Toth:86,
 AUTHOR = "{K. T{\'o}th and K. Szeg{\"o} and A. Margaritis}",
 TITLE =  "Radiative Corrections for Semileptonic Decays of {Hyperons:
`Model-Independent' Part}",
 JOURNAL = "Physical Review D", YEAR = 1986, VOLUME = 33, NUMBER = 11,
 PAGES = "3306-3315", MONTH ="June"}

@INPROCEEDINGS{Tournier:79,
 AUTHOR = "Evelyne Tournier",
 TITLE = "An Algebraic Form of a Solution of a System
of Linear Differential Equations with Constant Coefficients",
 BOOKTITLE = "Proc. {EUROSAM} 1979, Lecture Notes
in Computer Science", YEAR = 1979, VOLUME = 72, PAGES = "153-163",
 PUBLISHER = "Springer-Verlag",
 ABSTRACT = {In this paper we describe an algorithm for finding an
algebraic form for the solution of a system of linear differential
equations with constant coefficients, using the properties of elementary
divisors of a polynomial matrix.}}

@PHDTHESIS{Tournier:87,
 AUTHOR = "Evelyne Tournier",
 TITLE = "Solutions Formelles D'Equations Differentielles,
le Logiciel de Calcul Formel:  {DESIR} Etude Theorique
et Realisation",
 SCHOOL = "L'Universit{\'e} Scientifique, Technologique et
Medicale de Grenoble",
 YEAR = 1987, MONTH = "April"}

@INPROCEEDINGS{Trenkov:91,
 AUTHOR = "I. Trenkov and M. Spiridonova and M. Daskalova",
 TITLE = "An Application of the {REDUCE} System for Solving a Mathematical
Geodesy Problem",
 YEAR = 1991, MONTH = "July",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland",
 PAGES = "448-449"}

@INPROCEEDINGS{Trotter:89,
 AUTHOR = "H. F. Trotter",
 TITLE = "Use of Symbolic Methods in Analyzing an Integral Operator",
 BOOKTITLE = "Proc. of Computers and Mathematics '89",
 EDITOR = "E. Kaltofen and S. M. Watt",
 YEAR = 1989, PAGES = "82-90", PUBLISHER = "Springer-Verlag, New York"}

@ARTICLE{Tsai:65,
 AUTHOR = "Y. S. Tsai and A. C. Hearn",
 TITLE = "Differential Cross-Section for e+ + e- $\rightarrow$ {W+} +
{W-} $\rightarrow$ e- + $\overline{\nu}_{e} + \mu + \nu_{\mu}$",
 JOURNAL = "Phys. Rev.",
 YEAR = 1965, VOLUME = 140, PAGES = "B721-B729"}

@ARTICLE{Tsai:74,
 AUTHOR = "Y. S. Tsai",
 TITLE = "Pair Production and Bremsstrahlung of Charged Leptons",
 JOURNAL = "Rev. Mod. Phys.",
 YEAR = 1974, VOLUME = 46, PAGES = "815-851"}

@ARTICLE{Ucoluk:82,
 AUTHOR = "{G. \"{U}\c{c}oluk} and A. Hacinliyan",
 TITLE = "A Proposal for Extensions to {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1982, VOLUME = 16, NUMBER = 2, PAGES = "4-14", MONTH = "May",
 ABSTRACT = {Three classes of extensions are proposed for {REDUCE}:  A
facility  for evaluating arbitrary functions of matrices; a facility for
grouping, modifying or restoring the status of various flags
in {REDUCE}; further extensions and modifications for separating
terms, coefficients of expressions, concatenation, and non-
commuting algebra.}}

@ARTICLE{Umeno:89,
 AUTHOR = "Takaji Umeno and Syuichi Yamashita and Osami Saito and
Kenichi Abe",
 TITLE = "Symbolic Computation Application for the Design of Linear
Multivariable Control Systems",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1989, VOLUME = 8, NUMBER = 6, PAGES = "581-588", MONTH = "December"}

@INPROCEEDINGS{Urintsev:91,
 AUTHOR = "A.L. Urintsev and A.V. Samoilov",
 TITLE = "Complex Reduce-programs for analytic solution of some problems of
beam transport systems",
 YEAR = 1991,
 BOOKTITLE = "In:  4th International Conference on Computer Algebra in
Physical Research",
 EDITOR = "D.V. Shirkov and V.A. Rostovtsev and V.P. Gerdt",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore, New Jersey, London,
Hong Kong", PAGES = "438-442"}

@ARTICLE{vandenHeuvel:86,
 AUTHOR = "Pim van den Heuvel",
 TITLE = "Adding Statements to {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1986, VOLUME = 20, NUMBER = "1 and 2", PAGES = "8-14",
 MONTH = "February and May"}

@TECHREPORT{vandenHeuvel:86a,
 AUTHOR = "Pim van den Heuvel",
 TITLE = "Some Experiments in {REDUCE} Related to the
Calculation of {Groebner} Bases",
 INSTITUTION = "Department of Computer Science, Twente
University of Technology, The Netherlands",
 YEAR = 1986, MONTH = "June"}

@INPROCEEDINGS{vandenHeuvel:87,
 AUTHOR = "P. van den Heuvel and J. A. van Hulzen and V. V. Goldman",
 TITLE = "Automatic Generation of {FORTRAN}-Coded {Jacobians} and
{Hessians}",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "120-131",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{vandenHeuvel:87a,
 AUTHOR = "P. van den Heuvel and B. J. A. Hulshof and J. A. van Hulzen",
 TITLE = "Some Simple Pretty-Print Facilities for {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1987, VOLUME = 21, NUMBER = 1, PAGES = "14-17", MONTH = "February"}

@TECHREPORT{vanHeerwaarden,
 AUTHOR = "M. C. van Heerwaarden and J. A. van Hulzen",
 TITLE = "Pretty Print Facilities for {REDUCE}",
 INSTITUTION = "Department of Computer Science, University
of Twente, The Netherlands",
 YEAR = 1988, TYPE = "Memorandum",
 NUMBER = "INF-88-36", MONTH = "August"}

@ARTICLE{vanHulzen:80,
 AUTHOR = "J. A. van Hulzen",
 TITLE = "Computational Problems in Producing {Taylor} Coefficients
for the Rotating Disk Problem",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1980, VOLUME = 14, NUMBER = 2, PAGES = "36-49", MONTH = "May"}

@TECHREPORT{vanHulzen:81,
 AUTHOR = "J. A. van Hulzen",
 TITLE = "Breuer's Grow Factor Algorithm in Computer Algebra",
 INSTITUTION = "Department of Applied Mathematics, Twente University
of Technology, The Netherlands",
 YEAR = 1981, TYPE = "Memorandum", NUMBER = 332, MONTH = "April",
 COMMENT = {A shorter version appears in: Proceedings SYMSAC 81
 (Paul S. Wang, ed.) ACM, August 1981.}}

@ARTICLE{vanHulzen:82,
 AUTHOR = "J. A. van Hulzen and B. J. A. Hulshof",
 TITLE = "An Expression Analysis Package for {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1982, VOLUME = 16, NUMBER = 4, PAGES = "32-44", MONTH = "November"}

@INPROCEEDINGS{vanHulzen:82a,
 AUTHOR = "J. A. van Hulzen",
 TITLE = "Computer Algebra Systems Viewed by a Notorious User",
 BOOKTITLE = "Proc. {EUROCAM} 1982, Lecture Notes
in Computer Science", YEAR = 1982, VOLUME = 144, PAGES = "166-180"}

@INCOLLECTION{vanHulzen:83,
 AUTHOR = "J. A. van Hulzen and J. Calmet",
 TITLE = "Computer Algebra Systems",
 EDITOR = "B. Buchberger and G. E. Collins and R. Loos and R. Albrecht",
 BOOKTITLE = "Computer Algebra and Symbolic and Algebraic Computation",
 EDITION = "2nd", PUBLISHER = "Springer-Verlag", YEAR = 1983}

@INPROCEEDINGS{vanHulzen:83a,
 AUTHOR = "J. A. van Hulzen",
 TITLE = "Code Optimization of Multivariate Polynomial Schemes:  A
Pragmatic Approach",
 BOOKTITLE = "Proc. {EUROCAL} 1983, Lecture Notes
in Computer Science", YEAR = 1983, VOLUME = 162, PAGES = "286-300",
 PUBLISHER = "Springer-Verlag"}

@INPROCEEDINGS{vanHulzen:87,
 AUTHOR = "J. A. van Hulzen",
 TITLE = "Program Generation Aspects of the Symbolic-Numeric Interface",
 BOOKTITLE = "Proc. Third Intern. Conf. on Computer Algebra and its
applications in Theor. Phys, 1985", YEAR = 1987, PAGES = "104-113",
 PUBLISHER = "{J.I.N.R., Dubna, USSR}"}

@TECHREPORT{vanHulzen:88,
 AUTHOR = "J. A. van Hulzen",
 TITLE = "Formule Manipulatie m.b.v. {REDUCE} (in {Dutch})",
 INSTITUTION = "Department of Computer Science, Twente University
of Technology, The Netherlands",
 YEAR = 1988, MONTH = "October"}

@INPROCEEDINGS{vanHulzen:89,
 AUTHOR = "J. A. van Hulzen and B. J. A. Hulshof and B. L. Gates and
M. C. Van Heerwaarden",
 TITLE = "A Code Optimization Package for {REDUCE}",
 BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York",
 YEAR = 1989, PAGES = "163-170",
 COMMENT = {Lecture Notes.}}

@TECHREPORT{vanHulzen:89a,
 AUTHOR = "J. A. van Hulzen",
 TITLE = "Computer Algebra and Numerical Mathematics:  The Odd Couple?",
 INSTITUTION = "Department of Computer Science, Twente University
of Technology, The Netherlands",
 NUMBER = "Informatica 89-40",
 YEAR = 1989, MONTH = "June"}

@TECHREPORT{VanProeyan:76,
 AUTHOR = "A. Van Proeyen",
 TITLE = "Quantum Gravity Corrections on the Anomalous
Magnetic and Quadrupole Moments of a Spin-1 Particle",
 INSTITUTION = "Instituut voor Theor. Fys., Leuven",
 YEAR = 1976, MONTH = "October"}

@TECHREPORT{VanProeyan:79,
 AUTHOR = "A. Van Proeyan",
 TITLE = "Gravitational Divergences of the Electromagnetic
Interactions of Massive Vectorparticles",
 INSTITUTION = "Universiteit Leuven",
 YEAR = 1979, TYPE = "Preprint", NUMBER = "KUL-TF-79/032",
 MONTH = "October",
 ABSTRACT = {In a search for the explanation of the finite quantum
gravity corrections to anomalous moments we examined a
spontaneous broken 0(3) model with Yang-Mills particles
and Higgs scalars coupled to gravitons.}}

@INPROCEEDINGS{Vega:91,
 AUTHOR = "Laureano Gonz{\'a}lez Vega",
 TITLE = "Working with Real Algebraic Plane Curves in {REDUCE:} the
{GCUR} package",
 YEAR = 1991, MONTH = "July",
 BOOKTITLE = "Proc. of the 1991 International Symposium on Symbolic and
Algebraic Computation",
 EDITOR = "Stephen M. Watt", PUBLISHER = "ACM Press", ADDRESS = "Maryland",
 PAGES = "397-402"}

@TECHREPORT{Vinitsky:87,
 AUTHOR = "S. I. Vinitsky and V. A. Rostovtsev",
 TITLE = "A Use of {REDUCE} System in Problems of
Hydrogen Atom in an Electric Field",
 INSTITUTION = "J.I.N.R., Dubna", TYPE = "Preprint",
 YEAR = 1987, NUMBER = "P11-87-303"}

@ARTICLE{Voros:77,
 AUTHOR = "A. Voros",
 TITLE = "Asymptotic K-Expansions of Stationary Quantum States",
 JOURNAL = "Ann. Inst. H. Poincare",
 YEAR = 1977, VOLUME = "26A", PAGE = "343"}

@TECHREPORT{Wanas,
 AUTHOR = "M. I. Wanas",
 TITLE = "The Third Face of Computer -- Computer Solution
of Symbolic Problems",
 INSTITUTION = "Military Technical College, Cairo, Egypt",
 NUMBER = "CAP-3 837"}

@INPROCEEDINGS{Wanas:85,
 AUTHOR = "M. I. Wanas",
 TITLE = "Manipulation of Parameters Indicating the
Physical Significance of any Absolute Parallelism
Space Using {REDUCE} 2",
 YEAR = 1985,
 BOOKTITLE = "Tenth International Congress for Statistics,
Computer Science, Social and Demographic Research"}

@INPROCEEDINGS{Wang:84,
 AUTHOR = "Paul S. Wang and T. Y. P. Chang and J. A. van Hulzen",
 TITLE = "Code Generation and Optimization for Finite Element Analysis",
 BOOKTITLE = "Proc. {EUROSAM} 1984, Lecture Notes
in Computer Science", YEAR = 1984, VOLUME = 174, PAGES = "237-247",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Wassam:87,
 AUTHOR = "W. A. {Wassam, Jr.} and Go. Torres-Vega",
 TITLE = "Dual {Lanczos} Transformation Theory:  Closed Set of Algebraic
Equations Connecting {Lanczos} Parameters with Moments in Moment
Expansions of Time-Dependent Quantities",
 JOURNAL = "Chemical Phys. Lett.",
 YEAR = 1987, VOLUME = 134, NUMBER = 4, PAGES = "355-360",
 COMMENT = {"The utility of this set of equations is illustrated by using
them with the aid of symbolic manipulation on a computer to construct a
previously unknown exact continued fraction for the spectral density
of the incoherent scattering function{\ldots}" The system used is {REDUCE}
on a Burroughs.  Appear enthusiastic about the possibilities for
computer algebra in related fields.}}

@ARTICLE{Wassam:87a,
 AUTHOR = "W. A. {Wassam, Jr.} and Go. Torres-Vega and J. Neito-Frausto",
 TITLE = "Dual {Lanczos} Transformation Theory:  Exact Continued
Fraction Expression for Resonant $\gamma$-ray Absorption Spectrum of a
Harmonically Bound Atom Executing Classical Motion Described by
{Smoluchowski} Dynamics",
 JOURNAL = "Chemical Phys. Lett.",
 YEAR = 1987, VOLUME = 136, NUMBER = 1, PAGES = "26-30",
 COMMENT = {"{\ldots}with the aid of symbolic manipulation techniques, we
construct a previously unknown exact continued fraction for the resonance
$\gamma$-ray absorption spectrum{\dots}"  The system used is {REDUCE}
on a Burroughs.}}

@TECHREPORT{Watanabe:85,
 AUTHOR = "Yoichi Watanabe",
 TITLE = "Symbolic Manipulation of Structure Functions
in Availability Analysis",
 INSTITUTION = "Fusion Technology Institute, University of
Wisconsin, Madison, Wisconsin",
 YEAR = 1985, NUMBER = "UWFDM-658", MONTH = "November"}

@ARTICLE{Watanabe:76,
 AUTHOR = "Shunro Watanabe",
 TITLE = "Formula Manipulations Solving Linear Ordinary
Differential Equations {II}",
 JOURNAL = "Publications of the Research Institute for
Mathematical Sciences, Kyoto University",
 YEAR = 1976, VOLUME = 11, NUMBER = 2, PAGES = "297-337"}

@ARTICLE{Watanabe:79,
 AUTHOR = "Shunro Watanabe",
 TITLE = "A Verification for Non-existence of Movable Branch Points of Six
Painlev{\'e} Transcendents by Formula Manipulations",
 JOURNAL = "Tokyo Journal of Mathematics",
 YEAR = 1979, VOLUME = 2, NUMBER = 2, PAGES = "285-291"}

@ARTICLE{Weber:79,
 AUTHOR = "Lawrence A. Weber and Gerhard Rayna",
 TITLE = "Problem \#11 Solved in {REDUCE:}  A Case Study in Program
Translation",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1979, VOLUME = 13, NUMBER = 4, PAGES = "21-24", MONTH = "November"}

@ARTICLE{Wehner:86,
 AUTHOR = "M. F. Wehner and W. G. Wolfer",
 TITLE = "The Pressure of a Hard Sphere Fluid on a Curved Surface",
 JOURNAL = "J. Statistical Phys.",
 YEAR = 1986, VOLUME = 42, PAGES = "509-521",
 COMMENT = {Integral equation approach and perturbation expansions in
{REDUCE}.  "Therefore, in order to avoid errors, the integrations have been
done in closed form with the algebraic manipulation routine {REDUCE}."}}

@INCOLLECTION{Winkelmann:89,
 AUTHOR = "Volker Winkelmann and Friedrich W. Hehl",
 TITLE = "{REDUCE} for Beginners. Six Lectures on the
Application of Computer Algebra",
 EDITOR = "D. Stauffer and F. W. Hehl and V. Winkelmann and
J. G. Zabolitzky",
 BOOKTITLE = "Computer Simulation and Computer Algebra.
Lectures for Beginners",
 CHAPTER = 3, EDITION = "2nd", PUBLISHER = "Springer-Verlag",
 YEAR= 1989}

@TECHREPORT{Winkler:88,
 AUTHOR = "F. Winkler and B. Kutzler and F. Lichtenberger",
 TITLE = "Computeralgebrasysteme (in {German})",
 INSTITUTION = "RISC - LINZ, Austria", TYPE = "Report",
 YEAR = 1988, NUMBER = "88-10"}

@ARTICLE {Witham:77,
 AUTHOR = "C. R. Witham and S. Dubowsky",
 TITLE = "An Improved Symbolic Manipulation Technique for
the Simulation of Nonlinear Dynamic Systems With Mixed
Time-Varying and Constant Terms",
 JOURNAL = "Journal of Dynamic Systems, Measurement, and Control",
 YEAR = 1977, MONTH = "September", PAGES = "157-165",
 ABSTRACT = {The time domain behavior of nonlinear dynamic systems
often is obtained by numerical integration on the digital
computer.  These solutions are usually expensive and limit
the scope of the dynamic study.  The proposed improved
technique results in a substantial increase in the computational
efficiency by using automatic symbolic manipulation to generate
explicit equations of motion algebraically prior to numerical
integration.}}

@ARTICLE{Wood:89,
 AUTHOR = "John C. Wood",
 TITLE = "Harmonic Two Spheres in the Unitary Group",
 YEAR = 1989,
 JOURNAL = "Proc. London Math. Soc.",
 VOLUME = 3, NUMBER = 58, PAGES = "608-624"}

@TECHREPORT{Wright:84,
 AUTHOR = "F. J. Wright and G. Dangelmayr",
 TITLE = "Explicit Iterative Algorithms to Reduce a Univariate Catastrophe
to Normal Form",
 INSTITUTION = "Universit{\"a}t T{\"u}bingen",
 YEAR = 1984}

@TECHREPORT{Wulkow:90,
 AUTHOR = "Michael Wulkow and Peter Deuflhard",
 TITLE = "Towards an efficient computational treatment of heterogeneous
polymer reactions",
 INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin",
 YEAR = 1990, TYPE = "Preprint", NUMBER = "SC 90-1", MONTH = "January"}

@INPROCEEDINGS{Yamamoto:87,
 AUTHOR = "T. Yamamoto and Y. Aoki",
 TITLE = "{REDUCE} 3.2 on {iAPX 86/286}-based Personal Computers",
 BOOKTITLE = "Proc. {EUROCAL} '87, Lecture Notes
in Computer Science", YEAR = 1987, VOLUME = 378, PAGES = "134-135",
 PUBLISHER = "Springer-Verlag"}

@ARTICLE{Yamartino:91,
 AUTHOR = "Robert J. Yamartino and Richard Pavelle",
 TITLE = "An Application of Computer Algebra to a Problem in Stratified
Fluid Flow",
 JOURNAL = "J. Symb. Comp.",
 YEAR = 1991, VOLUME = 12, NUMBER = 6, PAGES = "669-672", MONTH = "December"}
 ABSTRACT = {The computationally tedious problem of considering trial Green's
function solutions to the fourth-order partial differential equation for a
stratified atmosphere flowing over a hill is approached using MACSYMA.
Significance of the problem, solution methodologies and CPU time
intercomparisons using various computer platforms and other algebra systems
are discussed.}}

@ARTICLE{Yannouleas:88,
 AUTHOR = "C. Yannouleas and J. M. Pacheco",
 TITLE = "An Algebraic Program for the States Associated with the
${U(5)} \supset {O(5)} \supset {O(3)}$ Chain of Groups",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1988, VOLUME = 52, NUMBER = 1, PAGES = "85-92", MONTH = "December"}

@ARTICLE{Yannouleas:89,
 AUTHOR = "C. Yannouleas and J. M. Pacheco",
 TITLE = "Algebraic Manipulation of the States Associated with the
${U(5)} \supset {O(5)} \supset {O(3)}$ Chain of {groups:}
Orthonormalization and Matrix Elements",
 JOURNAL = "Comp. Phys. Comm.",
 YEAR = 1989, VOLUME = 54, NUMBER = "2 and 3", PAGES = "315-328",
MONTH = "June and July"}

@ARTICLE{Zacrep:75,
 AUTHOR = "Douglas Zacrep and Bing-Lin Young",
 TITLE = "Trace and {Ward-Takahashi} Identity Anomalies
in an {SU}(3) Current Model with Energy-Momentum Tensor",
 JOURNAL = "Phys. Rev. D",
 YEAR = 1975, VOLUME = 12, PAGES = "513-522"}

@ARTICLE{Zahalak:87,
 AUTHOR = "G. I. Zahalak and P. R. Rao and S. P. Sutera",
 TITLE = "Large Deformations of a Cylindrical Liquid-Filled Membrane
by a Viscous Shear Flow",
 JOURNAL = "J. Fluid Mech.",
 YEAR = 1987, VOLUME = 179, PAGES = "283-305",
 COMMENT = {Draws attention to the use of classical perturbation
techniques combined with computer algebra as an alternative to
numerical calculation.}}

@ARTICLE{Zeng:84,
 AUTHOR = "Wan-zhen Zeng and Bail-lin Hao",
 TITLE = "Scaling Property of Period-n-Tupling
Sequences in One-Dimensional Mappings",
 JOURNAL = "Commun. in Theor. Phys., Beijing, China",
 YEAR = 1984, VOLUME = 3, NUMBER = 3, PAGES = "283-295"}

@TECHREPORT{Zhidkova:78,
 AUTHOR = "I. E. Zhidkova and I. P. Nedyalkov and V. A. Rostovtsev",
 TITLE = "On Applicability Limits of the Experimental Method
for Investigating Strong Gravitational Fields",
 INSTITUTION = "J.I.N.R., Dubna",
 YEAR = 1978, NUMBER = "P2 - 11589",
 COMMENT = {Mechanical effects of tidal forces on the physical apparatus
exploring strong gravitational fields are investigated.}}

Added r34.1/doc/bibl.tex version [1d0b1a86d2].



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
% The following UNIX script will create a hard copy version of the
% REDUCE bibliography from this file and the bibliography files
% bibl-*.bib.  It creates the files tmp.* in the process.
%
%       #  Make REDUCE bibliography
%       rm tmp.*
%       cat bibl.tex > tmp.tex
%       cat bibl*.bib > tmp.bib
%       bib2tex tmp | sed 1,5d >> tmp.tex
%       latex tmp
%       bibtex tmp  > tmp.blog
%       latex tmp
%       latex tmp
%
\documentstyle [11pt]{article}
\def\thebibliography#1{\section*{}\list
 {[\arabic{enumi}]}{\settowidth\labelwidth{[#1]}\leftmargin\labelwidth
 \advance\leftmargin\labelsep
 \usecounter{enumi}}
 \def\newblock{\hskip .11em plus .33em minus .07em}
 \sloppy\clubpenalty4000\widowpenalty4000
 \sfcode`\.=1000\relax}
\textwidth 6.6in\textheight 9in\columnwidth\textwidth
\hoffset-2cm
\begin{document}
\setcounter{page}{0}
\title{REDUCE Bibliography}
\author{Anthony C. Hearn\\
RAND \\
Santa Monica CA 90407-2138  \vspace {.5cm} \\
June 1992}
\date{}
\maketitle
\vspace{1cm}
This document contains a list of all known references to REDUCE.  It no doubt
contains errors and omissions.  Please report these by regular mail
(preferably in BibTeX format) to the REDUCE Secretary, RAND, P.O. Box 2138,
Santa Monica CA 90407-2318, or by electronic mail to reduce@rand.org.  An
electronic copy of the bibliography in BibTeX format is also available from
the latter address.
\begin{center}
\vspace{9.0cm}
RAND Publication CP162 (Rev. 6/92) \vspace*{.5cm} \\
Copyright \copyright 1992 RAND.  All rights reserved.
\end{center}
\newpage
\voffset-2.5cm

\nocite{Abbott:85}
\nocite{Abbott:86}
\nocite{Abbott:87}
\nocite{Abbott:87a}
\nocite{Abbott:88}
\nocite{Abbott:88a}
\nocite{Abbott:89}
\nocite{Abbott:89a}
\nocite{Abdali:88}
\nocite{Abiezzi:83}
\nocite{Abramov:91}
\nocite{Abramov:91a}
\nocite{Adamchik90}
\nocite{Adams:83}
\nocite{Adkins:83}
\nocite{Adkins:83a}
\nocite{Adkins:85}
\nocite{Aguilera-Navarro:87}
\nocite{Akselrod:90}
\nocite{Aldins:69}
\nocite{Alekseev:86}
\nocite{Alekseev:87}
\nocite{Alekseev:87a}
\nocite{Alfeld:82}
\nocite{Amirkhanov:87}
\nocite{Amirkhanov:91}
\nocite{Antweiler:89}
\nocite{Appelquist:70}
\nocite{Arbuzov:86}
\nocite{Aso:81}
\nocite{Atherton:73}
\nocite{Aurenche:84}
\nocite{Aurenche:84a}
\nocite{Autin:89}
\nocite{Baekler:84}
\nocite{Baekler:84a}
\nocite{Baekler:86}
\nocite{Baekler:87}
\nocite{Baekler:87a}
\nocite{Baekler:87b}
\nocite{Baekler:88}
\nocite{Baekler:88a}
\nocite{Baekler:88b}
\nocite{Bahrdt:90}
\nocite{Baier:81}
\nocite{Baier:85}
\nocite{Baier:90}
\nocite{Bajla:78}
\nocite{Balian:78}
\nocite{Baker:81}
\nocite{Bark:78}
\nocite{Barthes-Biesel:73}
\nocite{Barton:72}
\nocite{Bateman:86}
\nocite{Belkov:91}
\nocite{Bennett}
\nocite{Berends:81}
\nocite{Berkovich:89}
\nocite{Berkovich:90}
\nocite{Berman:63}
\nocite{Berndt:91}
\nocite{Bessis:85}
\nocite{Billoire:78}
\nocite{Biro:86}
\nocite{Biro:87}
\nocite{Birrell:77}
\nocite{Biswas:75}
\nocite{Bittencourt:90}
\nocite{Bocko:92}
\nocite{Boege:86}
\nocite{Bogdanova:88}
\nocite{Bordoni:81}
\nocite{Bowyer:87}
\nocite{Boyd:78}
\nocite{Brackx:87}
\nocite{Brackx:87a}
\nocite{Brackx:89}
\nocite{Bradford:86}
\nocite{Bradford:88}
\nocite{Bradford90}
\nocite{Broadhurst:85}
\nocite{Broadhurst:91}
\nocite{Broadhurst:91a}
\nocite{Brodsky:62}
\nocite{Brodsky:67}
\nocite{Brodsky:69}
\nocite{Brodsky:70}
\nocite{Brodsky:71}
\nocite{Brodsky:72}
\nocite{Brodsky:72a}
\nocite{Brodsky:72b}
\nocite{Brodsky:73}
\nocite{Broughan:82}
\nocite{Broughan:91}
\nocite{Brown:79}
\nocite{Bryan-Jones:87}
\nocite{Burnel}
\nocite{Calmet:72}
\nocite{Calmet:72a}
\nocite{Calmet:74}
\nocite{Calmet:83}
\nocite{Campbell:67}
\nocite{Campbell:68}
\nocite{Campbell:70}
\nocite{Campbell:70a}
\nocite{Campbell:74}
\nocite{Campbell:87}
\nocite{Caprasse:84}
\nocite{Caprasse:85}
\nocite{Caprasse:86}
\nocite{Caprasse:86a}
\nocite{Caprasse:88}
\nocite{Caprasse:89a}
\nocite{Caprasse:90}
\nocite{Caprasse:91}
\nocite{Carlson:80}
\nocite{Carroll:73}
\nocite{Carroll:75}
\nocite{Cejchan}
\nocite{Chaffy:88}
\nocite{Chinnick:86}
\nocite{Cline:90}
\nocite{Cohen:76}
\nocite{Cohen:76a}
\nocite{Cohen:77}
\nocite{Cohen:79}
\nocite{Cohen:84}
\nocite{Cohen:89}
\nocite{Connor:84}
\nocite{Connor:84a}
\nocite{Conwell:84}
\nocite{Cowan:79}
\nocite{Cung:75}
\nocite{Darbaidze:86}
\nocite{Darbaidze:86a}
\nocite{Darbaidze:88}
\nocite{Darbaidze:89}
\nocite{Dautcourt:79}
\nocite{Dautcourt:80}
\nocite{Dautcourt:81}
\nocite{Dautcourt:83}
\nocite{Davenport:81}
\nocite{Davenport:82}
\nocite{Davenport:82a}
\nocite{Davenport:85}
\nocite{Davenport:88}
\nocite{Davenport:88a}
\nocite{Della-Dora:81}
\nocite{Della-Dora:84}
\nocite{Della-Dora:85}
\nocite{Demaret:89}
\nocite{DeMenna:87}
\nocite{Demichev:85}
\nocite{Demichev:86}
\nocite{deRop:88}
\nocite{DeVos:89}
\nocite{Dewar:89}
\nocite{Dhar:85}
\nocite{Dicrescenzo:85}
\nocite{Diver}
\nocite{Diver:86}
\nocite{Diver:88}
\nocite{Diver:88a}
\nocite{Diver:91}
\nocite{Dorfi:85}
\nocite{Dorizzi:86}
\nocite{dosSantos:85}
\nocite{dosSantos:87}
\nocite{dosSantos:87a}
\nocite{dosSantos:88a}
\nocite{dosSantos:90}
\nocite{Drska:90}
\nocite{Dubowsky:75}
\nocite{Dudley:89}
\nocite{Dufner:69}
\nocite{Dulyan:87}
\nocite{Duncan:86}
\nocite{Duval:87}
\nocite{Earles:70}
\nocite{Eastwood:87}
\nocite{Eastwood:87a}
\nocite{Eastwood:91}
\nocite{Edelen:81}
\nocite{Edelen:82}
\nocite{Edneral:89}
\nocite{Eisenberger:90}
\nocite{Eissfeller:86}
\nocite{Eitelbach:73}
\nocite{Eleuterio:82}
\nocite{Eliseev:85}
\nocite{Elishakoff:87}
\nocite{Elishakoff:87a}
\nocite{Esteban:90}
\nocite{Falck:89}
\nocite{Fazio:84}
\nocite{Fedorova:87}
\nocite{Fedorova:87a}
\nocite{Feldmar:86}
\nocite{Feuillebois:84}
\nocite{Fitch:73}
\nocite{Fitch:81}
\nocite{Fitch:83}
\nocite{Fitch:85}
\nocite{Fitch:85a}
\nocite{Fitch:87}
\nocite{Fitch:87a}
\nocite{Fitch:89}
\nocite{Fitch:89a}
\nocite{Fitch90}
\nocite{Fitch:90a}
\nocite{Flatau:86}
\nocite{Flath:86}
\nocite{Fleischer:71}
\nocite{Fleischer:73}
\nocite{Fleischer:75}
\nocite{Fogelholm:82}
\nocite{Foster:89}
\nocite{Fox:71}
\nocite{Fox:74}
\nocite{Franceschetti:85}
\nocite{Freire:88}
\nocite{Freire:89}
\nocite{Frick:82}
\nocite{Fujimoto:84}
\nocite{Fuzio:85}
\nocite{Gaemers}
\nocite{Gaemers:78}
\nocite{Ganzha:89}
\nocite{Ganzha90}
\nocite{Ganzha90a}
\nocite{Ganzha:91}
\nocite{Garavaglia}
\nocite{Garavaglia:80}
\nocite{Garavaglia:84}
\nocite{Garcia:86}
\nocite{Garrad:86}
\nocite{Gastmans:79}
\nocite{Gatermann:90}
\nocite{Gatermann90a}
\nocite{Gatermann:91}
\nocite{Gatermann:91a}
\nocite{Gatermann:91b}
\nocite{Gates:85}
\nocite{Gates:85a}
\nocite{Gates:85b}
\nocite{Gates:85c}
\nocite{Gates:86}
\nocite{Gebauer:85}
\nocite{Gebauer:88}
\nocite{George:68}
\nocite{Gerdt:80}
\nocite{Gerdt:80a}
\nocite{Gerdt:80b}
\nocite{Gerdt:85}
\nocite{Gerdt:85a}
\nocite{Gerdt:85b}
\nocite{Gerdt:85c}
\nocite{Gerdt:86}
\nocite{Gerdt:87}
\nocite{Gerdt:87a}
\nocite{Gerdt:89}
\nocite{Gerdt:89a}
\nocite{Gerdt:89b}
\nocite{Gerdt90}
\nocite{Gerdt90a}
\nocite{Gerdt:90b}
\nocite{Gerdt:90c}
\nocite{Gerdt:91}
\nocite{Gerdt:91a}
\nocite{Gerdt:91b}
\nocite{Gervois:74}
\nocite{Gladd:82}
\nocite{Gladkih:83}
\nocite{Gladkih:84}
\nocite{Goldman:89}
\nocite{Golley}
\nocite{Good:75}
\nocite{Goto:77}
\nocite{Goto:78}
\nocite{Gould:84}
\nocite{Gragert:81}
\nocite{Grammaticos}
\nocite{Grammaticos:78}
\nocite{Grammaticos:85}
\nocite{Greenland:84}
\nocite{Grimm}
\nocite{Griss:74}
\nocite{Griss:74a}
\nocite{Griss:75}
\nocite{Griss:76}
\nocite{Griss:76a}
\nocite{Griss:77}
\nocite{Griss:77a}
\nocite{Griss:78}
\nocite{Griss:78a}
\nocite{Griss:79}
\nocite{Griss:79a}
\nocite{Grozin:83}
\nocite{Grozin:88}
\nocite{Grozin:88a}
\nocite{Grozin:88b}
\nocite{Grozin:90}
\nocite{Grozin:90a}
\nocite{Grozin:90b}
\nocite{Grozin:91}
\nocite{Grozin:91a}
\nocite{Gunion:72}
\nocite{Gunion:73}
\nocite{Gunion:85}
\nocite{Hadinger:87}
\nocite{Handy:87}
\nocite{Harper:87}
\nocite{Harper:89}
\nocite{Harper:89a}
\nocite{Harrington:77}
\nocite{Harrington:77a}
\nocite{Harrington:79}
\nocite{Harrington:79a}
\nocite{Hartley:91}
\nocite{Hasenfratz:80}
\nocite{Hearn:68}
\nocite{Hearn:69}
\nocite{Hearn:69a}
\nocite{Hearn:71}
\nocite{Hearn:71a}
\nocite{Hearn:71b}
\nocite{Hearn:71c}
\nocite{Hearn:72}
\nocite{Hearn:72a}
\nocite{Hearn:72b}
\nocite{Hearn:73}
\nocite{Hearn:73a}
\nocite{Hearn:74}
\nocite{Hearn:74a}
\nocite{Hearn:76}
\nocite{Hearn:76a}
\nocite{Hearn:76b}
\nocite{Hearn:77}
\nocite{Hearn:78}
\nocite{Hearn:79}
\nocite{Hearn:79a}
\nocite{Hearn:80}
\nocite{Hearn:81}
\nocite{Hearn:81a}
\nocite{Hearn:82}
\nocite{Hearn:82a}
\nocite{Hearn:85}
\nocite{Hearn:86}
\nocite{Hearn:91}
\nocite{Hermann:83}
\nocite{Hess:84}
\nocite{Hettich:77}
\nocite{Hietarinta:83}
\nocite{Hietarinta:83a}
\nocite{Hietarinta:84}
\nocite{Hietarinta:84a}
\nocite{Hietarinta:84b}
\nocite{Hietarinta:85}
\nocite{Hietarinta:87}
\nocite{Hietarinta:87a}
\nocite{Hietarinta:87b}
\nocite{Hietarinta:87c}
\nocite{Hietarinta:88}
\nocite{Hietarinta:89}
\nocite{Hietarinta:91}
\nocite{Hietarinta:92}
\nocite{Hietarinta:92a}
\nocite{Hirota:89}
\nocite{Horowitz:75}
\nocite{Horwitz:83}
\nocite{Hughes:90}
\nocite{Hulshof:84}
\nocite{Hulshof:85}
\nocite{Hulshof:81}
\nocite{Hulshof:83}
\nocite{Husberg:81}
\nocite{Idesawa:77}
\nocite{Ilyin:87}
\nocite{Ilyin:89}
\nocite{Ilyin:91}
\nocite{Ilyin:91a}
\nocite{Inada:80}
\nocite{Ioakimidis:90}
\nocite{Ioakimidis:90a}
\nocite{Ito:85}
\nocite{Ito:85a}
\nocite{Ito:88}
\nocite{Ito:90}
\nocite{Ito:90a}
\nocite{Jansen:86}
\nocite{Janssen:87}
\nocite{Jeffrey:84}
\nocite{Kadlecsik:88}
\nocite{Kadlecsik:92}
\nocite{Kagan:85}
\nocite{Kagan:88}
\nocite{Kahn:69}
\nocite{Kamal:81}
\nocite{Kamel:69}
\nocite{Kamel:69a}
\nocite{Kamel:78}
\nocite{Kanada:81}
\nocite{Kanada:75}
\nocite{Kaneko:89}
\nocite{Kaps:85}
\nocite{Karr:85}
\nocite{Katsura:85}
\nocite{Kauffman:73}
\nocite{Kazasov:87}
\nocite{Keady:85}
\nocite{Keener:83}
\nocite{Keener:85}
\nocite{Keener:89}
\nocite{Keener:90}
\nocite{Kendall:88}
\nocite{Kendall:89}
\nocite{Kendall:89a}
\nocite{Kendall:90}
\nocite{Kendall:91}
\nocite{Kendall:91a}
\nocite{Kerner:75}
\nocite{Kersten:83}
\nocite{Kersten:84}
\nocite{Kersten:86}
\nocite{Kersten:86a}
\nocite{Kersten:86b}
\nocite{Killalea:80}
\nocite{Kinoshita:72}
\nocite{Kinoshita:73}
\nocite{Kitatani:86}
\nocite{Kobayashi:84}
\nocite{Kobayashi:88}
\nocite{Kodaira:85}
\nocite{Koh:82}
\nocite{Koelbig:81}
\nocite{Koelbig:81b}
\nocite{Koelbig:82}
\nocite{Koelbig:82a}
\nocite{Koelbig:83}
\nocite{Koelbig:83a}
\nocite{Koelbig:84}
\nocite{Koelbig:84a}
\nocite{Koelbig:84b}
\nocite{Koelbig:85}
\nocite{Koelbig:85a}
\nocite{Koelbig:86}
\nocite{Kolar:90}
\nocite{Kornyak:87}
\nocite{Kotorynski:86}
\nocite{Krack:82}
\nocite{Kraus:73}
\nocite{Kredel:88}
\nocite{Kruse:83}
\nocite{Kryukov}
\nocite{Kryukov:84}
\nocite{Kryukov:85}
\nocite{Kryukov:85a}
\nocite{Kryukov:87}
\nocite{Kryukov:87a}
\nocite{Kryukov:88}
\nocite{Kryukov:88a}
\nocite{Kryukov:88b}
\nocite{Kryukov:91}
\nocite{Kuppers:71}
\nocite{Lambin:84}
\nocite{Lang:79}
\nocite{Laursen:79}
\nocite{Laursen:80}
\nocite{Laursen:81}
\nocite{Lecourtier:85}
\nocite{Lee:85}
\nocite{Leler:85}
\nocite{Lepage:83}
\nocite{Levi:70}
\nocite{Levi:71}
\nocite{Liebermann:75}
\nocite{Liska:84}
\nocite{Liska:87}
\nocite{Liska90}
\nocite{Liska:91}
\nocite{Lloyd:90}
\nocite{Loe:85}
\nocite{London:74}
\nocite{Loos:72}
\nocite{Lottati}
\nocite{Louw:86}
\nocite{Luegger:73}
\nocite{Luegger:91}
\nocite{Lukacs}
\nocite{Lukaszuk:87}
\nocite{Lux:75}
\nocite{MacCallum:86}
\nocite{MacCallum:86a}
\nocite{MacCallum:87}
\nocite{MacCallum:88}
\nocite{MacCallum:89}
\nocite{MacCallum:91}
\nocite{Mack:73}
\nocite{Mack:73a}
\nocite{Maclaren:89}
\nocite{Maguire:81}
\nocite{Malm:82}
\nocite{Marti:78}
\nocite{Marti:79}
\nocite{Marti:80}
\nocite{Marti:83}
\nocite{Marti:85}
\nocite{Marti:85a}
\nocite{Marti:88}
\nocite{Marzinkewitsch:91}
\nocite{Matveev:87}
\nocite{Maurer:86}
\nocite{Mazepa:85}
\nocite{Mazzarella:85}
\nocite{McCrea:81}
\nocite{McCrea:82}
\nocite{McCrea:83}
\nocite{McCrea:84}
\nocite{McCrea:84a}
\nocite{McCrea:87}
\nocite{McCrea:87a}
\nocite{McCrea:88}
\nocite{McIsaac:85}
\nocite{Melenk:88}
\nocite{Melenk:89}
\nocite{Melenk:89a}
\nocite{Melenk:89b}
\nocite{Mirie:84}
\nocite{Molenkamp:91}
\nocite{Moller:89}
\nocite{Moritsugu:85}
\nocite{Moritsugu:88}
\nocite{Moritsugu:89}
\nocite{Moritsugu:89a}
\nocite{Muroa:91}
\nocite{Mueller:81}
\nocite{Murzin:85}
\nocite{Nagata:82}
\nocite{Nagata:85}
\nocite{Nakamura:89}
\nocite{Nakashima:84}
\nocite{Nakashima:84a}
\nocite{Namba:86}
\nocite{Nemeth:82}
\nocite{Nemeth:87}
\nocite{Neun:89}
\nocite{Neutsch:85}
\nocite{Neutsch:86}
\nocite{Ng:89}
\nocite{Niki:84}
\nocite{Nikityuk:87}
\nocite{Noor:79}
\nocite{Norman:77}
\nocite{Norman:78}
\nocite{Norman:79}
\nocite{Norman:83}
\nocite{Norman90}
\nocite{Norton:80}
\nocite{Nucci:90}
\nocite{Ochiai:90}
\nocite{Ogilvie:82}
\nocite{Ogilvie:89}
\nocite{Ono:1979}
\nocite{Ozieblo}
\nocite{Padget90}
\nocite{Pankau:73}
\nocite{Pankau:73a}
\nocite{Parsons:68}
\nocite{Parsons:71}
\nocite{Pasini:91}
\nocite{Pattnaik:83}
\nocite{Pearce:81}
\nocite{Pearce:83}
\nocite{Perjes:84}
\nocite{Perjes:84a}
\nocite{Perjes:84b}
\nocite{Perjes:84c}
\nocite{Perjes:86}
\nocite{Perjes:86a}
\nocite{Perjes:88}
\nocite{Perlt:90}
\nocite{Perrottet:78}
\nocite{Pesic:73}
\nocite{Pictiaw:69}
\nocite{Piessens:84}
\nocite{Piessens:86}
\nocite{Pignataro:85}
\nocite{Podgorzak:84}
\nocite{Price:84}
\nocite{Quarton}
\nocite{Quarton:84}
\nocite{Rao:85}
\nocite{Rayna:87}
\nocite{Renner:91}
\nocite{Reusch:86}
\nocite{Rink:71}
\nocite{Rizzi:85}
\nocite{Rodionov:84}
\nocite{Rodionov:87}
\nocite{Rodionov:87a}
\nocite{Rodionov:88}
\nocite{Roelofs:91}
\nocite{Rogers:89}
\nocite{Roque:88}
\nocite{Roque:91}
\nocite{Ronveaux:88}
\nocite{Ronveaux:89}
\nocite{Rudenko:91}
\nocite{Saez:83}
\nocite{Sage:88}
\nocite{Sarlet:91}
\nocite{Sasaki:79}
\nocite{Savage:90}
\nocite{Sayers:87}
\nocite{Sayers:87a}
\nocite{Schlegel:91}
\nocite{Schmuck:77}
\nocite{Schoepf:91}
\nocite{Schruefer:81}
\nocite{Schruefer:82}
\nocite{Schruefer:87}
\nocite{Schruefer:88}
\nocite{Schwarz:80}
\nocite{Schwarz:82}
\nocite{Schwarz:82a}
\nocite{Schwarz:83}
\nocite{Schwarz:83a}
\nocite{Schwarz:84}
\nocite{Schwarz:84a}
\nocite{Schwarz:85}
\nocite{Schwarz:85a}
\nocite{Schwarz:86}
\nocite{Schwarz:87}
\nocite{Schwarz:88}
\nocite{Seiler:91}
\nocite{Shablygin:87}
\nocite{Shmueli:83}
\nocite{Shmueli:83a}
\nocite{Shtokhamer:75}
\nocite{Shtokhamer:77}
\nocite{Smit:79}
\nocite{Smit:81}
\nocite{Smit:82}
\nocite{Smit:87}
\nocite{Soderstrand:72}
\nocite{Soderstrand:72a}
\nocite{Soderstrand:74}
\nocite{Soma:77}
\nocite{Soma:85}
\nocite{Spiridonova:87}
\nocite{Squire}
\nocite{Steinberg:82}
\nocite{Steuerwald}
\nocite{Stoutemyer:74}
\nocite{Stoutemyer:75}
\nocite{Stoutemyer:77}
\nocite{Stroscio:74}
\nocite{Stuart:88}
\nocite{Stuart:90}
\nocite{Suppes:89}
\nocite{Surguladze:89}
\nocite{Surguladze:91}
\nocite{Tallents:84}
\nocite{Tao90}
\nocite{Tasso:76}
\nocite{Thas:89}
\nocite{Thas:89a}
\nocite{Todd:88}
\nocite{Toth:86}
\nocite{Tournier:79}
\nocite{Tournier:87}
\nocite{Trenkov:91}
\nocite{Trotter:89}
\nocite{Tsai:65}
\nocite{Tsai:74}
\nocite{Ucoluk:82}
\nocite{Umeno:89}
\nocite{Urintsev:91}
\nocite{vandenHeuvel:86}
\nocite{vandenHeuvel:86a}
\nocite{vandenHeuvel:87}
\nocite{vandenHeuvel:87a}
\nocite{vanHeerwaarden}
\nocite{vanHulzen:80}
\nocite{vanHulzen:81}
\nocite{vanHulzen:82}
\nocite{vanHulzen:82a}
\nocite{vanHulzen:83}
\nocite{vanHulzen:83a}
\nocite{vanHulzen:87}
\nocite{vanHulzen:88}
\nocite{vanHulzen:89}
\nocite{vanHulzen:89a}
\nocite{VanProeyan:76}
\nocite{VanProeyan:79}
\nocite{Vega:91}
\nocite{Vinitsky:87}
\nocite{Voros:77}
\nocite{Wanas}
\nocite{Wanas:85}
\nocite{Wang:84}
\nocite{Wassam:87}
\nocite{Wassam:87a}
\nocite{Watanabe:85}
\nocite{Watanabe:76}
\nocite{Watanabe:79}
\nocite{Weber:79}
\nocite{Wehner:86}
\nocite{Winkelmann:89}
\nocite{Winkler:88}
\nocite{Witham:77}
\nocite{Wood:89}
\nocite{Wright:84}
\nocite{Wulkow:90}
\nocite{Yamamoto:87}
\nocite{Yamartino:91}
\nocite{Yannouleas:88}
\nocite{Yannouleas:89}
\nocite{Zacrep:75}
\nocite{Zahalak:87}
\nocite{Zeng:84}
\nocite{Zhidkova:78}

\bibliography{bibl}
\bibliographystyle{plain}

\end{document}


Added r34.1/doc/compact.bib version [59d301d978].























>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
@INPROCEEDINGS{Hornfeldt:82,
  AUTHOR = "L. Hornfeldt",
  TITLE = "A Sum-Substitutor used as Trigonometric Simplifier",
  BOOKTITLE = "Proc. {EUROCAM} '82",
  PAGES = "188-195",
  SERIES = "Lecture Notes on Comp. Science",
  NUMBER = 144,
  PUBLISHER = "Springer-Verlag",
  ADDRESS = "Berlin",
  YEAR = 1982}

Added r34.1/doc/compact.tex version [78b05677ff].























































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
\documentstyle[11pt,reduce]{article}
\title{COMPACT: Reduction of a Polynomial in the Presence of Side Relations}
\date{}
\author{Anthony C. Hearn\\ RAND\\
Santa Monica CA 90407-2138\\
Email: hearn@rand.org}
\begin{document}
\maketitle

\index{COMPACT package} \index{side relations} \index{relations ! side}
{COMPACT} is a package of functions for the reduction of a polynomial in
the presence of side relations.  The package defines one operator {COMPACT}
\index{COMPACT operator}
whose syntax is:

\begin{quote}
\k{COMPACT}(\s{expression}, \s{list}):\s{expression}
\end{quote}

\s{expression} can be any well-formed algebraic expression, and
\s{list} an expression whose value is a list
of either expressions or equations.  For example

\begin{verbatim}
    compact(x**2+y**3*x-5y,{x+y-z,x-y-z1});
    compact(sin(x)**10*cos(x)**3+sin(x)**8*cos(x)**5,
            {cos(x)**2+sin(x)**2=1});
    let y = {cos(x)**2+sin(x)**2-1};
    compact(sin(x)**10*cos(x)**3+sin(x)**8*cos(x)**5,y);
\end{verbatim}

{COMPACT} applies the relations to the expression so that an equivalent
expression results with as few terms as possible.  The method used is
briefly as follows:

\begin{enumerate}
\item Side relations are applied separately to numerator and denominator, so
that the problem is reduced to the reduction of a polynomial with respect to
a set of polynomial side relations.

\item Reduction is performed sequentially, so that the problem is reduced
further to the reduction of a polynomial with respect to a single
polynomial relation.

\item The polynomial being reduced is reordered so that the variables
(kernels) occurring in the side relation have least precedence.

\item Each coefficient of the remaining kernels (which now only contain
the kernels
in the side relation) is reduced with respect to that side relation.

\item A polynomial quotient/remainder calculation is performed on the
coefficient.  The remainder is
used instead of the original if it has fewer terms.

\item The remaining expression is reduced with respect to the side relation
using a ``nearest neighbor'' approach.
\end{enumerate}

As with the traveling salesman problem, a nearest neighbor approach to
reduction does not necessarily achieve an optimal result.  In most cases
it will be within a factor of two from the optimal result, but in extreme
cases it may be much further away.

Another source of sub-optimal results is that the given expression
is reduced sequentially with respect to the side relations.  So for
example in the case

\begin{verbatim}
        compact((a+b+c)*(a-b-c)*(-a+b-c)*(-a-b+c),
                {x1=a+b+c,x2=a-b-c,x3=-a+b-c,x4=-a-b+c})
\end{verbatim}

the expression is actually $x_{1}x_{2}x_{3}x_{4}$, but any given relation
cannot reduce the size of the expanded form
$a^{4}-2a^{2}b^{2}-2a^{2}c^{2}+b^{4}-2b^{2}c^{2}+c^{4}$
of the original expression, and so the final result is far from optimal.

The only other program we have heard about that considers the compaction
problem is that of Hornfeldt~\cite{Hornfeldt:82}.
However, Hornfeldt reorders expressions so that the kernels in a side
relation have highest order.  Consequently, their coefficients are
polynomials rather than integers or other constants as in our approach.
Furthermore, it is not clear just how general Hornfeldt's approach is from
his description, since he only talks about sine and cosine substitutions.

There are a number of projects that this work immediately suggests.  For
example:

\begin{enumerate}
\item How does one do the reduction with the side relations in parallel?
The above example shows this is necessary for an optimal solution.

\item Should one reduce the side relations to a Groebner or other basis
before doing any reduction?

\item Should one check for the consistency of the basis?

\item How does one do factorization and gcds on a polynomial whose
variables are related by a set of side relations?
\end{enumerate}

The author would be interested in hearing from anyone wishing to work with
him on any of these problems.
\bibliography{compact}
\bibliographystyle{plain}
\end{document}

Added r34.1/doc/excalc.tex version [723cb6ff45].









































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
\documentstyle[11pt,reduce]{article}
\title{EXCALC: A System for Doing Calculations in the Calculus of Modern
Differential Geometry}
\author{Eberhard Schr\"{u}fer \\
GMD, Institut F1   \\
Postfach 1240      \\
5205 St. Augustin  \\
GERMANY       \\[0.05in]
Email: schrufer@gmdzi.gmd.de}
\begin{document}
\maketitle

\index{EXCALC package}

\section*{Acknowledgments}

This program was developed over several years. I would like to express
my deep gratitude to Dr. Anthony Hearn for his continuous interest in
this work, and especially for his hospitality and support during a
visit in 1984/85 at the RAND Corporation, where substantial progress
on this package could be achieved. The Heinrich Hertz-Stiftung
supported this visit. Many thanks are also due to Drs. F.W. Hehl,
University of Cologne, and J.D. McCrea, University College Dublin, for
their suggestions and work on testing this program.

\section{Introduction}

\index{differential geometry}
{\bf EXCALC} is designed for easy use by all who are familiar with the
calculus of Modern Differential Geometry.  Its syntax is kept as close
as possible to standard textbook notations.  Therefore, no great
experience in writing computer algebra programs is required.  It is
almost possible to input to the computer the same as what would have
been written down for a hand-calculation.  For example, the statement

\begin{verbatim}
                       f*x^y + u_|(y^z^x)
\end{verbatim}

\index{exterior calculus}
would be recognized by the program as a formula involving exterior
products and an inner product.  The program is currently able to
handle scalar-valued exterior forms, vectors and operations between
them, as well as non-scalar valued forms (indexed forms).  With this,
it should be an ideal tool for studying differential equations,
doing calculations in general relativity and field theories, or doing
such simple things as calculating the Laplacian of a tensor field for
an arbitrary given frame.  With the increasing popularity of this
calculus, this program should have an application in almost any field
of physics and mathematics.

Since the program is completely embedded in {\REDUCE}, all features and
facilities of {\REDUCE} are available in a calculation.  Even for those
who are not quite comfortable in this calculus, there is a good chance
of learning it by just playing with the program.

This is still a very experimental version, and changes of the syntax
are to be expected. The performance of the program can still be
increased considerably.

Complaints and comments are appreciated and should be sent to the author.
If the use of this program leads to a publication, this document should
be cited, and a copy of the article should be sent to the above address.

\section{Declarations}

Geometrical objects like exterior forms or vectors are introduced to the
system by declaration commands.  The declarations can appear anywhere in
a program, but must, of course, be made prior to the use of the object.
Everything that has no declaration is treated as a constant; therefore
zero-forms must also be declared.

An exterior form is introduced by\label{PFORM} \index{PFORM statement}
\index{exterior form ! declaration}

\hspace*{2em} \k{PFORM} \s{declaration$_1$}, \s{declaration$_2$}, \ldots;

where

\begin{tabbing}
\s{declaration} ::= \s{name}=\s{number}|\s{identifier} $\mid$ \s{expression} \\
\s{name} ::= \s{identifier} $\mid$ \s{identifier}(\s{arguments})
\end{tabbing}

For example

\begin{verbatim}
     pform u=k,v=4,f=0,w=dim-1;
\end{verbatim}

declares {\tt U} to be an exterior form of degree {\tt K}, {\tt V} to be a
form of degree 4, {\tt F} to be a form of degree 0 (a function), and {\tt W}
to be a form of degree {\tt DIM}-1.

If the exterior form should have indices, the declaration would be
\index{exterior form ! with indices}

\begin{verbatim}
     pform curv(a,b)=2,chris(a,b)=1;
\end{verbatim}

The name of the indices is arbitrary.

The declaration of vectors is similar. The command {\tt TVECTOR}\label{TVECTOR}
takes a list of names. \index{TVECTOR command} \index{exterior form ! vector}

\example\index{EXCALC package ! example}

To declare {\tt X} as a vector and {\tt COMM} as a vector with two
indices, one would say

\begin{verbatim}
     tvector x,comm(a,b);
\end{verbatim}

If a declaration of an already existing name is made, the old
declaration is removed, and the new one is taken.


\section{Exterior Multiplication}

\index{"\^{} ! exterior multiplication} \index{exterior product}
Exterior multiplication between exterior forms is carried out with the
nary infix operator \^{ } (wedge)\label{wedge}.  Factors are ordered
according to the usual ordering in {\REDUCE} using the commutation
rule for exterior products.

\example\index{EXCALC package ! example}

\begin{verbatim}
     pform u=1,v=1,w=k;

     u^v;

     U^V

     v^u;

     - U^V

     u^u;

     0

     w^u^v;

           K
     ( - 1) *U^V^W

     (3*u-a*w)^(w+5*v)^u;

     A*(5*U^V^W - U^W^W)
\end{verbatim}

It is possible to declare the dimension of the underlying space
by\label{SPACEDIM} \index{SPACEDIM command} \index{dimension}

\hspace*{2em} \k{SPACEDIM} \s{number} $\mid$ \s{identifier};

If an exterior product has a degree higher than the dimension of the
space, it is replaced by 0:

\begin{verbatim}
     spacedim 4;

     pform u=2,v=3;

     u^v;

     0
\end{verbatim}


\section{Partial Differentiation}

Partial differentiation is denoted by the operator {\tt @}\label{at}.  Its
capability is the same as the {\REDUCE} {\tt DF} operator.
\index{"@ operator} \index{partial differentiation}
\index{differentiation ! partial}

\example\index{EXCALC package ! example}

\begin{verbatim}
     @(sin x,x);

     COS(X)

     @(f,x);

     0
\end{verbatim}

An identifier can be declared to be a function of certain variables.
\index{FDOMAIN command}
This is done with the command {\tt FDOMAIN}\label{FDOMAIN}.  The
following would tell the partial differentiation operator that {\tt F}
is a function of the variables {\tt X} and {\tt Y} and that {\tt H} is
a function of {\tt X}.

\begin{verbatim}
     fdomain f=f(x,y),h=h(x);
\end{verbatim}

Applying {\tt @} to {\tt F} and {\tt H} would result in

\begin{verbatim}
     @(f,x);

     @  F
      X

     @(x*f,x);

     F + X*@  F
            X

     @(h,y);

     0
\end{verbatim}

\index{tangent vector}
The partial derivative symbol can also be an operator with a single
argument.  It then represents a natural base element of a tangent
vector\label{at1}.

\example\index{EXCALC package ! example}

\begin{verbatim}
     a*@ x + b*@ y;

     A*@  + B*@
        X      Y
\end{verbatim}

\section{Exterior Differentiation}
\index{exterior differentiation}
Exterior differentiation of exterior forms is carried out by the
operator {\tt d}\label{d}.  Products are normally differentiated out,
{\em i.e.}

\begin{verbatim}
     pform x=0,y=k,z=m;

     d(x * y);

     X*d Y + d X^Y

     d(r*y);

     R*d Y

     d(x*y^z);

           K
     ( - 1) *X*Y^d Z  + X*d Y^Z + d X^Y^Z
\end{verbatim}

This expansion can be suppressed by the command {\tt NOXPND D}\label{NOXPNDD}.
\index{NOXPND ! D}

\begin{verbatim}
     noxpnd d;

     d(y^z);

     d(Y^Z)
\end{verbatim}

To obtain a canonical form for an exterior product when the expansion
is switched off, the operator {\tt D} is shifted to the right if it
appears in the leftmost place.

\begin{verbatim}
     d y ^ z;

             K
     - ( - 1) *Y^d Z + d(Y^Z)
\end{verbatim}

Expansion is performed again when the command {\tt XPND D}\label{XPNDD}
is executed. \index{XPND ! D}

Functions which are implicitly defined by the {\tt FDOMAIN} command are
expanded into partial derivatives:

\begin{verbatim}
     pform x=0,y=0,z=0,f=0;

     fdomain f=f(x,y);

     d f;

     @  F*d X + @  F*d Y
      X          Y
\end{verbatim}

If an argument of an implicitly defined function has further
dependencies the chain rule will be applied {\em e.g.} \index{chain rule}
                                   

\begin{verbatim}
     fdomain y=y(z);

     d f;

     @  F*d X + @  F*@  Y*d Z
      X          Y    Z
\end{verbatim}

Expansion into partial derivatives can be inhibited by
{\tt NOXPND @}\label{NOXPNDA}
and enabled again by {\tt XPND @}\label{XPNDA}.
\index{NOXPND ! "@} \index{XPND ! "@}

The operator is of course aware of the rules that a repeated
application always leads to zero and that there is no exterior form of
higher degree than the dimension of the space.

\begin{verbatim}
     d d x;

     0

     pform u=k;

     spacedim k;

     d u;

     0
\end{verbatim}

\section{Inner Product}
\index{inner product ! exterior form}
The inner product between a vector and an exterior form is represented
by the diphthong \_$|$ \label{innerp} (underscore or-bar), which is the
notation of many textbooks.  If the exterior form is an exterior
product, the inner product is carried through any factor.
\index{\_$\mid$ operator}

\example\index{EXCALC package ! example}

\begin{verbatim}
     pform x=0,y=k,z=m;

     tvector u,v;

     u_|(x*y^z);

              K
     X*(( - 1) *Y^U_|Z + U_|Y^Z)
\end{verbatim}

In repeated applications of the inner product to the same exterior
form the vector arguments are ordered {\em e.g.}

\begin{verbatim}
     (u+x*v)_|(u_|(3*z));

     - 3*U_|V_|Z
\end{verbatim}

The duality of natural base elements is also known by the system, {\em i.e.}

\begin{verbatim}
     pform x=0,y=0;

     (a*@ x+b*@(y))_|(3*d x-d y);

     3*A - B
\end{verbatim}

\section{Lie Derivative}

\index{Lie Derivative}
The Lie derivative can be taken between a vector and an exterior form
or between two vectors.  It is represented by the infix operator $|$\_
\label{lie}.  In the case of Lie differentiating, an exterior form by
a vector, the Lie derivative is expressed through inner products and
exterior differentiations, {\em i.e.} \index{$\mid$\_ operator}

\begin{verbatim}
     pform z=k;

     tvector u;

     u |_ z;

     U_|d Z + d(U_|Z)
\end{verbatim}

If the arguments of the Lie derivative are vectors, the vectors are
ordered using the anticommutivity property, and functions (zero forms)
are differentiated out.

\example\index{EXCALC package ! example}

\begin{verbatim}
     tvector u,v;

     v |_ u;

     - U|_V

     pform x=0,y=0;

     (x*u)|_(y*v);

     - U*Y*V_|d X + V*X*U_|d Y + X*Y*U|_V
\end{verbatim}

\section{Hodge-* Duality Operator}

\index{Hodge-* duality poperator} \index{"\# ! Hodge-* operator}
The Hodge-*\label{hodge} duality operator maps an exterior form of degree
{\tt K} to an exterior form of degree {\tt N-K}, where {\tt N} is the
dimension of the space.  The double application of the operator must
lead back to the original exterior form up to a factor. The following
example shows how the factor is chosen here

\begin{verbatim}
     spacedim n;

     pform x=k;

     # # x;

             2
           (K  + K*N)
     ( - 1)          *X*SGN
\end{verbatim}

\index{SGN ! indeterminate sign} \index{coframe}
The indeterminate SGN in the above example denotes the sign of the
determinant of the metric. It can be assigned a value or will be
automatically set if more of the metric structure is specified (via
COFRAME), {\em i.e.} it is then set to $g/|g|$, where $g$ is the
determinant of the metric.  If the Hodge-* operator appears in an
exterior product of maximal degree as the leftmost factor, the Hodge-*
is shifted to the right according to

\begin{verbatim}
     pform x=k,y=k;

     # x ^ y;

             2
           (K  + K*N)
     ( - 1)          *X^# Y
\end{verbatim}

More simplifications are performed if a coframe is defined.



\section{Variational Derivative}

\index{derivative ! variational} \index{variational derivative}
\ttindex{VARDF}
The function {\tt VARDF}\label{VARDF} returns as its value the
variation of a given Lagrangian n-form with respect to a specified
exterior form (a field of the Lagrangian).  In the shared variable
\ttindex{BNDEQ"!*}
{\tt BNDEQ!*}, the expression is stored that has to yield zero if
integrated over the boundary.

Syntax:

\hspace*{2em} \k{VARDF}(\s{Lagrangian n-form},\s{exterior form})

\example\index{EXCALC package ! example}

\begin{verbatim}
  spacedim 4;

  pform l=4,a=1,j=3;

  l:=-1/2*d a ^ # d a - a^# j$  %Lagrangian of the e.m. field

  vardf(l,a);

  - (# J + d # d A)             %Maxwell's equations

  bndeq!*;

  - 'A^# d A                    %Equation at the boundary
\end{verbatim}

Restrictions:

In the current implementation, the Lagrangian must be built up by the
fields and the operations {\tt d}, {\tt \#}, and {\tt @}. Variation
with respect to indexed quantities is currently not allowed.

For the calculation of the conserved currents induced by symmetry
operators (vector fields), the function {\tt NOETHER}\label{NOETHER}
\index{NOETHER function}
is provided.  It has the syntax:

\hspace*{2em}
\k{NOETHER}(\s{Lagrangian n-form},\s{field},\s{symmetry generator})

\example\index{EXCALC package ! example}

\begin{verbatim}
  pform l=4,a=1,f=2;

  spacedim 4;

  l:= -1/2*d a^#d a;   %Free Maxwell field;

  tvector x(k);        %An unspecified generator;

  noether(l,a,x(-k));

  ( - 2*d(X _|A)^# d A - (X _|d A)^# d A + d A^(X _|# d A))/2
           K               K                     K
\end{verbatim}

The above expression would be the canonical energy
momentum 3-forms of the Maxwell field, if X is interpreted 
as a translation;



\section{Handling of Indices}
\index{exterior form ! with indices}
Exterior forms and vectors may have indices.  On input, the indices
are given as arguments of the object.  A positive argument denotes a
superscript and a negative argument a subscript.  On output, the
indexed quantity is displayed two dimensionally if {\tt NAT} is on.
\index{NAT flag}
Indices may be identifiers or numbers.  However, zero is currently not
allowed to be an index.

\example\index{EXCALC package ! example}

\begin{verbatim}
     pform om(k,l)=m,e(k)=1;

     e(k)^e(-l);

      K
     E ^E
         L

     om(4,-2);

       4
     OM
        2
\end{verbatim}

In the current release, full simplification is performed only if an
index range is specified.  It is hoped that this restriction can be
removed soon.  If the index range (the values that the indices can
obtain) is specified, the given expression is evaluated for all
possible index values, and the summation convention is understood.

\example\label{INDEXRANGE}\index{EXCALC package ! example}

\begin{verbatim}
     indexrange t,r,ph,z;

     pform e(k)=1,s(k,l)=2;

     w := e(k)*e(-k);

              T       R        PH       Z
     W := E *E  + E *E  + E  *E   + E *E
           T       R       PH        Z


     s(k,l):=e(k)^e(l);

      T T
     S    := 0

      R T       T  R
     S    := - E ^E

      PH T       T  PH
     S     := - E ^E

       .
       .
       .

\end{verbatim}

If the expression to be evaluated is not an assignment, the values of
the expression are displayed as an assignment to an indexed variable
with name {\tt NS}.  This is done only on output, {\em i.e.} no actual
binding to the variable NS occurs.
\index{NS dummy variable}

\begin{verbatim}
     e(k)^e(l);

       T T
     NS    := 0

       R T       T  R
     NS    := - E ^E
       .
       .
       .
\end{verbatim}

It should be noted, however, that the index positions on the variable
NS can sometimes not be uniquely determined by the system (because of
possible reorderings in the expression). Generally it is advisable to
use assignments to display complicated expressions.

In certain cases, one would like to inhibit the summation over
specified index names, or at all.  For this the command

\index{NOSUM command}
\hspace*{2em} \k{NOSUM} \s{indexname$_1$}, \ldots;\label{NOSUM}

and the switch {\tt NOSUM} are \index{NOSUM switch}
available.  The command {\tt NOSUM} has the effect that summation is
not performed over those indices which had been listed.  The command
{\tt RENOSUM}\label{RENOSUM} enables summation again.  The switch {\tt
NOSUM}, if on, inhibits any summation. \index{RENOSUM command}

It is possible to declare an indexed quantity completely antisymmetric
or completely symmetric by the command

\index{ANTISYMMETRIC command}
\hspace*{2em} \k{ANTISYMMETRIC} \s{name$_1$}, \ldots;\label{ANTISYMMETRIC}

or

\index{SYMMETRIC command}
\hspace*{2em} \k{SYMMETRIC} \s{name$_1$}, \ldots;\label{SYMMETRIC}

If applicable, these commands should
be issued, since great savings in memory and execution time result.
Only strict components are printed.


\section{Metric Structures}

\index{metric structure} \index{coframe}
A metric structure is defined in {\bf EXCALC} by specifying a set of
basis one-forms (the coframe) together with the metric.

Syntax:\label{COFRAME}

\begin{tabbing}
\hspace*{2em} \k{COFRAME} \=
\s{identifier}\s{(index$_1$)}=\s{expression$_1$}, \\
\> \s{identifier}\s{(index$_2$)}=\s{expression$_2$}, \\
\> . \\
\> . \\
\> . \\
\> \s{identifier}\s{(index$_n$)}=\s{expression$_n$} \\
\> \hspace{1em} \k{WITH} \k{METRIC} \s{name}=\s{expression}; \\
\end{tabbing}

\index{euclidean metric} \index{COFRAME ! WITH METRIC}
This statement automatically sets the dimension of the space and the
index range. The clause {\tt WITH METRIC} can be omitted if the metric
\index{COFRAME ! WITH SIGNATURE}
is Euclidean and the shorthand {\tt WITH SIGNATURE \s{diagonal elements}}
\label{SIGNATURE} can be used in the case of a pseudo-Euclidean metric. The
splitting of a metric structure in its metric tensor coefficients and
basis one-forms is completely arbitrary including the extrems of an
orthonormal frame and a coordinate frame.

\example\index{EXCALC package ! example}

\begin{verbatim}
 coframe e r=d r, e(ph)=r*d ph
   with metric g=e(r)*e(r)+e(ph)*e(ph);    %Polar coframe

 coframe e(r)=d r,e(ph)=r*d(ph);           %Same as before

 coframe o(t)=d t, o x=d x
   with signature -1,1;                    %A Lorentz coframe

 coframe b(xi)=d xi, b(eta)=d eta        %A lightcone coframe
   with metric w=-1/2*(b(xi)*b(eta)+b(eta)*b(xi));

 coframe e r=d r, e ph=d ph                %Polar coordinate
   with metric g=e r*e r+r**2*e ph*e ph;   %basis

\end{verbatim}

Individual elements of the metric can be accessed just by calling them
with the desired indices. The value of the determinant of the
\index{determinant ! in DETM"!*} \ttindex{DETM"!*}
covariant metric is stored in the variable {\tt DETM!*}.  The metric
is not needed for lowering or raising of indices as the system
performs this automatically, {\em i.e.} no matter in what index
position values were assigned to an indexed quantity, the values can
be retrieved for any index position just by writing the indexed
quantity with the desired indices.

\example\index{EXCALC package ! example}

\begin{verbatim}
     coframe e t=d t,e x=d x,e y=d y
      with signature -1,1,1;

     pform f(k,l)=0;

     antisymmetric f;

     f(-t,-x):=ex$ f(-x,-y):=b$  f(-t,-y):=0$
     on nero;

     f(k,-l):=f(k,-l);

      X
     F    := - EX
        T

      T
     F    := - EX
        X

      Y
     F    := - B
        X

      X
     F    := B
        Y
\end{verbatim}

Any expression containing differentials of the coordinate functions will
be transformed into an expression of the basis one-forms.The system also
knows how to take the exterior derivative of the basis one-forms.

\index{spherical coordinates}
\example (Spherical coordinates)\index{EXCALC package ! example}

\begin{verbatim}
     coframe e(r)=d(r), e(th)=r*d(th), e(ph)=r*sin(th)*d(ph);

     d r^d th;

       R  TH
     (E ^E  )/R

     d(e(th));

       R  TH
     (E ^E  )/R


     pform f=0;

     fdomain f=f(r,th,ph);

     factor e;

     on rat;

     d f;       %The "gradient" of F in spherical coordinates;

      R          TH              PH
     E *@  F + (E  *@   F)/R + (E  *@   F)/(R*SIN(TH))
         R           TH              PH
\end{verbatim}

The frame dual to the frame defined by the {\tt COFRAME} command can
be introduced by \k{FRAME} command. \index{FRAME command}

\hspace*{2em} \k{FRAME} \s{identifier};\label{FRAME}

This command causes the
dual property to be recognized, and the tangent vectors of the
coordinate functions are replaced by the frame basis vectors.

\example\index{EXCALC package ! example}

\begin{verbatim}
   coframe b r=d r,b ph=r*d ph,e z=d z; %Cylindrical coframe;

   frame x;

   on nero;

   x(-k)_|b(l);

       R
   NS    := 1
     R

        PH
   NS      := 1
     PH

       Z
   NS    := 1
     Z

   x(-k) |_ x(-l);       %The commutator of the dual frame;


   NS     := X  /R
     PH R     PH


   NS     := ( - X  )/R  %i.e. it is not a coordinate base;
     R PH         PH

\end{verbatim}

\index{DISPLAYFRAME command} \index{tracing ! EXCALC}
As a convenience, the frames can be displayed at any point in a program
by the command {\tt DISPLAYFRAME;}\label{DISPLAYFRAME}.

\index{Hodge-* duality operator}
The Hodge-* duality operator returns the explicitly constructed dual
element if applied to coframe base elements. The metric is properly
taken into account.

\index{Levi-Cevita tensor} \ttindex{EPS}
The total antisymmetric Levi-Cevita tensor {\tt EPS}\label{EPS} is
also available.  The value of {\tt EPS} with an even permutation of the
indices in a covariant position is taken to be +1.


\section{Riemannian Connections}

\index{Riemannian Connections}
The command {\tt RIEMANNCONX} is provided for calculating the
\index{RIEMANNCONX command} \label{RIEMANNCONX}
connection 1 forms.  The values are stored on the name given to {\tt
RIEMANNCONX}.  This command is far more efficient than calculating the
connection from the differential of the basis one-forms and using
inner products.

\example (Calculate the connection 1-form and curvature 2-form on S(2))
\index{EXCALC package ! example}

\begin{verbatim}
   coframe e th=r*d th,e ph=r*sin(th)*d ph;

   riemannconx om;

   om(k,-l);                 %Display the connection forms;

     TH
   NS      := 0
        TH

     PH         PH
   NS      := (E  *COS(TH))/(SIN(TH)*R)
        TH

     TH            PH
   NS      := ( - E  *COS(TH))/(SIN(TH)*R)
        PH

     PH
   NS      := 0
        PH

   pform curv(k,l)=2;


   curv(k,-l):=d om(k,-l) + om(k,-m)^om(m-l);
                 %The curvature forms

       TH
   CURV      := 0
          TH

       PH            TH  PH   2
   CURV      := ( - E  ^E  )/R  
          TH               %Of course it was a sphere with
                           %radius R.

       TH         TH  PH   2
   CURV      := (E  ^E  )/R
          PH

       PH
   CURV      := 0
          PH
\end{verbatim}

\section{Ordering and Structuring}

\index{ordering ! exterior form} \index{FORDER command}
The ordering of an exterior form or vector can be changed by the
command {\tt FORDER}.\label{FORDER}  In an expression, the first
identifier or kernel in the arguments of {\tt FORDER} is ordered ahead
of the second, and so on, and ordered ahead of all not appearing as
arguments.  This ordering is done on the internal level and not only
on output.  The execution of this statement can therefore have
tremendous effects on computation time and memory requirements.  {\tt
REMFORDER}\label{REMFORDER} brings back standard ordering for those
elements that are listed as arguments. \index{REMFORDER command}


\index{ISOLATE command}
Another ordering command is {\tt ISOLATE}.\label{ISOLATE} It takes one
argument. The system attempts to shift out this identifier or kernel
to the leftmost position, utilizing commutation and derivative rules.
{\tt REMISOLATE} restores normal ordering.
\index{REMISOLATE command}\label{REMISOLATE}

\example\index{EXCALC package ! example}

\begin{verbatim}
     pform u=k,v=l,w=m;

     u^d(v)^w;

     U^d V^W

     forder v;

     u^d(v)^w;

           (K*L + K)
     ( - 1)         *d V^U^W

     isolate v;

     u^d(v);

           (K*L + K)                 L
     ( - 1)         *(d(V^U) - ( - 1) *V^d U)
\end{verbatim}

An expression can be put in a more structured form by renaming a
subexpression.  This is done with the command {\tt KEEP} which
has the syntax \index{KEEP command}\label{KEEP}

\hspace*{2em} \k{KEEP}
\s{name$_1$}=\s{expression$_1$},\s{name$_2$}=\s{expression$_2$}, \ldots

The effect is that rules are set up for simplifying \s{name} without
introducing its definition in an expression. In an expression the system
also tries by reordering to generate as many instances of \s{name} as
possible.

\example\index{EXCALC package ! example}

\begin{verbatim}
     pform x=0,y=0,z=0,f=0,j=3;

     keep j=d x^d y^d z;

     j;

     J

     d j;

     0

     j^d x;

     0

     fdomain f=f(x);

     d f^d y^d z;

     @  F*J
      X
\end{verbatim}

\index{exterior product}
The capabilities of {\tt KEEP} are currently very limited.  Only exterior
products should occur as righthand sides in {\tt KEEP}.


\section{Summary of Operators and Commands}
Table~\ref{EXCALC:sum} summarizes EXCALC commands and the page number they are
defined on.

\begin{table}
\begin{tabular}{l l r}
\index{"\^{} ! exterior multiplication} \index{wedge}
\^{ }  &  Exterior Multiplication & \pageref{wedge} \\
\index{"@ ! partial differentiation}
@  & Partial Differentiation & \pageref{at}  \\
\index{"@ ! tangent vector}
@  & Tangent Vector  & \pageref{at1}  \\
\index{"\# ! Hodge-* operator}
\#  & Hodge-* Operator & \pageref{hodge} \\
\index{\_$\mid$ operator}
\_$|$  & Inner Product  & \pageref{innerp} \\
\index{$\mid$\_ operator}
$|$\_  & Lie Derivative  & \pageref{lie}  \\
\index{ANTISYMMETRIC command}
ANTISYMMETRIC & Declares completely antisymmetric & \pageref{ANTISYMMETRIC} \\
  & indexed quantities & \\
\index{COFRAME command}
COFRAME & Declaration of a coframe & \pageref{COFRAME} \\
\index{d ! exterior differentiation}
d &  Exterior differentiation & \pageref{d} \\
\index{DISPLAYFRAME command}
DISPLAYFRAME & Displays the frame & \pageref{DISPLAYFRAME}\\
\index{EPS ! Levi-Civita tensor}
EPS & Levi-Civita tensor  & \pageref{EPS}  \\
\index{FDOMAIN command}
FDOMAIN & Declaration of implicit dependencies &\pageref{FDOMAIN} \\
\index{FORDER command}
FORDER & Ordering command  & \pageref{FORDER} \\
\index{FRAME command}
FRAME & Declares the frame dual to the coframe & \pageref{FRAME} \\
\index{INDEXRANGE command}
INDEXRANGE & Declaration of indices & \pageref{INDEXRANGE} \\
\index{ISOLATE command}
ISOLATE & Ordering command  & \pageref{ISOLATE} \\
\index{KEEP command}
KEEP & Structuring command  & \pageref{KEEP} \\
\index{METRIC command}
METRIC & Clause of COFRAME to specify a metric & \pageref{COFRAME} \\
\index{NOETHER function}
NOETHER & Calculates the Noether current & \pageref{NOETHER} \\
\index{NOSUM command}
NOSUM & Inhibits summation convention & \pageref{NOSUM} \\
\index{NOXPND command}
NOXPND d & Inhibits the use of product rule for d &
\pageref{NOXPNDD} \\
\index{NOXPND "@ command}
NOXPND @ & Inhibits expansion into partial derivatives &
\pageref{NOXPNDA} \\
\index{PFORM command}
PFORM & Declaration of exterior forms & \pageref{PFORM} \\
\index{REMFORDER command}
REMFORDER & Clears ordering  & \pageref{REMFORDER} \\
\index{REMISOLATE command}
REMISOLATE & Clears ISOLATE command & \pageref{REMISOLATE} \\
\index{RENOSUM command}
RENOSUM & Enables summation convention & \pageref{RENOSUM} \\
\index{RIEMANNCONX command}
RIEMANNCONX & Calculation of a Riemannian Connection &
\pageref{RIEMANNCONX} \\
\index{SIGNATURE command}
SIGNATURE & Clause of COFRAME to specify a pseudo- & \pageref{SIGNATURE} \\
  & Euclidean metric &   \\
\index{SPACEDIM command}
SPACEDIM & Command to set the dimension of a space &
\pageref{SPACEDIM} \\
\index{SYMMETRIC command}
SYMMETRIC & Declares completely symmetric indexed & \pageref{SYMMETRIC} \\
  & quantities  &   \\
\index{TVECTOR command}
TVECTOR & Declaration of vectors  & \pageref{TVECTOR} \\
\ttindex{VARDF}
VARDF & Variational derivative  & \pageref{VARDF} \\
\index{XPND command}
XPND d & Enables the use of product rule for d & \pageref{XPNDD} \\
  & (default)  &   \\
\index{XPND ! "@}
XPND @ & Enables expansion into partial derivatives & \pageref{XPNDA} \\
  & (default)   
\end{tabular}
\caption{EXCALC Command Summary}\label{EXCALC:sum}
\end{table}
\newpage
\section{Examples}

The following examples should illustrate the use of {\bf EXCALC}. It is not
intended to show the most efficient or most elegant way of stating the
problems; rather the variety of syntactic constructs are exemplified.
The examples are on a test file distributed with {\bf EXCALC}.
\index{EXCALC package ! example}
{\small
\begin{verbatim}

% Problem: Calculate the PDE's for the isovector of the heat
% equation.
% --------
%  (c.f. B.K. Harrison, f.B. Estabrook, "Geometric Approach...",
%   J. Math. Phys. 12, 653, 1971);

%The heat equation @   psi = @  psi is equivalent to the set of 
%                   xx        t

%exterior equations (with u=@ psi, y=@ psi):
%                            T        x


pform psi=0,u=0,x=0,y=0,t=0,a=1,da=2,b=2;

a:=d psi - u*d t - y*d x;

da:=- d u^d t - d y^d x;

b:=u*d x^d t - d y^d t;


%Now calculate the PDE's for the isovector;

tvector v;

pform vpsi=0,vt=0,vu=0,vx=0,vy=0;
fdomain vpsi=vpsi(psi,t,u,x,y),vt=vt(psi,t,u,x,y),
                               vu=vu(psi,t,u,x,y),
                               vx=vx(psi,t,u,x,y),
                               vy=vy(psi,t,u,x,y);

v:=vpsi*@ psi + vt*@ t + vu*@ u + vx*@ x + vy*@ y;


factor d;
on rat;

i1:=v |_ a - l*a;

pform o=1;

o:=ot*d t + ox*d x + ou*d u + oy*d y;

fdomain f=f(psi,t,u,x,y);

i11:=v_|d a - l*a + d f;

let vx=-@(f,y),vt=-@(f,u),vu=@(f,t)+u*@(f,psi),vy=@(f,x)+y*@(f,psi),
    vpsi=f-u*@(f,u)-y*@(f,y);

factor ^;

i2:=v |_ b - xi*b - o^a + zet*da;

let ou=0,oy=@(f,u,psi),ox=-u*@(f,u,psi),
    ot=@(f,x,psi)+u*@(f,y,psi)+y*@(f,psi,psi);

i2;

let zet=-@(f,u,x)-@(f,u,y)*u-@(f,u,psi)*y;

i2;

let xi=-@(f,t,u)-u*@(f,u,psi)+@(f,x,y)+u*@(f,y,y)+
                 y*@(f,y,psi)+@(f,psi);

i2;

let @(f,u,u)=0;

i2;      % These PDE's have to be solved;


clear a,da,b,v,i1,i11,o,i2,xi,t;
remfdomain f;
clear @(f,u,u);


%Problem:
%--------
%Calculate the integrability conditions for the system of PDE's:
%(c.f. B.F. Schutz, "Geometrical Methods of Mathematical Physics"
%Cambridge University Press, 1984, p. 156)


% @ z /@ x + a1*z  + b1*z  = c1
%    1           1       2

% @ z /@ y + a2*z  + b2*z  = c2
%    1           1       2

% @ z /@ x + f1*z  + g1*z  = h1
%    2           1       2

% @ z /@ y + f2*z  + g2*z  = h2
%    2           1       2      ;


pform w(k)=1,integ(k)=4,z(k)=0,x=0,y=0,a=1,b=1,c=1,f=1,g=1,h=1,
      a1=0,a2=0,b1=0,b2=0,c1=0,c2=0,f1=0,f2=0,g1=0,g2=0,h1=0,h2=0;

fdomain  a1=a1(x,y),a2=a2(x,y),b1=b1(x,y),b2=b2(x,y),
         c1=c1(x,y),c2=c2(x,y),f1=f1(x,y),f2=f2(x,y),
         g1=g1(x,y),g2=g2(x,y),h1=h1(x,y),h2=h2(x,y);


a:=a1*d x+a2*d y$
b:=b1*d x+b2*d y$
c:=c1*d x+c2*d y$
f:=f1*d x+f2*d y$
g:=g1*d x+g2*d y$
h:=h1*d x+h2*d y$

%The equivalent exterior system:;
factor d;
w(1) := d z(-1) + z(-1)*a + z(-2)*b - c;
w(2) := d z(-2) + z(-1)*f + z(-2)*g - h;
indexrange 1,2;
factor z;
%The integrability conditions:;

integ(k) := d w(k) ^ w(1) ^ w(2);

clear a,b,c,f,g,h,w(k),integ(k);

%Problem:
%--------
%Calculate the PDE's for the generators of the d-theta symmetries of
%the Lagrangian system of the planar Kepler problem.
%c.f. W.Sarlet, F.Cantrijn, Siam Review 23, 467, 1981;
%Verify that time translation is a d-theta symmetry and 
%calculate the corresponding integral;

pform t=0,q(k)=0,v(k)=0,lam(k)=0,tau=0,xi(k)=0,et(k)=0,theta=1,f=0,
      l=0,glq(k)=0,glv(k)=0,glt=0;

tvector gam,y;

indexrange 1,2;

fdomain tau=tau(t,q(k),v(k)),xi=xi(t,q(k),v(k)),f=f(t,q(k),v(k));

l:=1/2*(v(1)**2+v(2)**2)+m/r$      %The Lagrangian;

pform r=0;
fdomain r=r(q(k));
let @(r,q 1)=q(1)/r,@(r,q 2)=q(2)/r,q(1)**2+q(2)**2=r**2;

lam(k):=-m*q(k)/r;                              %The force;

gam:=@ t + v(k)*@(q(k)) + lam(k)*@(v(k))$

et(k) := gam _| d xi(k) - v(k)*gam _| d tau$

y  :=tau*@ t + xi(k)*@(q(k)) + et(k)*@(v(k))$   %Symmetry generator;

theta := l*d t + @(l,v(k))*(d q(k) - v(k)*d t)$

factor @;

s := y |_ theta - d f$

glq(k):=@(q k)_|s;
glv(k):=@(v k)_|s;
glt:=@(t)_|s;

%Translation in time must generate a symmetry;
xi(k) := 0;
tau := 1;

glq k;
glv k;
glt;

%The corresponding integral is of course the energy;
integ := - y _| theta;


clear l,lam k,gam,et k,y,theta,s,glq k,glv k,glt,t,q k,v k,tau,xi k;
remfdomain r,f;

%Problem:
%--------
%Calculate the "gradient" and "Laplacian" of a function and the
%"curl" and "divergence" of a one-form in elliptic coordinates;


coframe e u=sqrt(cosh(v)**2-sin(u)**2)*d u,
        e v=sqrt(cosh(v)**2-sin(u)**2)*d v,
        e ph=cos u*sinh v*d ph;

pform f=0;

fdomain f=f(u,v,ph);

factor e,^;
on rat,gcd;
order cosh v, sin u;
%The gradient:;
d f;

factor @;
%The Laplacian:;
# d # d f;

%Another way of calculating the Laplacian:
-#vardf(1/2*d f^#d f,f);

remfac @;

%Now calculate the "curl" and the "divergence" of a one-form:

pform w=1,a(k)=0;

fdomain a=a(u,v,ph);

w:=a(-k)*e k;
%The curl:
x := # d w;

factor @;
%The divergence;
y := # d # w;

remfac @;
clear x,y,w,u,v,ph,e k,a k;
remfdomain a,f;


%Problem:
%--------
%Calculate in a spherical coordinate system the Navier Stokes 
%equations;

coframe e r=d r,e th=r*d th,e ph=r*sin th*d ph;
frame x;

fdomain v=v(t,r,th,ph),p=p(r,th,ph);

pform v(k)=0,p=0,w=1;

%We first calculate the convective derivative;

w := v(-k)*e(k)$

factor e; on rat;

cdv := @(w,t) + (v(k)*x(-k)) |_ w - 1/2*d(v(k)*v(-k));

%next we calculate the viscous terms;

visc := nu*(d#d# w - #d#d w) + nus*d#d# w;

%finally we add the pressure term and print the components of the
%whole equation;

pform nasteq=1,nast(k)=0;

nasteq := cdv - visc + 1/rho*d p$

factor @;

nast(-k) := x(-k) _| nasteq;

remfac @,e;

clear v k,x k,nast k,cdv,visc,p,w,nasteq;
remfdomain p,v;


%Problem:
%--------
%Calculate from the Lagrangian of a vibrating rod the equation of
% motion and show that the invariance under time translation leads
% to a conserved current;

pform y=0,x=0,t=0,q=0,j=0,lagr=2;

fdomain y=y(x,t),q=q(x),j=j(x);

factor ^;

lagr:=1/2*(rho*q*@(y,t)**2-e*j*@(y,x,x)**2)*d x^d t;

vardf(lagr,y);

%The Lagrangian does not explicitly depend on time; therefore the
%vector field @ t generates a symmetry. The conserved current is

pform c=1;
factor d;

c := noether(lagr,y,@ t);

%The exterior derivative of this must be zero or a multiple of the
%equation of motion (weak conservation law) to be a conserved
%current;

remfac d;

d c;

%i.e. it is a multiple of the equation of motion;

clear lagr,c;


%Problem:
%--------
%Show that the metric structure given by Eguchi and Hanson induces a
%self-dual curvature.
%c.f. T. Eguchi, P.B. Gilkey, A.J. Hanson, "Gravitation, Gauge 
%Theories and Differential Geometry", Physics Reports 66, 213, 1980;

for all x let cos(x)**2=1-sin(x)**2;

pform f=0,g=0;

fdomain f=f(r), g=g(r);

coframe   o(r) =f*d r,
      o(theta) =(r/2)*(sin(psi)*d theta-sin(theta)*cos(psi)*d phi),
        o(phi) =(r/2)*(-cos(psi)*d theta-sin(theta)*sin(psi)*d phi),
        o(psi) =(r/2)*g*(d psi+cos(theta)*d phi);

frame e;


pform gamma1(a,b)=1,curv2(a,b)=2;
antisymmetric gamma1,curv2;

factor o;

gamma1(-a,-b):=-(1/2)*( e(-a)_|(e(-c)_|(d o(-b)))
                       -e(-b)_|(e(-a)_|(d o(-c)))
                       +e(-c)_|(e(-b)_|(d o(-a))) )*o(c)$


curv2(-a,b):=d gamma1(-a,b) + gamma1(-c,b)^gamma1(-a,c)$

factor ^;

curv2(a,b):= curv2(a,b)$

let f=1/g;
let g=sqrt(1-(a/r)**4);
pform chck(k,l)=2;
antisymmetric chck;
%The following has to be zero for a self-dual curvature;

chck(k,l):=1/2*eps(k,l,m,n)*curv2(-m,-n)+curv2(k,l);

clear gamma1(a,b),curv2(a,b),f,g,chck(a,b),o(k),e(k);
remfdomain f,g;

%Problem:
%--------
%Calculate for a given coframe and given torsion the Riemannian 
%part and the torsion induced part of the connection. Calculate 
%the curvature.

%For a more elaborate example: E.Schruefer, F.W. Hehl, J.D. McCrea,
%"Exterior Calculus on the Computer: The REDUCE-Package EXCALC 
%Applied to General Relativity and to the Poincare Gauge Theory",
%GRG, vol. 19, 1987, pp. 197-218

pform ff=0, gg=0;

fdomain ff=ff(r), gg=gg(r);

coframe o(4)=d u+2*b0*cos(theta)*d phi,
        o(1)=ff*(d u+2*b0*cos(theta)*d phi)+ d r,
        o(2)=gg*d theta,
        o(3)=gg*sin(theta)*d phi
 with metric g=-o(4)*o(1)-o(4)*o(1)+o(2)*o(2)+o(3)*o(3);

frame e;

pform tor(a)=2,gwt(a)=2,gam(a,b)=1,
      u1=0,u3=0,u5=0;

antisymmetric gam;

fdomain u1=u1(r),u3=u3(r),u5=u5(r);

tor(4):=0$

tor(1):=-u5*o(4)^o(1)-2*u3*o(2)^o(3)$

tor(2):=u1*o(4)^o(2)+u3*o(4)^o(3)$

tor(3):=u1*o(4)^o(3)-u3*o(4)^o(2)$

gwt(-a):=d o(-a)-tor(-a)$

%The following is the combined connection;
%The Riemannian part could have equally well been calculated by the
%RIEMANNCONX statement;

gam(-a,-b):=(1/2)*( e(-b)_|(e(-c)_|gwt(-a))
                   +e(-c)_|(e(-a)_|gwt(-b))
                   -e(-a)_|(e(-b)_|gwt(-c)) )*o(c);

pform curv(a,b)=2;
antisymmetric curv;
factor ^;

curv(-a,b):=d gam(-a,b) + gam(-c,b)^gam(-a,c);



showtime;
end;

\end{verbatim}
}
\end{document}

Added r34.1/doc/gentran.bib version [b1776c7307].











































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
@BOOK{FORTRAN,
  KEY = "American National Standards Institute",
  TITLE = "American National Standard Programming Language {FORTRAN}",
  PUBLISHER = "American National Standards Institute",
  SERIES = "{ANS X3.9}",
  ADDRESS = "New York",
  YEAR = 1978}

@INPROCEEDINGS{Gates:84,
  AUTHOR = "Barbara L. Gates and Paul S. Wang",
  TITLE = "A {LISP}-Based {RATFOR} Code Generator",
  BOOKTITLE = "Proceedings of the 1984 {MACSYMA} User's Conference",
  ADDRESS = "Schenectady, New York", MONTH = "July", YEAR = 1984}

@INPROCEEDINGS{Gates:85,
 AUTHOR = "Barbara L. Gates and J. A. van Hulzen",
 TITLE = "Automatic Generation of Optimized Programs",
 BOOKTITLE = "Proc. {EUROCAL} '85", YEAR = 1985,
 MONTH = "April"}

@ARTICLE{Gates:85a,
 AUTHOR = "Barbara L. Gates",
 TITLE = "Gentran:  An Automatic Code Generation Facility
for {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "24-42", MONTH = "August"}

@TECHREPORT{Gates:85b,
 AUTHOR = "Barbara L. Gates",
 TITLE = "Gentran User's Manual - {REDUCE} Version",
 INSTITUTION = "Twente University of Technology, Department of
Computer Science, The Netherlands", TYPE = "Memorandum",
 YEAR = 1985, NUMBER = "INF-85-11", MONTH = "June"}

@INPROCEEDINGS{Gates:86,
 AUTHOR = "Barbara L. Gates",
 TITLE = "A Numerical Code Generation Facility for {REDUCE}",
 BOOKTITLE = "Proc. {SYMSAC} '86",
 YEAR = 1986, PAGES = "94-99", MONTH = "July"}

@MANUAL{Kernighan:79,
  AUTHOR = "B. W. Kernighan",
  TITLE = "{RATFOR} -- A Preprocessor for a Rational Fortran",
  SERIES = "{UNIX} Programmer's Manual",
  VOLUME = "2B", EDITION = "Seventh",
  PUBLISHER = "Bell Telephone Laboratories, Inc.",
  ADDRESS = "Murray Hill, New Jersey",
  YEAR = 1979}

@BOOK{Kernighan:78,
  AUTHOR = "B. W. Kernighan and Dennis M. Ritchie",
  TITLE = "The {C} Programming Language",
  PUBLISHER = "Prentice-Hall",
  ADDRESS = "Englewood Cliffs, New Jersey",
  YEAR = 1978}

@ARTICLE{Wang:86,
  AUTHOR = "Payl S. Wang",
  TITLE = "{FINGER}:  A Symbolic System for Automatic Generation of
Numerical Programs in Finite Element Analysis",
  JOURNAL = "Journal of Symbolic Computation",
  VOLUME = 2, YEAR = 1986}

@MASTERSTHESIS{vandenHeuvel:86ms,
  AUTHOR = "Pim van den Heuvel",
  TITLE = "Aspects of Program Generation Related to Automatic
Differentiation",
  SCHOOL = "Twente University of Technology",
  ADDRESS = "Department of Computer Science, Enschede, The Netherlands",
  MONTH = "December", YEAR = 1986}

@INPROCEEDINGS{vanHulzen:89,
 AUTHOR = "J. A. van Hulzen and B. J. A. Hulshof and B. L. Gates and
M. C. Van Heerwaarden",
 TITLE = "A Code Optimization Package for {REDUCE}",
 BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York",
 YEAR = 1989, PAGES = "163-170",
 COMMENT = {Lecture Notes.}}

@INPROCEEDINGS{Wang:84,
  AUTHOR = "Paul S. Wang and T. Y. P. Chang and J. A. van Hulzen",
  TITLE = "Code Generation and Optimization for Finite Element Analysis",
  BOOKTITLE = "{EUROSAM} '84 Conference Proceedings",
  PUBLISHER = "Springer-Verlag", SERIES = "{LNCS} Series", YEAR = 1984}

Added r34.1/doc/gentran.tex version [1addc37c21].





























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
\documentstyle[11pt,reduce]{article}
\title{GENTRAN User's Manual \\ REDUCE Version}
\date{}
\author{Barbara L. Gates \\ RAND \\
Santa Monica CA 90407-2138 \\[0.05in]
{\em Updated for {\REDUCE} 3.4 by} \\[0.05in]
Michael C. Dewar \\
The University of Bath \\
Email: mcd@maths.bath.ac.uk}
\begin{document}
\maketitle

\index{GENTRAN ! package} \index{GENTRAN package !}

\begin{center} February 1991 \end{center}

GENTRAN is an automatic code GENerator and TRANslator which runs under
REDUCE and VAXIMA\index{VAXIMA}.  It constructs complete numerical
programs based on sets of algorithmic specifications and symbolic
expressions.  Formatted FORTRAN, RATFOR or C code can be generated
through a series of interactive commands or under the control of a
template processing routine.  Large expressions can be automatically
segmented into subexpressions of manageable size, and a special
file-handling mechanism maintains stacks of open I/O channels to allow
output to be sent to any number of files simultaneously and to
facilitate recursive invocation of the whole code generation process.
GENTRAN provides the flexibility necessary to handle most code
generation applications.  This manual describes usage of the GENTRAN
package for REDUCE.

\subsection*{Acknowledgements}

The GENTRAN package was created at Kent State University to generate
numerical code for computations in finite element analysis.  I would
like to thank Prof. Paul Wang for his guidance and many suggestions
used in designing the original package for VAXIMA.

The second version of GENTRAN was implemented at Twente University of
Technology to run under REDUCE.  It was designed to be interfaced with
a code optimization facility created by Dr. J. A. van Hulzen.  I would
like to thank Dr. van Hulzen for all of his help in the implementation
of GENTRAN in RLISP during a stay at his university in The
Netherlands.

Finally, I would like to thank Dr. Anthony Hearn of the RAND
Corporation for his help in better integrating GENTRAN into the REDUCE
environment.

\section{INTRODUCTION}

Solving a problem in science or engineering is often a two-step
process.  First the problem is modeled mathematically and derived
symbolically to provide a set of formulas which describe how to solve
the problem numerically.  Next numerical programs are written based on
this set of formulas to efficiently compute specific values for given
sets of input.  Computer algebra systems such as REDUCE
provide powerful tools for use in the formula-derivation phase but
only provide primitive program-coding tools.  The GENTRAN 
package~\cite{Gates:85,Gates:85a,Gates:85b,Gates:86}
has been constructed to automate the tedious,
time consuming and error-prone task of writing numerical programs
based on a set of symbolic expressions.

\subsection{The GENTRAN Code Generator and Translator}
The GENTRAN code GENeration and TRANslation package, originally
implemented in Franz LISP to run under VAXIMA~\cite{Gates:84}, is now also
implemented in RLISP to run under REDUCE.  Although GENTRAN
was originally created specifically to generate numerical
code for use with an existing FORTRAN-based finite element analysis
package~\cite{Wang:86,Wang:84}, it was designed
to provide the flexibility required to handle most code generation
applications.  GENTRAN contains code generation commands, file-handling
commands, mode switches, and global variables, all of which are
accessible from both the algebraic and symbolic modes of REDUCE to
give the user maximal control over the code generation process.  Formatted
\index{FORTRAN} \index{RATFOR} \index{C}
FORTRAN~\cite{FORTRAN}, RATFOR~\cite{Kernighan:79}, C~\cite{Kernighan:78},
or PASCAL code can be generated from algorithmic specifications,
i.e., descriptions of the behaviour of the target numerical program expressed
in the REDUCE programming language, and from symbolically derived expressions
and formulas.

In addition to arithmetic expressions and assignment statements,
GENTRAN can also generate type declarations and control-flow
structures.  Code generation can be guided by user-supplied
template file(s) to insert generated code into pre-existing program
skeletons, or it can be accomplished interactively through a series
of translation commands without the use of template files.  Special
mode switches enable the user to turn on or off specific features such as
automatic segmentation of large expressions, and global variables
allow the user to modify the code formatting process.  Generated
code can be sent to one or more files and, optionally, to
the user's terminal.  Stacks of open I/O channels facilitate temporary
output redirection and recursive invocation of the code generation process.

\subsection{Code Optimization}
\index{optimization, code}
A code optimizer~\cite{vanHulzen:89}, which runs under REDUCE, has
been constructed to reduce the arithmetic complexity of a set of
symbolic expressions (see the SCOPE package on
page~\pageref{SCOPE:intro}).  It optimizes them by extracting common
subexpressions and assigning them to temporary variables which are
inserted in their places.  The optimization technique is based on
mapping the expressions onto a matrix of coefficients and exponents
which are searched for patterns corresponding to the common
subexpressions.  Due to this process the size of the expressions is
often considerably reduced.

GENTRAN and the Code Optimizer have been interfaced to make it
possible to generate optimized numerical programs directly
\index{GENTRANOPT switch} from REDUCE.  Setting the switch {\tt
GENTRANOPT} {\bf ON} specifies that all sequences of assignment
statements are to be optimized before being converted to numerical
code.

\subsection{Organization of the Manual}
The remainder of this manual is divided into five sections.  Sections
\ref{GENTRAN:inter} and \ref{GENTRAN:template} describe code
generation.  Section \ref{GENTRAN:inter} explains interactive code
generation, the expression segmentation facility, and how temporary
variables can be generated; then section \ref{GENTRAN:template}
explains how code generation can be guided by a user-supplied template
file.  Section \ref{GENTRAN:output} describes methods of output
redirection, and section \ref{GENTRAN:mod} describes user-accessible
global variables and mode switches which alter the code generation
process.  Finally section \ref{GENTRAN:examples} presents three
complete examples.

\subsubsection{Typographic Conventions}
The following conventions are used in the syntactic definitions of
commands in this manual:
\begin{itemize}
\item[{-}]
Command parts which must be typed exactly as shown are given in 
{\bf BOLD PRINT}.
\item[{-}]
User-supplied arguments are {\it emphasized}.
\item[{-}]
[ ... ] indicate optional command parts.
\end{itemize}
The syntax of each GENTRAN command is shown terminated with a {\bf ;}.
However, either {\bf ;} or {\bf \$} can be used to terminate any
command with the usual REDUCE meaning:  {\bf ;} indicates that the
returned value is to be printed, while {\bf \$} indicates that printing
of the returned value is to be suppressed.

Throughout this manual it is stated that file name arguments must be
atoms.  The exact type of atom (e.g., identifier or string) is
system and/or site dependent.  The instructions for the implementation
being used should therefore be consulted.

\section{Interactive Code Generation}\label{GENTRAN:inter}
GENTRAN generates numerical programs based on algorithmic specifications
in the REDUCE programming language and derived symbolic expressions
\index{FORTRAN} \index{RATFOR} \index{PASCAL} \index{C}
produced by REDUCE evaluations.  FORTRAN, RATFOR, PASCAL or C code can
be produced.  Type declarations can be generated, and comments and
other literal strings can be inserted into the generated code.  In
addition, large arithmetic expressions can be automatically segmented
into a sequence of subexpressions of manageable size.

This section explains how to select the target language, generate
code, control expression segmentation, and how to generate temporary
variable names.

\subsection{Target Language Selection}
\label{gentranlang}
Before generating code, the target numerical language must be
selected.  GENTRAN is currently able to generate FORTRAN, RATFOR,
PASCAL and C \ttindex{GENTRANLANG"!*} code.  The global variable {\bf
GENTRANLANG!*} determines which type of code is produced.  {\bf
GENTRANLANG!*} can be set in algebraic or symbolic mode.  It can be
set to any value, but only four atoms have special meaning: {\bf
FORTRAN}, {\bf RATFOR}, {\bf PASCAL} and {\bf C}.  Any other value is
assumed to mean {\bf FORTRAN}.  {\bf GENTRANLANG!*} is always
initialized to {\bf FORTRAN}.


\subsection{Translation}
\label{translation}
\index{GENTRAN ! command}
The {\bf GENTRAN} (GENerate/TRANslate) command is used to generate
numerical code and also to translate code from algorithmic
specifications in the REDUCE programming language to code in the
target numerical language.  Section~\ref{generation} explains code
{\em generation}.  This section explains code {\em translation}.

A substantial subset of all expressions and statements in the REDUCE
programming language can be translated directly into numerical code.
The {\bf GENTRAN} command takes a REDUCE expression, statement, or
procedure definition, and translates it into code in the target
language.

\begin{describe}{Syntax:}
{\bf GENTRAN} {\it stmt} [ {\bf OUT} {\it f1,f2,\dots\  ,fn} ]{\it ;}
\end{describe}

\begin{describe}{Arguments:}
{\it stmt} is any REDUCE expression, statement (simple, compound, or
group), or procedure definition that can be translated by GENTRAN into the
target language\footnote{See~\ref{appa} for a complete listing of REDUCE
expressions and statements that can be translated.}
{\it stmt} may contain any number of calls
to the special functions {\bf EVAL}, {\bf DECLARE}, and {\bf LITERAL}
(see sections~\ref{translation}~--~\ref{comments}).

{\it f1,f2,\dots\  ,fn } is an optional argument list containing one or more
{\it f}'s, where each {\it f} is one of:
\par
\begin{tabular}{lll}
{\it an atom} &= &an output file\\
{\bf T} &= &the terminal\\
{\bf NIL} &= &the current output file(s)\\
\ttindex{ALL"!*} {\bf ALL!*} &= &all files currently open for output \\
& & by GENTRAN (see section~\ref{GENTRAN:output})\\
\end{tabular}
\end{describe}
\index{side effects}
\begin{describe}{Side Effects:}
{\bf GENTRAN} translates {\it stmt} into formatted code in the target language.

If the optional part of the command is not given, generated code is simply
written to the current output file.  However, if it is
given, then the current output file is temporarily overridden.  Generated
code is written to each file represented by 
{\it f1,f2,\dots\  ,fn} for this command only.  Files which were open prior
to the call to {\bf GENTRAN} will remain open after the call, and files
which did not exist prior to the call will be created, opened, written to,
and closed.  The output stack will be exactly the same both before and
after the call.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRAN}  returns the name(s) of the file(s) to which code was written.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS
    OVERWRITE FILE? (Y/N)
\end{verbatim}
\begin{verbatim}
***** WRONG TYPE OF ARG
\end{verbatim}
exp
\begin{verbatim}
***** CANNOT BE TRANSLATED
\end{verbatim}
\end{describe}
\begin{describe}{\example\footnote{When the {\bf PERIOD} flag (default
setting: ON) is turned on, all \ttindex{PERIOD}
integers are automatically printed as real numbers except exponents,
subscripts in subscripted variables, and index values in DO-type loops.}}
\index{GENTRAN package ! example}
\begin{verbatim}
1: GENTRANLANG!* := 'FORTRAN$

2: GENTRAN
2:     FOR I:=1:N DO
2:         V(I) := 0$

      DO 25001 I=1,N
          V(I)=0.0
25001 CONTINUE

3: GENTRANLANG!* := 'RATFOR$ 

4: GENTRAN 
4:      FOR I:=1:N DO 
4:          FOR J:=I+1:N DO 
4:          << 
4:              X(J,I) := X(I,J); 
4:              Y(J,I) := Y(I,J) 
4:          >>$ 

DO I=1,N
    DO J=I+1,N
    {
        X(J,I)=X(I,J)
        Y(J,I)=Y(I,J)
    }

5: GENTRANLANG!* := 'C$ 

6: GENTRAN 
6:      P := FOR I:=1:N PRODUCT I$ 

{
    P=1;
    for (I=1;I<=N;++I)
        P*=I;
}

7: GENTRANLANG!* := 'PASCAL$

8: GENTRAN
8:     S := FOR I := 1:10 SUM V(I)$
BEGIN
    S:=0;
    FOR I:=1 TO 10 DO
        S:=S+V(I)
END;
\end{verbatim}
\end{describe}


\index{numeric code} Translation is a convenient method of producing
numerical code when the exact behaviour of the resultant code is
known.  It gives the REDUCE user who is familiar with the syntax of
statements in the REDUCE programming language the ability to write
code in a numerical programming language without knowing the exact
syntactical requirements of the language.  However the {\em real}
power of the {\bf GENTRAN} command lies in its ability to generate
code: it can produce numerical code from symbolic expressions derived
in REDUCE in addition to translating statements directly.  This aspect
is described in section~\ref{generation}.

\subsection{Precision}
\label{precision}
\index{precision} \index{DOUBLE switch}
By default {\bf GENTRAN} generates constants and type declarations in
single precision form.  If the user requires double precision output
then the switch {\bf DOUBLE} must be set {\bf ON}.  This does the
following:

\begin{itemize}
\item Declarations of appropriate type are converted to their double
precision counterparts.  In FORTRAN and RATFOR this means that objects of type
{\it REAL\/} are converted to objects of type {\it DOUBLE PRECISION\/}
and objects of type {\it COMPLEX\/} are converted to {\it COMPLEX*16\/}
\footnote{This is not part of the ANSI FORTRAN standard.  Some compilers
accept {\it DOUBLE COMPLEX\/} as well as, or instead of, {\it COMPLEX*16\/},
and some accept neither.}. \index{DOUBLE PRECISION} \index{COMPLEX}
\index{COMPLEX*16}
In C the counterpart of {\it float\/} is {\it double\/}, and of {\it int\/}
is {\it long\/}.  There is no complex data type and trying to translate complex
objects causes an error.
\item Similarly subprograms are given their correct type where appropriate.
\item In FORTRAN and RATFOR {\it REAL\/} and {\it COMPLEX\/} numbers are
printed with the correct double precision format.
\item Intrinsic functions are converted to their double precision counterparts
(e.g. in FORTRAN $SIN \rightarrow DSIN$ etc.).
\end{itemize}

\subsubsection{Intrinsic FORTRAN and RATFOR functions.}
An attempt is made to convert the arguments of intrinsic functions to
the correct type.  For example:
\begin{verbatim}
5: GENTRAN f:=sin(1)$
      F=SIN(1.0)

6: GENTRAN f:=sin(x)$
      F=SIN(REAL(X))

7: GENTRAN DECLARE <<x:real>>$

8: GENTRAN f:=sin(x)$
      F=SIN(X)
\end{verbatim}
Which function is used to coerce the argument may, of course, depend on the
setting of the switch {\bf DOUBLE}.

\subsubsection{Number of printed floating point digits.}
\index{PRECISION command} \index{PRINT"!-PRECISION command}
To ensure the correct number of floating point digits are
generated it may be necessary to use either the {\bf PRECISION} or
{\bf PRINT!-PRECISION} commands.  The former alters the number of
digits REDUCE calculates, the latter only the number of digits REDUCE
prints.  Each takes an integer argument.  It is not possible to set
the printed precision higher than the actual precision.  Calling {\bf
PRINT!-PRECISION} with a negative argument causes the printed
precision to revert to the actual precision.

\begin{verbatim}
1: on rounded$

2: precision 16$

3: 1/3;

0.333 33333 33333 333

4: print!-precision 6$

5: 1/3;

0.333333

6: print!-precision(-1)$

7: 1/3;

0.333 33333 33333 333
\end{verbatim}

\subsection{Code Generation:  Evaluation Prior to Translation}
\label{generation}
Section~\ref{translation} showed how REDUCE statements and expressions
can be translated directly into the target language.  This section
shows how to indicate that parts of those statements and expressions
are to be handed to REDUCE to be evaluated before being translated.
In other words, this section explains how to generate numerical code
from algorithmic specifications (in the REDUCE programming language)
and symbolic expressions.  Each of the following four subsections
describes a special function or operator that can be used to request
partial or full evaluation of expressions prior to translation.  Note
that these functions and operators have the described effects {\it
only} when applied to arguments to the {\bf GENTRAN} function and that
evaluation is done in algebraic or symbolic mode, depending on the
value of the REDUCE variable {\bf !*MODE}.\ttindex{"!*MODE}

\subsubsection{The EVAL Function}
\label{eval}
\begin{describe}{Syntax:} 
{\bf EVAL} {\it exp}
\end{describe} \ttindex{EVAL}
\begin{describe}{Argument:}
{\it exp} is any REDUCE expression or statement which, after evaluation
by REDUCE, results in an expression that can be translated by
GENTRAN into the target language.
\end{describe}
\begin{describe}{Side Effect:}
When {\bf EVAL} is called on an expression which is to be translated, it
tells {\bf GENTRAN} to give the expression to REDUCE
for evaluation first, and then to translate the result of that evaluation.
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
The following formula, F, has been derived symbolically:
\begin{verbatim}
   2
2*X  - 5*X + 6
\end{verbatim}
We wish to generate an assignment statement for the quotient
of F and its derivative.
\begin{verbatim}
1: GENTRAN 
1:      Q := EVAL(F)/EVAL(DF(F,X))$ 

      Q=(2.0*X**2-(5.0*X)+6.0)/(4.0*X-5.0)
\end{verbatim}
\end{describe}

\subsubsection{The :=: Operator}
\index{:=:}
\label{rsetq} \index{GENTRAN ! preevaluation} \index{rsetq operator}
In many applications, assignments must be generated in which the
left-hand side is some known variable name, but the
right-hand side is an expression that must be evaluated.  For
this reason, a special operator is provided to indicate that the expression
on the right-hand side is to be evaluated prior to translation.  This
special operator is {\bf :=:} (i.e., the usual REDUCE assignment operator
with an extra ``:'' on the right).
\begin{describe}{\example} \index{GENTRAN package ! example}
\begin{verbatim}
1: GENTRAN 
1:  DERIV :=: DF(X^4-X^3+2*x^2+1,X)$ 

      DERIV=4.0*X**3-(3.0*X**2)+4.0*X
\end{verbatim}
\end{describe}
Each built-in operator in REDUCE has an alternative alphanumeric identifier
associated with it.  Similarly, the GENTRAN {\bf :=:} operator has a
special identifier associated with it: {\bf RSETQ} may be used \ttindex{RSETQ}
interchangeably with {\bf :=:} on input.
\subsubsection{The ::= Operator}
\label{lsetq}
\index{matrices ! in GENTRAN}
When assignments to matrix or array elements must be generated, many
times the indices of the element must be evaluated first.  The special operator
\index{::=} \index{lsetq operator}
{\bf ::=} can be used within a call to {\bf GENTRAN}
to indicate that the indices of the matrix or
array element on the left-hand side of the assignment are to
be evaluated prior to translation.  (This is the usual REDUCE
assignment operator with an extra ``:'' on the left.)
\begin{describe}{\example}\index{GENTRAN package ! example}
We wish to generate assignments which assign zeros to all elements
on the main diagonal of M, an n x n matrix.
\begin{verbatim}
10: FOR j := 1 : 8 DO 
10:      GENTRAN 
10:          M(j,j) ::= 0$

      M(1,1)=0.0
      M(2,2)=0.0
      :
      :
      M(8,8)=0.0
\end{verbatim}
\end{describe}

{\bf LSETQ} may be used interchangeably with {\bf ::=} on input.\ttindex{LSETQ}
\subsubsection{The ::=: Operator}
\label{lrsetq}
\index{::=:}  \index{lrsetq operator}
In applications in which evaluated expressions are to be assigned to
array elements with evaluated subscripts, the {\bf ::=:} operator can be
used.  It is a combination of the {\bf ::=} and {\bf :=:} operators described
in sections~\ref{rsetq} and ~\ref{lsetq}.
\index{matrices ! in GENTRAN}

\newpage
\begin{describe}{\example}\index{GENTRAN package ! example}
The following matrix, M, has been derived symbolically:
\begin{verbatim}
(  A   0  -1   1)
(               )
(  0   B   0   0)
(               )
( -1   0   C  -1)
(               )
(  1   0  -1   D)
\end{verbatim}
We wish to generate assignment statements for those elements
on the main diagonal of the matrix.
\begin{verbatim}
10: FOR j := 1 : 4 DO 
10:      GENTRAN 
10:          M(j,j) ::=: M(j,j)$

      M(1,1)=A
      M(2,2)=B
      M(3,3)=C
      M(4,4)=D
\end{verbatim}
\end{describe}
The alternative alphanumeric identifier associated with {\bf ::=:} is 
{\bf LRSETQ}.\ttindex{LRSETQ}

\subsection{Explicit Type Declarations}
\label{explicit:type}
Type declarations are automatically generated each time a subprogram
heading is generated.  Type declarations are constructed
from information stored in the GENTRAN symbol table.  The user
can place entries into the symbol table explicitly through calls
to the special GENTRAN function {\bf DECLARE}. \index{DECLARE function}
\begin{describe}{Syntax:}
{\bf \ \ DECLARE} {\it v1,v2,\dots\  ,vn} {\bf :} {\it type;}

    or

\begin{tabular}{ll}
{\bf DECLARE}\\
{\bf $<$$<$}\\ 
&{\it v11,v12,\dots\  ,v1n} {\bf :} {\it type1;}\\
&{\it v21,v22,\dots\  ,v2n} {\bf :} {\it type2;}\\
& :\\
& :\\
&{\it vn1,vnn,\dots\  ,vnn} {\bf :} {\it typen;}\\ 
{\bf $>$$>$}{\it ;}
\end{tabular}
\end{describe}
\begin{describe}{Arguments:}
Each {\it v1,v2,\dots\  ,vn} is a list of one or more variables
(optionally subscripted to indicate array dimensions), or
variable ranges (two letters separated by a ``-'').  {\it v}'s are
not evaluated unless given as arguments to {\bf EVAL}.

Each {\it type} is a variable type in the target language.  Each
must be an atom, optionally preceded by the atom {\bf IMPLICIT}.
\index{IMPLICIT option}
{\it type}'s are not evaluated unless given as arguments to {\bf EVAL}.
\end{describe}
\begin{describe}{Side Effect:}
Entries are placed in the symbol table for each variable or
variable range declared in the call to this function.  The function
call itself is removed from the statement group being
translated.  Then after translation, type declarations are
generated from these symbol table entries before the resulting
executable statements are printed.
\end{describe}
\begin{describe}{Diagnostic Message:}
\begin{verbatim}
***** INVALID SYNTAX
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: GENTRAN 
1: <<
1:      DECLARE 
1:      << 
1:          A-H, O-Z : IMPLICIT REAL; 
1:          M(4,4)   : INTEGER 
1:      >>; 
1:      FOR I:=1:4 DO 
1:          FOR J:=1:4 DO 
1:              IF I=J 
1:                  THEN M(I,J):=1 
1:                  ELSE M(I,J):=0; 
1:      DECLARE I, J : INTEGER; 
1: >>$ 

      IMPLICIT REAL (A-H,O-Z)
      INTEGER M(4,4),I,J
      DO 25001 I=1,4
          DO 25002 J=1,4
              IF (I.EQ.J) THEN
                  M(I,J)=1.0
              ELSE
                  M(I,J)=0.0
              ENDIF
25002     CONTINUE
25001 CONTINUE
\end{verbatim}
\end{describe}
The {\bf DECLARE} statement can also be used to declare subprogram types (i.e.
{\bf SUBROUTINE} or {\bf FUNCTION}) for \index{SUBROUTINE} \index{FUNCTION}
FORTRAN and RATFOR code, and function types for all four languages.
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: GENTRANLANG!* := 'RATFOR$ 

2: GENTRAN 
2:      PROCEDURE FAC N; 
2:      BEGIN 
2:      DECLARE 
2:      << 
2:          FAC : FUNCTION; 
2:          FAC, N : INTEGER 
2:      >>; 
2:      F := FOR I:=1:N PRODUCT I; 
2:      DECLARE F, I : INTEGER; 
2:      RETURN F 
2:      END$

INTEGER FUNCTION FAC(N)
INTEGER N,F,I
{
    F=1
    DO I=1,N
        F=F*I
}
RETURN(F)
END

3: GENTRANLANG!* := 'C$
4: GENTRAN 
4:      PROCEDURE FAC N; 
4:      BEGIN 
4:      DECLARE FAC, N, I, F : INTEGER; 
4:      F := FOR I:=1:N PRODUCT I; 
4:      RETURN F 
4:      END$ 

int FAC(N)
int N;
{
    int I,F;
    {
        F=1;
        for (I=1;I<=N;++I)
            F*=I;
    }
    return(F);
}
\end{verbatim}
\end{describe}

When generating code for subscripted variables (i.e., matrix and
array elements), it is important to keep several things in mind.  First
of all, when a REDUCE array is declared with a declaration such as
\index{ARRAY}
\begin{center}
{\bf ARRAY A(}{\it n}{\bf )\$} 
\end{center}
where {\it n} is a positive integer, {\bf A} is actually being declared
to be of size {\bf n}+1.  Each of the elements {\bf A(0), A(1), \dots\  , A(n)}
can be used.  However, a FORTRAN or RATFOR declaration such as
\begin{center}
{\bf DIMENSION A(}{\it n}{\bf )}
\end{center}
declares {\bf A} only to be of size {\bf n}.  Only the elements
{\bf A(1), A(2), \dots\  , A(n)} can be used.  Furthermore, a C declaration
such as
\begin{center}
{\bf float A[}{\it n}{\bf ];}
\end{center}
declares {\bf A} to be of size {\bf n} with elements referred to as
{\bf A[0], A[1], \dots\  , A[}{\it n-1}{\bf ]}.

To resolve these array size and subscripting conflicts, the user should
remember the following:
\index{subscripts ! in GENTRAN}
\begin{itemize}
\item {\it All REDUCE array subscripts are translated literally.}
Therefore it is the user's responsibility to be sure that array elements with
subscript 0 are not translated into FORTRAN or RATFOR.
\item Since C and PASCAL
arrays allow elements with a subscript of 0, when an array is
declared to be of size {\it n} by the user, {\it the actual generated type
declaration will be of size n+1} so that the user can translate
elements with subscripts from 0, and up to and including {\it n}.
\end{itemize}

\subsection{Implicit Type Declarations}
\label{implicit:type} \index{GETDECS switch}
Some type  declarations can be made automatically if the switch {\bf GETDECS}
is {\bf ON}.  In this case:
\begin{enumerate}
\item The indices of loops are automatically declared to be integers.
\index{loop indices ! in GENTRAN}
\item There is a global variable {\bf DEFTYPE!*}, which is the default
type given to objects.  Subprograms, their parameters, and local scalar
objects are automatically assigned this type. \ttindex{DEFTYPE"!*}
\index{REAL*8} \index{DOUBLE PRECISION}
Note that types such as REAL*8 or DOUBLE PRECISION should not
be used as, if {\bf DOUBLE} is on, then a default type of REAL
will in fact be DOUBLE PRECISION anyway.
\item  If GENTRAN is used to translate a REDUCE procedure, then it assigns
objects declared {\bf SCALAR} the type given by {\bf DEFTYPE!*}.  Note that
\index{INTEGER declaration} \index{REAL declaration}
it is legal to use the commands {\bf INTEGER} and {\bf REAL} in the place
of {\bf SCALAR}, which allows the user to specify an actual type.  The
procedure may also be given a return type, in which case that is used as
the default.  For example:
\begin{verbatim}

2: on getdecs,gendecs$

3: GENTRAN
3: real procedure f(x);
3: begin integer n;real y;
3:     n := 4;
3:     y := n/(1+x)^2;
3:     return y;
3: end;
      REAL FUNCTION F(X)
      INTEGER N
      REAL X,Y
      N=4
      Y=N/(1.0+X)**2
      F=Y
      RETURN
      END

\end{verbatim}
\end{enumerate}

\subsection{More about Type Declarations}
\label{more:type}
A check is made on output to ensure that all types generated are legal ones.
This is necessary since {\bf DEFTYPE!*} can be set to anything.
Note that {\bf DEFTYPE!*} ought normally to be given a simple 
type as its \ttindex{DEFTYPE"!*}
value, such as REAL, INTEGER, or COMPLEX,
since this will always be translated into the corresponding type in the
target language on output.

An entry is removed from the symbol table once a declaration has been
generated for it.  The {\bf KEEPDECS} switch (by default {\bf OFF})
disables this, allowing a user to check the types of objects
\index{KEEPDECS switch} which GENTRAN has generated (useful if they
are being generated automatically)

\subsection{Comments and Literal Strings}
\label{comments} \index{comments ! in GENTRAN}
Comments and other strings of characters can be inserted directly into
the stream of generated code through a call to the special function
{\bf LITERAL}.
\begin{describe}{Syntax:}
{\bf LITERAL} {\it  arg1,arg2,\dots\  ,argn;}
\end{describe}
\begin{describe}{Arguments:}
{\it arg1,arg2,\dots\  ,argn} is an argument list containing one or more
{\it arg}'s, where each {\it arg} either is, or evaluates to, an atom.  The
\ttindex{TAB"!*} \ttindex{CR"!*} 
atoms {\bf TAB!*} and {\bf CR!*} have special meanings.  {\it arg}'s are
not evaluated unless given as arguments to {\bf EVAL}.
\end{describe}
\begin{describe}{Side Effect:}
This statement is replaced by the character sequence resulting from
concatenation of the given atoms.  Double quotes are stripped from
all string type {\it arg}'s, and the reserved atoms {\bf TAB!*} and
{\bf CR!*} are replaced by a tab to the current level of indentation, and
an end-of-line character, respectively.
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Suppose N has value 10.
\begin{verbatim}
1: GENTRANLANG!* := 'FORTRAN$ 

2: GENTRAN 
2: << 
2:      LITERAL 
2:        "C",TAB!*,"--THIS IS A FORTRAN COMMENT--",CR!*, 
2:        "C",CR!*; 
2:      LITERAL 
2:        TAB!*,"DATA N/",EVAL(N),"/",CR!* 
2: >>$ 

C     --THIS IS A FORTRAN COMMENT--
C
      DATA N/10/

3: GENTRANLANG!* := 'RATFOR$ 
4: GENTRAN 
4:     FOR I:=1:N DO 
4:     << 
4:         LITERAL 
4:            TAB!*,"# THIS IS A RATFOR COMMENT",CR!*; 
4:         LITERAL 
4:            TAB!*,"WRITE(6,10) (M(I,J),J=1,N)",CR!*, 
4:            10,TAB!*,"FORMAT(1X,10(I5,3X))",CR!* 
4:     >>$ 

DO I=1,N
    {
        # THIS IS A RATFOR COMMENT
        WRITE(6,10) (M(I,J),J=1,N)
10      FORMAT(1X,10(I5,3X))
    }

5: GENTRANLANG!* := 'C$ 
6: GENTRAN 
6: << 
6:      X:=0; 
6:      LITERAL "/* THIS IS A",CR!*, 
6:              "   C COMMENT */",CR!* 
6: >>$ 

{
    X=0.0;
/* THIS IS A
   C COMMENT */
}

7:  GENTRANLANG!* := 'PASCAL$

8: GENTRAN
8: <<
8:     X := SIN(Y);
8:     LITERAL "{ THIS IS A PASCAL COMMENT }", CR!*
8: >>$
BEGIN
    X:=SIN(Y)
{ THIS IS A PASCAL COMMENT }
END;

\end{verbatim}
\end{describe}
\subsection{Expression Segmentation}
\label{segmentation} \index{segmenting expressions}
Symbolic derivations can easily produce formulas that can be anywhere
from a few lines to several pages in length.  Such formulas
can be translated into numerical assignment statements, but unless they
are broken into smaller pieces they may be too long for a compiler
to handle.  (The maximum number of continuation lines for one statement
allowed by most FORTRAN compilers is only 19.)  Therefore GENTRAN
\index{continuation lines}
contains a segmentation facility which automatically {\it segments},
or breaks down unreasonably large expressions.

The segmentation facility generates a sequence of assignment
statements, each of which assigns a subexpression to an automatically
generated temporary variable.  This sequence is generated in such a
way that temporary variables are re-used as soon as possible, thereby
keeping the number of automatically generated variables to a minimum.
The facility can be turned on or off by setting the mode
\index{GENTRANSEG switch} switch {\bf GENTRANSEG} accordingly (i.e.,
by calling the REDUCE function {\bf ON} or {\bf OFF} on it).  The user
can control the maximum allowable expression size by setting the
\ttindex{MAXEXPPRINTLEN"!*}
variable {\bf MAXEXPPRINTLEN!*} to the maximum number of characters
allowed in an expression printed in the target language (excluding
spaces automatically printed by the formatter).  The {\bf GENTRANSEG}
switch is on initially, and {\bf MAXEXPPRINTLEN!*} is initialized to
800.
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: ON EXP$ 

2: JUNK1 := (A+B+C+D)^2$ 

3: MAXEXPPRINTLEN!* := 24$ 

4: GENTRAN VAL :=: JUNK1$ 

      T0=A**2+2.0*A*B
      T0=T0+2.0*A*C+2.0*A*D
      T0=T0+B**2+2.0*B*C
      T0=T0+2.0*B*D+C**2
      VAL=T0+2.0*C*D+D**2

5: JUNK2 := JUNK1/(E+F+G)$ 

6: MAXEXPPRINTLEN!* := 23$ 

7: GENTRANLANG!* := 'C$ 

8: GENTRAN VAL :=: JUNK2$ 

{
    T0=power(A,2)+2.0*A*B;
    T0+=2.0*A*C;
    T0=T0+2.0*A*D+power(B,2);
    T0+=2.0*B*C;
    T0=T0+2.0*B*D+power(C,2);
    T0=T0+2.0*C*D+power(D,2);
    VAL=T0/(exp(1.0)+F+G);
}
\end{verbatim}
\end{describe}
\subsubsection{Implicit Type Declarations}\label{GENTRAN:itd}
When the segmentation routine generates temporary variables, it places
type declarations in the symbol table for those variables if
possible.  It uses the following rules to determine their type:
\index{implicit type declarations} \index{temporary variables ! type}
\begin{itemize}
\item[{(1)}]
If the type of the variable to which the large expression is being
assigned is already known (i.e., has been declared by the user),
then the temporary variables will be declared to be of that same type.
\item[{(2)}] \ttindex{TEMPVARTYPE"!*}
If the global variable {\bf TEMPVARTYPE!*} has a non-NIL value, then the
temporary variables are declared to be of that type.
\item[{(3)}]
Otherwise, the variables are not declared.
\end{itemize}

\newpage
\begin{describe}{\example} \index{GENTRAN package ! example}

\begin{verbatim}
1: MAXEXPPRINTLEN!* := 20$

2: TEMPVARTYPE!* := 'REAL$ 

3: GENTRAN 
3: << 
3:      DECLARE ISUM : INTEGER; 
3:      ISUM := II+JJ+2*KK+LL+10*MM+NN; 
3:      PROD := V(X,Y)*SIN(X)*COS(Y^2)*(X+Y+Z^2) 
3: >>$ 

      INTEGER ISUM,T0
      REAL T1
      T0=II+JJ+2.0*KK+LL
      ISUM=T0+10.0*MM+NN
      T1=V(X,Y)*SIN(X)*COS(Y**2)
      PROD=T1*(X+Y+Z**2)
\end{verbatim}
\end{describe}
\subsection{Generation of Temporary Variable Names}
\label{tempvars} \index{temporary variables ! names}
As we have just seen, GENTRAN's segmentation module generates
temporary variables and places type declarations in the symbol table
for them whenever possible.  Various other modules also generate
variables and corresponding declarations.  All of these modules call
one special GENTRAN function each time they need a temporary
variable name.  This function is {\bf TEMPVAR}.  There are situations
in which it may be convenient for the user to be able to generate
temporary variable names directly.\footnote{One such example is suppression
of the simplification process to generate numerical code which is more
efficient.  See the example in section~\ref{tempvar:example} on
page~\pageref{tempvar:example}.}
Therefore {\bf TEMPVAR} \ttindex{TEMPVAR}
is a user-accessible function which may be called from both
the algebraic and symbolic modes of REDUCE.
\begin{describe}{Syntax:}
{\bf TEMPVAR} {\it type}
\end{describe}
\begin{describe}{Argument:}
{\it type} is an atom which either indicates the variable type in the
target language (INTEGER, REAL, etc.), or is {\bf NIL} if the variable
type is unknown.
\end{describe}
\begin{describe}{Side Effects:}
{\bf TEMPVAR} creates temporary variable names by repeatedly concatenating
the values of the global variables {\bf TEMPVARNAME!*} (which has a
\ttindex{TEMPVARNUM"!*}
default value of {\bf T}) and {\bf TEMPVARNUM!*} (which is initially set
to 0) and incrementing {\bf TEMPVARNUM!*} until a variable name is created
which satisfies one of the following conditions:
\begin{itemize}
\item[{(1)}]
It was not generated previously, and it has not been declared by the user.
\item[{(2)}]
It was previously generated to hold the same type of value that it
must hold this time (e.g. INTEGER, REAL, etc.), and the value assigned
to it previously is no longer needed.
\end{itemize}
If {\it type} is a non-NIL argument, or if {\it type} is {\bf NIL}
and the global variable {\bf TEMPVARTYPE!*} (initially NIL) has been
\ttindex{TEMPVARTYPE"!*}
set to a non-NIL value, then a type entry for the generated variable name
is placed in the symbol table.
\end{describe}
\begin{describe}{Returned Value:}
{\bf TEMPVAR} returns an atom which can be used as a variable.
\end{describe}
Note:  It is the user's responsibility to set {\bf TEMPVARNAME!*} and 
{\bf TEMPVARNUM!*} to values such that generated variable
names will not clash with variables used elsewhere in the
program unless those variables have been declared.

\subsubsection{Marking Temporary Variables}
In section~\ref{tempvars} we saw that a temporary variable name (of a certain
type) can be regenerated when the value previously assigned to it
is no longer needed.  This section describes a function which {\it marks}
a variable to indicate that it currently holds a
significant value, and the next section describes functions which
{\it unmark} variables to indicate that the values they hold are no
\index{temporary variables ! marking}
\index{marking temporary variables}
longer significant.\ttindex{MARKVAR}
\begin{describe}{Syntax:}
{\bf MARKVAR} {\it  var}
\end{describe}
\begin{describe}{Argument:}
{\it var} is an atom.
\end{describe}
\begin{describe}{Side Effects:}
{\bf MARKVAR} sets a flag on {\it var}'s property list to indicate that
{\it var} currently holds a significant value.
\end{describe}
\begin{describe}{Returned Value:}
{\bf MARKVAR} returns {\it var}.
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
The following matrix, M has been derived symbolically:
\begin{verbatim}
(X*(Y+Z)       0     X*Z)
(                       )
(     -X     X+Y       0)
(                       )
(    X*Z       0    Z**2)
\end{verbatim}
We wish to replace each non-zero element by a generated variable name
to prevent these expressions from being resubstituted into further
calculations.  (We will also record these substitutions in the
numerical program we are constructing by generating assignment
statements.)\footnote{ Note: {\bf MARKVAR} is a symbolic mode
procedure.  Therefore, the name of each variable whose value is to be
passed to it from algebraic mode must appear in a {\bf SHARE}
\index{SHARE command} declaration.  This tells REDUCE to share the
variable's value between algebraic and symbolic modes.}
\begin{verbatim}
9: SHARE var$ 

10: FOR j := 1 : 3 DO 
10:      FOR k := 1 : 3 DO 
10:          IF M(j,k) NEQ 0 THEN 
10:          << 
10:              var := TEMPVAR(NIL); 
10:              MARKVAR var;
10:              GENTRAN
10:                  EVAL(var) :=: M(j,k);
10:              M(j,k) := var
10:          >>$ 

      T0=X*(Y+Z)
      T1=X*Z
      T2=-X
      T3=X+Y
      T4=X*Z
      T5=Z**2
\end{verbatim}
Now matrix M contains the following entries:
\begin{verbatim}
(T0   0  T1)
(          )
(T2  T3   0)
(          )
(T4   0  T5)
\end{verbatim}
\end{describe}

\subsubsection{Unmarking Temporary Variables}
\index{unmarking temporary variables} \index{temporary variables ! unmarking}
After the value assigned to a temporary variable has been used
in the numerical program and is no longer needed, the variable name can be \
\ttindex{UNMARKVAR}
{\it unmarked} with the {\bf UNMARKVAR} function.
\begin{describe}{Syntax:}
{\bf UNMARKVAR} {\it  var;}
\end{describe}
\begin{describe}{Argument:}
{\it var} is an atom (variable name) or an expression containing one or more
variable names.
\end{describe}
\begin{describe}{Side Effect:}
{\bf UNMARKVAR} resets flags on the property lists of all variable names in 
{\it var} to indicate that they do not hold significant values any longer.
\end{describe}

\subsection{Enabling and Disabling Generation of Type Declarations}
\label{control:type}
GENTRAN maintains a symbol table of variable type and dimension
information.  It adds information to the symbol table by processing
user-supplied calls to the {\bf DECLARE} function (see
Section~\ref{explicit:type}) and as a
side effect of generating temporary variable names 
(see Sections~\ref{segmentation} and \ref{tempvars}).
All information is stored in the symbol table until GENTRAN is ready
to print formatted numerical code.  Since programming languages such as
FORTRAN require that type declarations appear before executable statements,
GENTRAN automatically extracts all relevant type information and prints it
in the form of type declarations before printing executable
statements.  This feature is useful when the entire body of a (sub)program is
generated at one time:  in this case, type declarations are printed
before any executable code.  However, if the user chooses to generate code
in pieces, the resulting code may have type declarations interleaved
\index{GENDECS switch}
with executable code.  For this reason, the user may turn the {\bf GENDECS}
mode switch on or off, depending on whether or not s/he chooses to use
this feature.

In the following we re-examine the example of Section~\ref{GENTRAN:itd}.
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: MAXEXPPRINTLEN!* := 20$ 

2: TEMPVARTYPE!* := 'REAL!*8$

3: GENTRAN 
3: << 
3:      DECLARE ISUM : INTEGER; 
3:      ISUM := II+JJ+2*KK+LL+10*MM+NN 
3: >>$ 

      INTEGER ISUM,T0
      T0=II+JJ+2*KK+LL
      ISUM=T0+10*MM+NN

4: GENTRAN PROD := V(X,Y)*SIN(X)*COS(Y^2)*(X+Y+Z^2)$ 

      REAL*8 T2
      T2=V(X,Y)*SIN(REAL(X))*COS(REAL(Y**2))
      PROD=T2*(X+Y+Z**2)

5: OFF GENDECS$ 

6: GENTRAN 
6: <<
6:      DECLARE ISUM : INTEGER; 
6:      ISUM := II+JJ+2*KK+LL+10*MM+NN 
6: >>$ 

      T0=II+JJ+2*KK+LL
      ISUM=T0+10*MM+NN

7: GENTRAN PROD := V(X,Y)*SIN(X)*COS(Y^2)*(X+Y+Z^2)$ 

      T2=V(X,Y)*SIN(REAL(X))*COS(REAL(Y**2))
      PROD=T2*(X+Y+Z**2)
\end{verbatim}
\end{describe}

In Section~\ref{template:type} we will explain how to further control
the generation of type declarations.

\subsection{Complex Numbers}
\label{complex} \index{complex numbers} \index{COMPLEX}
With the switch {\bf COMPLEX} set {\bf ON}, GENTRAN will generate the
correct representation for a complex number in the given precision
provided that:

\begin{enumerate}
\item The current language supports a complex data type (if it doesn't then
an error results);
\item The complex quantity is evaluated by REDUCE
to give an object of the correct
domain; i.e.
\begin{verbatim}
        GENTRAN x:=: 1+i;

        GENTRAN x:= eval 1+i;

        z := 1+i;
        GENTRAN x:=: z;
\end{verbatim}
will all generate the correct result, as will their Symbolic mode equivalents,
while:
\begin{verbatim}
        GENTRAN x := 1+i;
\end{verbatim}
will not.
\end{enumerate}

\subsection{Intrinsic Functions}
\label{intrinsic} \index{intrinsic functions}
A warning is issued if a standard REDUCE function is encountered which
does not have an intrinsic counterpart in the target language (e.g.
 {\it cot\/},
{\it sec\/} etc.).
Output is not halted in case this is a user--supplied function, either via
a REDUCE definition or within a GENTRAN template.

The types of intrinsic FORTRAN functions are coerced to reals (in the correct
precision) as the following examples demonstrate:
\begin{verbatim}
19: GENTRAN x:=sin(0)$
      X=SIN(0.0)

20: GENTRAN x:=cos(A)$
      X=COS(REAL(A))

21: ON DOUBLE$

22: GENTRAN x := log(1)$
      X=DLOG(1.0D0)

23: GENTRAN x := exp(B)$
      X=DEXP(DBLE(B))

24: GENTRAN DECLARE <<b:real>>$

25: GENTRAN x := exp(B)$
      X=DEXP(B)

\end{verbatim}

\subsection{Miscellaneous}

\subsubsection{MAKECALLS}
A statement like:
\begin{verbatim}
        GENTRAN x^2+1$
\end{verbatim}
will yield the result:
\begin{verbatim}
        X**2+1
\end{verbatim}
but, under normal circumstances, a statement like:
\begin{verbatim}
        GENTRAN sin(x)$
\end{verbatim}
will yield the result:
\begin{verbatim}
              CALL SIN(X)
\end{verbatim}
\index{MAKECALLS switch}
The switch {\bf MAKECALLS} (OFF by default) will make GENTRAN yield
\begin{verbatim}
       SIN(X)
\end{verbatim}
This is useful if you don't know in advance what the form of the expression
which you are translating is going to be.

\subsubsection{E}
\index{e} \index{EXP}
When GENTRAN encounters $e$ it translates it into EXP(1), and when GENTRAN
encounters
$e^x$ it is translated to EXP(X).  This is then translated
into the correct statement in the given language and precision.  Note that
it is still possible to do something like:
\begin{verbatim}
                GENTRAN e:=:e;
\end{verbatim}
and get the correct result.



\section{Template Processing}\label{GENTRAN:template}

\index{GENTRAN ! templates} \index{templates !} \index{code templates}
In some code generation applications pieces of the target numerical
program are known in advance.  A {\it template} file containing a
program outline is supplied by the user, and formulas are derived in
REDUCE, converted to numerical code, and inserted in the corresponding
places in the program outline to form a complete numerical program.  A
template processor is provided by GENTRAN for use in these
applications.

\subsection{The Template Processing Command}
\label{templates} \index{GENTRANIN command}
\begin{describe}{Syntax:}
{\bf GENTRANIN} {\it f1,f2,\dots\ ,fm} [{\bf OUT} {\it f1,f2,\dots\
 ,fn\/}]{\it ;}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fm\/} is an argument list containing one or more
{\it f\/}'s,
where each {\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom}& = &a template (input) file\\
{\bf T}& = &the terminal\\
\end{tabular}
\end{center}
{\it f1,f2,\dots\ ,fn\/} is an optional argument list containing one or more
{\it f\/}'s, where each {\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom}& = &an output file\\
{\bf T}& = &the terminal\\
{\bf NIL}& = &the current output file(s)\\
{\bf ALL!*}& = &all files currently open for output \\
& &  by GENTRAN (see section~\ref{GENTRAN:output}) \\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
{\bf GENTRANIN} processes each template file {\it f1,f2,\dots\ ,fm}
sequentially.

A template file may contain any number of parts, each of which
is either an active or an inactive part.  All active parts start with
the character sequence {\bf ;BEGIN;} and end with {\bf ;END;}.  The end
of the template file is indicated by an extra {\bf ;END;} character
sequence. \index{;BEGIN; marker}  \index{;END; marker}

Inactive parts of template files are assumed to contain code in the
target language (FORTRAN, RATFOR, PASCAL or C, depending on the value
\ttindex{GENTRANLANG"!*}
of the global variable {\bf GENTRANLANG!*}).  All inactive parts are
copied to the output.  Comments delimited by the appropriate characters,
\index{comments ! in GENTRAN}
\begin{center}
\begin{tabular}{lll}
&{\bf C} \dots\  $<$cr$>$ & FORTRAN (beginning in column 1)\\
&{\bf \#} \dots\  $<$cr$>$ & RATFOR \\
&{\bf /*} \dots\  {\bf */} & C \\
&{\bf \{} \dots\ {\bf \}} or {\bf *(} \dots\  {\bf )*} & PASCAL\\
\end{tabular}
\end{center}
are also copied in their entirety to the output.  Thus the character
sequences {\bf ;BEGIN;} and {\bf ;END;} have no special meanings
within comments.

Active parts may contain any number of REDUCE expressions, statements,
and commands.  They are not copied directly to the output.  Instead,
they are given to REDUCE for evaluation in algebraic mode\footnote{
Active parts are evaluated in algebraic mode unless the mode is
explicitly changed to symbolic from within the active part itself.
This is true no matter which mode the system was in when the template
processor was called.}.  All output generated by each evaluation is
sent to the output file(s).  Returned values are only printed on the
terminal.\index{GENTRAN ! preevaluation}

Active parts will most likely contain calls to {\bf GENTRAN} to
generate code.  This means that the result of processing a
template file will be the original template file with all active
parts replaced by generated code.

If {\bf OUT} {\it f1,f2,\dots\ ,fn} is not given, generated code is simply
written to the current-output file.

However, if {\bf OUT} {\it  f1,f2,\dots\ ,fn}
is given, then the current-output file
is temporarily overridden.  Generated code is written to each file represented
by {\it f1,f2,\dots\ ,fn} for this command only.  Files which were
open prior to the call to {\bf GENTRANIN} will remain open after the
call, and files which did not exist prior to the call will be
created, opened, written to, and closed.  The output-stack will be
exactly the same both before and after the call.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANIN} returns the names of all files written to by this
command.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS
    OVERWRITE FILE? (Y/N)

***** NONEXISTENT INPUT FILE

***** TEMPLATE FILE ALREADY OPEN FOR INPUT

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Suppose we wish to generate a FORTRAN subprogram to compute the
determinant of a 3 x 3 matrix.  We can construct a template
file with an outline of the FORTRAN subprogram and REDUCE and
GENTRAN commands to fill it in:
\index{matrices ! in GENTRAN}

Contents of file {\tt det.tem}:
\end{describe}
\begin{framedverbatim}
      REAL FUNCTION DET(M)                         
      REAL M(3,3)                                  
;BEGIN;                                              
      OPERATOR M$                                    
      MATRIX MM(3,3)$                                
      MM := MAT( (M(1,1),M(1,2),M(1,3)),             
                 (M(2,1),M(2,2),M(2,3)),             
                 (M(3,1),M(3,2),M(3,3)) )$           
      GENTRAN DET :=: DET(MM)$                       
;END;                                                
      RETURN                                         
      END                                            
;END;                                                
\end{framedverbatim}

\begin{describe}{}
Now we can generate a FORTRAN subprogram with the following
REDUCE session:
\begin{verbatim}
1: GENTRANLANG!* := 'FORTRAN$ 

2: GENTRANIN 
2:      "det.tem" 
2: OUT "det.f"$ 
\end{verbatim}
Contents of file det.f:
\end{describe}
\begin{framedverbatim}
      REAL FUNCTION DET(M)
      REAL M(3,3)
      DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)
     . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1
     . ,2)-(M(3,1)*M(2,2)*M(1,3))
      RETURN
      END
\end{framedverbatim}

\subsection{Copying Files into Template Files}
\label{copy:template}

\index{GENTRANIN command} \index{files ! in GENTRAN}
Template files can be copied into other template files with recursive
calls to {\bf GENTRANIN} ; i.e., by calling {\bf GENTRANIN} from the
active part of a template file.

For example, suppose we wish to copy the contents of a file containing
a subprogram into a file containing a main program.  We will call 
{\bf GENTRANIN} to do the copying, so the subprogram file must
have {\bf ;END;} on its last line:

Contents of file {\tt det.tem}:
\begin{framedverbatim}
      REAL FUNCTION DET(M)                              
      REAL M(3,3)                                       
      DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)
     . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1
     . ,2)-(M(3,1)*M(2,2)*M(1,3))
      RETURN                                              
      END                                                 
;END;                                                     
\end{framedverbatim} 

Now the template file for the main program can be constructed
with an active part which will include file det.tem:

Contents of file {\tt main.tem}:
\begin{framedverbatim} 
C                                                         
C  MAIN PROGRAM                                           
C                                                         
      REAL M(3,3),DET                                   
      WRITE(6,*) 'ENTER 3 x 3 MATRIX'                     
      DO 100 I=1,3                                        
          READ(5,*) (M(I,J),J=1,3)                        
100   CONTINUE                                            
      WRITE(6,*) ' DET = ', DET(M)                        
      STOP                                                
      END                                                 
C                                                         
C  DETERMINANT CALCULATION                                
C                                                         
;BEGIN;                                                   
      GENTRANIN "det.tem"$                                
;END;                                                     
;END;                                                     
\end{framedverbatim} 

The following REDUCE session will create the file {\tt main.f}:
\begin{verbatim}
1: GENTRANIN 
1:      "main.tem" 
1: OUT "main.f"$
\end{verbatim}

Contents of file {\tt main.f}:
\begin{framedverbatim}
C                                                         
C  MAIN PROGRAM                                           
C                                                         
      REAL M(3,3),DET                                   
      WRITE(6,*) 'ENTER 3 x 3 MATRIX'                     
      DO 100 I=1,3                                        
          READ(5,*) (M(I,J),J=1,3)                        
100   CONTINUE                                            
      WRITE(6,*) ' DET = ', DET(M)                        
      STOP                                                
      END                                                 
C                                                         
C  DETERMINANT CALCULATION                                
C                                                         
      REAL FUNCTION DET(M)                              
      REAL M(3,3)                                       
      DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)
     . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*
     . M(1,2)-(M(3,1)*M(2,2)*M(1,3))
      RETURN                                              
      END                                                 
\end{framedverbatim} 

\subsection{The Template File Stack}
\label{template:stack}

\index{templates ! file stack}
The REDUCE {\bf IN} command takes one or more file names as
arguments.  REDUCE reads each of the given files and executes all
statements and commands, any of which may be another {\bf IN}
command.  A stack of input file names is maintained by
REDUCE to allow recursive invocation of the {\bf IN} command.  Similarly,
a stack of template file names is maintained by GENTRAN to facilitate
recursive invocation of the template processor.  Section~\ref{copy:template}
showed that the {\bf GENTRANIN} command can be
\index{GENTRANIN command}
called recursively to copy files into other files.  This section shows
that template files which are copied into other template files can also
contain active parts, and thus the whole code generation process can
be invoked recursively.

We can generalize the example of section~\ref{copy:template} by
generating code recursively.  We can extend it to generate code which
will compute entries of the inverse matrix, also.  Suppose
we have created the file init.red, which contains REDUCE commands to
create an {\it n}x{\it n} matrix MM and initialize its entries
to M(1,1), M(1,2),~\dots~, M({\it n}, {\it n}), for some user-entered
value of {\it n}:

Contents of file {\tt init.red}:
\begin{framedverbatim}
OPERATOR M$                                               
MATRIX MM(n,n)$                                           
FOR J := 1 : n DO                                         
    FOR K := 1 : n DO                                     
        MM(J,K) := M(J,K)$                                
END$                                                      
\end{framedverbatim} 

We have also created template files {\tt det.tem} and {\tt inv.tem} which
contain outlines of FORTRAN subprograms to compute the
determinant and inverse of an {\it n}x{\it n} matrix, respectively:

Contents of file {\tt det.tem}:
\begin{framedverbatim}
      REAL FUNCTION DET(M)                              
;BEGIN;                                                   
      GENTRAN                                             
      <<                                                  
          DECLARE M(EVAL(n),EVAL(n)) : REAL;            
          DET :=: DET(MM)                                 
      >>$                                                 
;END;                                                     
      RETURN                                              
      END                                                 
;END;                                                     
\end{framedverbatim} 
Contents of file {\tt inv.tem}:
\begin{framedverbatim}
      SUBROUTINE INV(M,MINV)                              
;BEGIN;                                                   
      GENTRAN                                             
      <<                                                  
          DECLARE M(EVAL(n),EVAL(n)),                     
          MINV(EVAL(n),EVAL(n)) : REAL;                 
          MINV :=: MM^(-1)                                
      >>$                                                 
;END;                                                     
      RETURN                                              
      END                                                 
;END;                                                     
\end{framedverbatim} 

Now we can construct a template file with a generalized version of the main
program given in section~\ref{copy:template}
and can place {\bf GENTRANIN} commands
in this file to generate code recursively from the template files det.tem
and inv.tem:

Contents of file {\tt main.tem}:
\begin{framedverbatim}
C                                                         
C  MAIN PROGRAM                                           
C                                                         
;BEGIN;                                                   
      GENTRAN                                             
      <<                                                  
          DECLARE                                         
          <<                                              
              M(EVAL(n),EVAL(n)),                         
              DET,                                        
              MINV(EVAL(n),EVAL(n)) : REAL;             
              N                     : INTEGER             
          >>;                                             
          LITERAL TAB!*, "DATA N/", EVAL(n), "/", CR!*    
      >>$                                                 
;END;                                                     
      WRITE(6,*) 'ENTER ', N, 'x', N, ' MATRIX'           
      DO 100 I=1,N                                        
          READ(5,*) (M(I,J),J=1,N)                        
100   CONTINUE                                            
      WRITE(6,*) ' DET = ', DET(M)                        
      WRITE(6,*) ' INVERSE MATRIX:'                       
      CALL INV(M,MINV)                                    
      DO 200 I=1,N                                        
          WRITE(6,*) (MINV(I,J),J=1,N)                    
200   CONTINUE                                            
      STOP                                                
      END                                                 
C                                                         
C  DETERMINANT CALCULATION                                
C                                                         
;BEGIN;                                                   
      GENTRANIN "det.tem"$                                
;END;                                                     
C                                                         
C  INVERSE CALCULATION                                    
C                                                         
;BEGIN;                                                   
      GENTRANIN "inv.tem"$                                
;END;                                                     
;END;                                                     
\end{framedverbatim} 

The following REDUCE session will create the file {\tt main.f}:
\begin{verbatim}
1: n := 3$ 

2: IN "init.red"$ 

3: GENTRANLANG!* := 'FORTRAN$ 

4: GENTRANIN 
4:      "main.tem" 
4: OUT "main.f"$ 
\end{verbatim}
Contents of file {\tt main.f}:
\begin{framedverbatim}
C                                                         
C  MAIN PROGRAM                                           
C                                                         
      REAL M(3,3),DET,MINV(3,3)                         
      INTEGER N                                           
      DATA N/3/                                           
      WRITE(6,*) 'ENTER ', N, 'x', N, ' MATRIX'           
      DO 100 I=1,N                                        
          READ(5,*) (M(I,J),J=1,N)                        
100   CONTINUE                                            
      WRITE(6,*) ' DET = ', DET(M)                        
      WRITE(6,*) ' INVERSE MATRIX:'                       
      CALL INV(M,MINV)                                    
      DO 200 I=1,N                                        
          WRITE(6,*) (MINV(I,J),J=1,N)                    
200   CONTINUE                                            
      STOP                                                
      END                                                 
C                                                         
C  DETERMINANT CALCULATION                                
C                                                         
      REAL FUNCTION DET(M)                              
      REAL M(3,3)                                       
      DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)
     . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)
     . *M(1,2)-(M(3,1)*M(2,2)*M(1,3))
      RETURN                                              
      END                                                 
C                                                         
C  INVERSE CALCULATION                                    
C                                                         
      SUBROUTINE INV(M,MINV)                              
      REAL M(3,3),MINV(3,3)                             
      MINV(1,1)=(M(3,3)*M(2,2)-(M(3,2)*M(2,3)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      MINV(1,2)=(-(M(3,3)*M(1,2))+M(3,2)*M(1,3))/(M(3,3)*M(2,
     . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)
     . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(
     . 2,2)*M(1,3)))
      MINV(1,3)=(M(2,3)*M(1,2)-(M(2,2)*M(1,3)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      MINV(2,1)=(-(M(3,3)*M(2,1))+M(3,1)*M(2,3))/(M(3,3)*M(2,
     . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)
     . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(
     . 2,2)*M(1,3)))
      MINV(2,2)=(M(3,3)*M(1,1)-(M(3,1)*M(1,3)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      MINV(2,3)=(-(M(2,3)*M(1,1))+M(2,1)*M(1,3))/(M(3,3)*M(2,
     . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)
     . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(
     . 2,2)*M(1,3)))
      MINV(3,1)=(M(3,2)*M(2,1)-(M(3,1)*M(2,2)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      MINV(3,2)=(-(M(3,2)*M(1,1))+M(3,1)*M(1,2))/(M(3,3)*M(2,
     . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)
     . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(
     . 2,2)*M(1,3)))
      MINV(3,3)=(M(2,2)*M(1,1)-(M(2,1)*M(1,2)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      RETURN                                              
      END                                                 
\end{framedverbatim} 

This is an example of a modular approach to code generation; separate
subprogram templates are given in separate files.  Furthermore, the template
files are general; they can be used for matrices of any predetermined
size.  Therefore, we can easily generate different subprograms to
handle matrices of different sizes from the same template files
simply by assigning different values to {\it n}, and reloading the
file init.red.

\subsection{Template Processing and Generation of Type Declarations}
\label{template:type}
\index{GENDECS switch} \index{type declarations}
In Section~\ref{control:type} we described the {\bf GENDECS} flag.  We
explained that type declarations are not generated when this flag is
turned off.  Now that the concept of template processing has been
explained, it is appropriate to continue our discussion of generation
of type declarations.

When the {\bf GENDECS} flag is off, type declaration information is not
simply discarded --- it is still maintained in the symbol table.  Only the
automatic extraction of this information in the form of declarations is
disabled.  When the {\bf GENDECS} flag is turned off, all type
information associated with a specific subprogram can be retrieved in the
form of generated declarations by calling the {\bf GENDECS} function with
the subprogram name as argument.  The template processor recognizes
function and subroutine headings.  It always keeps track of the name of
the subprogram it is processing.  Therefore, the declarations associated with
a particular subprogram {\it subprogname} can be generated with a call to
{\bf GENDECS} as follows:
\begin{center}
{\bf GENDECS} {\it subprogname}\$
\end{center}

By using the {\bf GENDECS} flag and function together with the template
processing facility, it is possible to have type information
inserted into the symbol table during a first pass over a template file, and
then to have it extracted during a second pass.  Consider the following
example in which the original template file is transformed into an
intermediate template during the first pass, and then into the final file
of FORTRAN code during the second pass:

Contents of file {\tt junk.tem}:
\begin{framedverbatim}
;BEGIN;                                       
MAXEXPPRINTLEN!* := 50$                       
OFF GENDECS$                                  
;END;                                         
      SUBROUTINE CALC(X,Y,Z,A,B,RES)          
;BEGIN;                                       
GENTRAN LITERAL ";BEGIN;", CR!*,              
                "GENDECS CALC$", CR!*,        
                 ";END;", CR!*$                
;END;                                         
      X=3.75                                  
      Y=-10.2                                 
      Z=16.473                                
;BEGIN;                                       
GENTRAN                                       
<<                                            
    DECLARE X,Y,Z,A,B,RES : REAL;           
    RES :=: (X + Y + Z)^3*(A + B)^2           
>>$                                           
;END;                                         
      RETURN                                  
      END                                     
;BEGIN;                                       
GENTRAN LITERAL ";END;", CR!*$                
;END;                                         
;END;                                         
\end{framedverbatim} 

Invocation of the template processor on this file produces an
intermediate template file:
\begin{verbatim}
1: GENTRANIN 
1:     "junk.tem" 
1: OUT "#junk.tem"$ 
\end{verbatim}
Contents of file {\tt \#junk.tem}:
\begin{framedverbatim}
      SUBROUTINE CALC(X,Y,Z,A,B,RES)          
;BEGIN;                                       
GENDECS CALC$                                 
;END;                                         
      X=3.75                                  
      Y=-10.2                                 
      Z=16.473                                
      T0=A**2*X**3+3.0*A**2*X**2*Y            
      T0=T0+3.0*A**2*X**2*Z+3.0*A**2*X*Y**2   
      T0=T0+6.0*A**2*X*Y*Z+3.0*A**2*X*Z**2    
      T0=T0+A**2*Y**3+3.0*A**2*Y**2*Z         
      T0=T0+3.0*A**2*Y*Z**2+A**2*Z**3         
      T0=T0+2.0*A*B*X**3+6.0*A*B*X**2*Y       
      T0=T0+6.0*A*B*X**2*Z+6.0*A*B*X*Y**2     
      T0=T0+12.0*A*B*X*Y*Z+6.0*A*B*X*Z**2     
      T0=T0+2.0*A*B*Y**3+6.0*A*B*Y**2*Z       
      T0=T0+6.0*A*B*Y*Z**2+2.0*A*B*Z**3       
      T0=T0+B**2*X**3+3.0*B**2*X**2*Y         
      T0=T0+3.0*B**2*X**2*Z+3.0*B**2*X*Y**2   
      T0=T0+6.0*B**2*X*Y*Z+3.0*B**2*X*Z**2    
      T0=T0+B**2*Y**3+3.0*B**2*Y**2*Z         
      RES=T0+3.0*B**2*Y*Z**2+B**2*Z**3        
      RETURN                                  
      END                                     
;END;                                         
\end{framedverbatim} 
Another pass of the template processor produced the final file of FORTRAN
code:
\begin{verbatim}
2: GENTRANIN 
2:     "#junk.tem" 
2: OUT "junk.f"$ 
\end{verbatim}
Contents of file {\tt junk.f}:
\begin{framedverbatim}
      SUBROUTINE CALC(X,Y,Z,A,B,RES)          
      REAL X,Y,Z,A,B,RES,T0                 
      X=3.75                                  
      Y=-10.2                                 
      Z=16.473                                
      T0=A**2*X**3+3.0*A**2*X**2*Y            
      T0=T0+3.0*A**2*X**2*Z+3.0*A**2*X*Y**2   
      T0=T0+6.0*A**2*X*Y*Z+3.0*A**2*X*Z**2    
      T0=T0+A**2*Y**3+3.0*A**2*Y**2*Z         
      T0=T0+3.0*A**2*Y*Z**2+A**2*Z**3         
      T0=T0+2.0*A*B*X**3+6.0*A*B*X**2*Y       
      T0=T0+6.0*A*B*X**2*Z+6.0*A*B*X*Y**2     
      T0=T0+12.0*A*B*X*Y*Z+6.0*A*B*X*Z**2     
      T0=T0+2.0*A*B*Y**3+6.0*A*B*Y**2*Z       
      T0=T0+6.0*A*B*Y*Z**2+2.0*A*B*Z**3       
      T0=T0+B**2*X**3+3.0*B**2*X**2*Y         
      T0=T0+3.0*B**2*X**2*Z+3.0*B**2*X*Y**2   
      T0=T0+6.0*B**2*X*Y*Z+3.0*B**2*X*Z**2    
      T0=T0+B**2*Y**3+3.0*B**2*Y**2*Z         
      RES=T0+3.0*B**2*Y*Z**2+B**2*Z**3        
      RETURN                                  
      END                                     
\end{framedverbatim} 

\subsection{Referencing Subprogram and Parameter Names}
\index{"!\$n parameters} \index{"!\$0 subprogram name}
In some code generation applications in which template processing is used,
it is useful to be able to reference the names of the parameters
given in the subprogram header.  For this reason, the special
symbols {\bf !\$1}, {\bf !\$2},~\dots, {\bf !\${\it n}}, where {\it n}
is the number
of parameters, can be used in computations and code generation commands in
active parts of template files.  Each of these symbols will be replaced by
the corresponding parameter name when code is generated.  In addition, the
special symbol {\bf !\$0} will be replaced by the subprogram name.  This is
useful when FORTRAN or RATFOR functions are being generated.  Finally, the
\index{"!\$"!\# in GENTRAN}
special global variable {\bf !\$!\#} is bound to the number of parameters in
the subprogram header.

\section{Output Redirection}\label{GENTRAN:output}
\index{GENTRAN ! file output}
Many examples given thus far in this manual have sent all generated code to
the terminal screen.  In actual code generation applications, however,
code must be sent to a file which will be compiled at a later
time.  This section explains methods of redirecting code to a
file as it is generated.  Any number of output files can be open
simultaneously, and generated code can be sent to any combination
of these open files.

\subsection{File Selection Commands}
\label{file:selection}
\index{OUT command} \index{SHUT command}
REDUCE provides the user with two file handling commands for output
redirection: {\bf OUT} and {\bf SHUT}.  The {\bf OUT} command takes a
single file name as argument and directs all REDUCE output to that
file from then on, until another {\bf OUT} changes the output file, or
{\bf SHUT} closes it.  Output can go to only one file at a time,
although many can be open.  If the file has previously been used for
output during the current job and not {\bf SHUT}, then the new output
is appended onto the end of the file.  Any existing file is erased
before its first use for output in a job.  To output on the terminal
without closing the output file, the reserved file name {\bf T} (for
terminal) may be used.

The REDUCE {\bf SHUT} command takes a list of names of files which
have been previously opened via an {\bf OUT} command and closes them.
Most systems require this action by the user before he ends the REDUCE
job; otherwise the output may be lost.  If a file is {\bf SHUT} and a
further {\bf OUT} command is issued for the same file, the file is
erased before the new output is written.  If it is the current output
file that is {\bf SHUT}, output will switch to the terminal.

These commands are suitable for most applications in which REDUCE
output must be saved.  However, they have two deficiencies when
considered for use in code generation applications.  First, they are
inconvenient.  {\bf OUT} tells REDUCE to direct {\it all\/} output to
a specified file.  Thus in addition to output written as side effects
of functions, returned values are also written to the file (unless the
user is careful to terminate all statements and commands with a {\bf
\$}, in which case only output produced by side effects is written).
If code generation is to be accomplished interactively; i.e., if
algebraic computations and code generation commands are interleaved,
then {\bf OUT} {\it filename\/}{\bf \$} must be issued before every
group of code generation requests, and {\bf OUT T\$} must be issued
after every group.  Secondly, the {\bf OUT} command does not allow
output to be sent to two or more files without reissuing the {\bf OUT}
with another file name.  In an effort to remove these deficiencies and
make the code generation commands flexible and easy to use, separate
file handling commands are provided by GENTRAN which redirect
generated code {\it only}.

\index{GENTRANOUT command} \index{GENTRANSHUT command}
The {\bf GENTRANOUT} and {\bf GENTRANSHUT} commands are identical to
the REDUCE {\bf OUT} and {\bf SHUT} commands with the following
exceptions:

\begin{itemize}
\item {\bf GENTRANOUT} and {\bf GENTRANSHUT} redirect {\it only\/} code which
is printed as a side effect of GENTRAN commands.
\item {\bf GENTRANOUT} allows more than one file name to be given
to indicate that generated code is to be sent to two or more
files.  (It is particularly convenient to be able to
have generated code sent to
the terminal screen and one or more file simultaneously.)
\item {\bf GENTRANOUT} does not automatically erase existing files; it prints
a warning message on the terminal and asks the user whether the existing
file should be erased or the whole command be aborted.
\end{itemize}
The next two subsections describe these commands in detail.

\index{GENTRANOUT command}
\subsubsection{GENTRANOUT}
\begin{describe}{Syntax:}
{\bf GENTRANOUT} {\it f1,f2,\dots\ ,fn;}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each 
{\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom} & = & an output file\\
{\bf T} & = & the terminal\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
GENTRAN maintains a list of files currently open for output by
GENTRAN {\it only}.  {\bf GENTRANOUT} inserts each file name represented by
{\it f1,f2,\dots\ ,fn\/} into that list and opens each one for output.  It
also resets the current output file(s) to be all files in {\it f1,f2,\dots\
 ,fn}.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANOUT} returns the list of files represented by
{\it f1,f2,\dots\ ,fn\/};
i.e., the current output file(s) after the command has been executed.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS
    OVERWRITE FILE? (Y/N)

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}
Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(5,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(.75,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(.7,1.5) {\vector(0,-1){.75}}
\end{picture}}

\begin{verbatim}
1: GENTRANOUT "f1"; 

"f1"
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(5,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(2.25,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(2.2,1.5) {\vector(0,-1){.75}}
\end{picture}}

\begin{verbatim}
2: GENTRANOUT "f2"; 

"f2"
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(5,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(3.75,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(3.7,1.5) {\vector(0,-1){.75}}
\end{picture}}


\begin{verbatim}
3: GENTRANOUT T,"f3"; 

{T,"f3"}
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(4.5,0) {\framebox(1.5,.75){"f3"}}
\put(5.5,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(5.25,1.5) {\vector(0,-1){.75}}
\put(5.45,1.5) {\line(-1,0){4.70}}
\put(.75,1.5) {\vector(0,-1){.75}}
\end{picture}}


\begin{verbatim}
4: GENTRANOUT "f1"; 

"f1"
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(4.5,0) {\framebox(1.5,.75){"f3"}}
\put(2.25,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(2.2,1.5) {\vector(0,-1){.75}}
\end{picture}}

\begin{verbatim}
5: GENTRANOUT NIL,"f4"; 

{"f1","f4"}
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(4.5,0) {\framebox(1.5,.75){"f3"}}
\put(6,0) {\framebox(1.5,.75){"f4"}}
\put(7.5,1.5) {\makebox(0,0)[bl]{\tt current-output}}
\put(6.75,1.5) {\vector(0,-1){.75}}
\put(2.25,1.5) {\vector(0,-1){.75}}
\put(7.45,1.5) {\line(-1,0){5.2}}
\end{picture}}


\ttindex{ALL"!*}
\begin{verbatim}
6: GENTRANOUT ALL!*; 

{"f1","f2","f3","f4"}
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(4.5,0) {\framebox(1.5,.75){"f3"}}
\put(6,0) {\framebox(1.5,.75){"f4"}}
\put(7.5,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(6.75,1.5) {\vector(0,-1){.75}}
\put(5.25,1.5) {\vector(0,-1){.75}}
\put(3.75,1.5) {\vector(0,-1){.75}}
\put(2.25,1.5) {\vector(0,-1){.75}}
\put(7.45,1.5) {\line(-1,0){5.2}}
\end{picture}}

\end{describe}

\subsubsection{GENTRANSHUT}
\index{GENTRANSHUT command}
\begin{describe}{Syntax:}
{\bf GENTRANSHUT} {\it  f1,f2,\dots\ ,fn;\/}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each 
{\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom} & = & an output file\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
{\bf GENTRANSHUT} creates a list of file names from {\it f1,f2,\dots\ ,fn},
deletes each from the output file list, and closes the
corresponding files.  If (all of) the current output file(s) are
closed, then the current output file is reset to the terminal.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANSHUT} returns the current output file(s) after the command has
been executed.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** FILE NOT OPEN FOR OUTPUT

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1,.75){T}}
\put(1,0) {\framebox(1,.75){"f1"}}
\put(2,0) {\framebox(1,.75){"f2"}}
\put(3,0) {\framebox(1,.75){"f3"}}
\put(4,0) {\framebox(1,.75){"f4"}}
\put(5,0) {\framebox(1,.75){"f5"}}
\put(6,0) {\framebox(1,.75){"f6"}}
\put(7,0) {\framebox(1,.75){"f7"}}
\put(2,1.5) {\makebox(0,0) [br]{\tt current-output}}
\put(3.5,1.5) {\vector(0,-1){.75}}
\put(4.5,1.5) {\vector(0,-1){.75}}
\put(7.5,1.5) {\vector(0,-1){.75}}
\put(2.05,1.5) {\line(1,0){5.45}}
\end{picture}}

\begin{verbatim}
1: GENTRANSHUT "f1","f2","f7"; 

{"f3","f4"}
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1,.75){T}}
\put(1,0) {\framebox(1,.75){"f3"}}
\put(2,0) {\framebox(1,.75){"f4"}}
\put(3,0) {\framebox(1,.75){"f5"}}
\put(4,0) {\framebox(1,.75){"f6"}}
\put(4.5,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(1.5,1.5) {\vector(0,-1){.75}}
\put(2.5,1.5) {\vector(0,-1){.75}}
\put(4.45,1.5) {\line(-1,0){2.95}}
\end{picture}}

\begin{verbatim}
2: GENTRANSHUT NIL; 

T
\end{verbatim}
Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1,.75){T}}
\put(1,0) {\framebox(1,.75){"f5"}}
\put(2,0) {\framebox(1,.75){"f6"}}
\put(.55,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(.5,1.5) {\vector(0,-1){.75}}
\end{picture}}

\begin{verbatim}
3: GENTRANSHUT ALL!*; 

T
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1,.75){T}}
\put(.55,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(.5,1.5) {\vector(0,-1){.75}}
\end{picture}}

\end{describe}

\subsection{The Output File Stack}
Section~\ref{file:selection}
\index{files ! in GENTRAN} 
explained the {\bf GENTRANOUT} and {\bf GENTRANSHUT}
commands which are very similar to the REDUCE {\bf OUT} and {\bf SHUT}
commands but redirect {\it only code generated as side effects of GENTRAN
commands\/} to files.  This section describes another pair of file
handling commands provided by GENTRAN.

In some code generation applications it may be convenient to be
able to send generated code to one (set of) file(s), then
temporarily send code to another (set of) file(s), and later
resume sending generated code to the first (set of) file(s).  In
other words, it is convenient to think of the output files as
being arranged in a stack which can be pushed whenever new
files are to be written to temporarily, and popped whenever
previously written-to files are to be appended onto.  {\bf GENTRANPUSH}
\index{GENTRANPUSH command} \index{GENTRANPOP command}
and {\bf GENTRANPOP} enable the user to manipulate a stack of open
output files in these ways.

{\bf GENTRANPUSH} simply pushes a (set of) file(s) onto
the stack and opens each one that is not already open for
output.  {\bf GENTRANPOP} deletes the top-most occurrence of
the given file(s) from the stack and closes each one that is no
longer in the stack.  The stack is initialized to one element:  the
terminal.  This element is always on the bottom of the stack, and thus,
is the default output file.  The current output file is always the
file(s) on top of the stack.

\subsubsection{GENTRANPUSH}
\index{GENTRANPUSH command}
\begin{describe}{Syntax:}
{\bf GENTRANPUSH} {\it f1,f2,\dots\ ,fn;}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each
{\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom} & = & an output file\\
{\bf T} & = & the terminal\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
{\bf GENTRANPUSH} creates a list of file name(s) represented by
{\it f1,f2,\dots\ ,fn\/} and pushes that list onto the output stack.  Each file
in the list that is not already open for output is opened at this time.  The
current output file is reset to this new element on the top of the stack.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANPUSH} returns the list of files represented by 
{\it f1,f2,\dots\ ,fn\/};
i.e., the current output file(s) after the command has been executed.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS
    OVERWRITE FILE? (Y/N)

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,1)(0,0)
\put(0,0) {\framebox(3,1){}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,.5) {\vector(-1,0){1}}
\put(4.1,.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}


\begin{verbatim}
1: GENTRANPUSH "f1"; 

"f1"
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,1.5)(0,0)
\put(0,0) {\framebox(3,1.5){}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,1) {\vector(-1,0){1}}
\put(4.1,1) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
2: GENTRANPUSH "f2","f3"; 

{"f2","f3"}
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(3,2){}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,1.5) {\vector(-1,0){1}}
\put(4.1,1.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
3: GENTRANPUSH NIL,T; 

{"f2","f3",T}
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2.5)(0,0)
\put(0,0) {\framebox(3,2.5){}}
\put(0.25,2) {\makebox(0,0)[cl]{"f2" "f3" T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,2) {\vector(-1,0){1}}
\put(4.1,2) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
4: GENTRANPUSH "f1"; 

"f1"
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,3)(0,0)
\put(0,0) {\framebox(3,3){}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,2) {\makebox(0,0)[cl]{"f2" "f3" T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,2.5) {\vector(-1,0){1}}
\put(4.1,2.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
5: GENTRANPUSH ALL!*; 

{"f1","f2","f3"}
\end{verbatim}

Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,3.5)(0,0)
\put(0,0) {\framebox(3,3.5){}}
\put(0.25,3) {\makebox(0,0)[cl]{"f1" "f2" "f3"}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,2) {\makebox(0,0)[cl]{"f2" "f3" T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,3) {\vector(-1,0){1}}
\put(4.1,3) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\end{describe}

\subsubsection{GENTRANPOP}
\index{GENTRANPOP command}
\begin{describe}{Syntax:}
{\bf GENTRANPOP} {\it f1,f2,\dots\ ,fn;}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each 
{\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom} & = & an output file\\
{\bf T} & = & the terminal\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
{\bf GENTRANPOP} deletes the top-most occurrence of the single element
containing the file name(s) represented by {\it f1,f2,\dots\ ,fn\/}
from the output stack.  Files whose names have been completely removed from
the output stack are closed.  The current output file is reset to the
(new) element on the top of the output stack.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANPOP} returns the current output file(s) after this command
has been executed.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** FILE NOT OPEN FOR OUTPUT

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,4)(0,0)
\put(0,0) {\framebox(3,4){}}
\put(0.25,3.5) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,3) {\makebox(0,0)[cl]{"f4" "f2" T}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,2) {\makebox(0,0)[cl]{T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f2" "f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,3.5) {\vector(-1,0){1}}
\put(4.1,3.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
1: GENTRANPOP NIL; 

{"f4","f2",T}
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,3.5)(0,0)
\put(0,0) {\framebox(3,3.5){}}
\put(0.25,3) {\makebox(0,0)[cl]{"f4" "f2" T}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,2) {\makebox(0,0)[cl]{T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f2" "f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,3) {\vector(-1,0){1}}
\put(4.1,3) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
2: GENTRANPOP NIL; 

"f4"
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,3)(0,0)
\put(0,0) {\framebox(3,3){}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,2) {\makebox(0,0)[cl]{T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f2" "f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,2.5) {\vector(-1,0){1}}
\put(4.1,2.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
3: GENTRANPOP "f2","f1"; 

"f4"
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2.5)(0,0)
\put(0,0) {\framebox(3,2.5){}}
\put(0.25,2) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,1.5) {\makebox(0,0)[cl]{T}}
\put(0.25,1) {\makebox(0,0)[cl]{"f3"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,2) {\vector(-1,0){1}}
\put(4.1,2) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
4: GENTRANPOP ALL!*; 

T
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,1)(0,0)
\put(0,0) {\framebox(3,1){}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,.5) {\vector(-1,0){1}}
\put(4.1,.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\end{describe}

\subsection{Temporary Output Redirection}
Sections~\ref{translation} and ~\ref{templates}
explain how to use the code generation and
template processing commands.  The syntax for these two commands
is:
\index{output redirection (temporary)}
\index{GENTRAN command} \index{GENTRANIN command}

\begin{tabular}{lll}
&\multicolumn{2}{l}{{\bf GENTRAN} {\it stmt\/} [{\bf OUT} {\it f1,f2,\dots\
 ,fn\/}]{\it ;}}\\
&&and\\
&\multicolumn{2}{l}{{\bf GENTRANIN} {\it f1,f2,\dots\ ,fm\/} [{\bf OUT}
 {\it  f1,f2,\dots\ ,fn\/}]{\it ;}}\\
\end{tabular}

The optional parts of these two commands can be used for {\it temporary}
output redirection; they can be used when the current output
file is to be temporarily reset, for this command only.

Thus the following two sequences of commands are equivalent:
\begin{verbatim}
10: GENTRANPUSH "f1",T$ 

11: GENTRAN ... $

12: GENTRANPOP NIL$
\end{verbatim}

and

\begin{verbatim}
10: GENTRAN 
10:    ...
10: OUT "f1",T$
\end{verbatim}

\section{Modification of the Code Generation Process}\label{GENTRAN:mod}

GENTRAN is designed to be flexible enough to be used in a variety of
code generation applications.  For this reason, several mode
switches and variables are provided to enable the user to tailor the
code generation process to meet his or her particular needs.

\subsection{Mode Switches}
\index{GENTRAN package ! switches}
The following GENTRAN mode switches can be turned on and off with the
REDUCE {\bf ON} and {\bf OFF} commands.

\begin{describe}{DOUBLE}
\index{DOUBLE switch} \index{precision}
\begin{itemize}
\item When turned on, causes (where appropriate):
\begin{itemize}
\item floating point numbers to be printed in double precision format;
\item intrinsic functions to be replaced by their double precision
counterparts;
\item generated type declarations to be of double precision form.
\end{itemize}
See also section~\ref{precision} on page~\pageref{precision}.
\item default setting: off
\end{itemize}
\end{describe}

\begin{describe}{GENDECS}
\index{GENDECS switch}
\begin{itemize}
\item when turned on, allows type declarations to be generated automatically;
otherwise, type information is stored in but not automatically retrieved
from the symbol table.  See also sections~\ref{explicit:type} on
page~\pageref{explicit:type}, \ref{more:type} on page~\pageref{more:type},
and \ref{template:type} on page~\pageref{template:type}.
\item default setting:  on
\end{itemize}
\end{describe}

\begin{describe}{GENTRANOPT}
\index{GENTRANOPT switch}
\begin{itemize}
\item when turned on, replaces each block of straightline code by
an optimized sequence of assignments.
The Code Optimizer takes a sequence of assignments and replaces common
subexpressions with temporary variables.  It returns the resulting assignment
statements with common-subexpression-to-temporary-variable assignment
statements preceding them
\item default setting:  off
\end{itemize} 
\end{describe} 

\begin{describe}{GENTRANSEG} 
\index{GENTRANSEG switch}
\begin{itemize}
\item when turned on, checks the print length of expressions and breaks
those expressions that are longer than {\bf MAXEXPPRINTLEN!*} down
\ttindex{MAXEXPPRINTLEN"!*}
into subexpressions which are assigned to temporary variables.
See also section~\ref{segmentation} on page~\pageref{segmentation}.
\item default setting:  on
\end{itemize}
\end{describe}

\begin{describe}{GETDECS}
\index{GETDECS switch}
\begin{itemize}
\item when on, causes:
\begin{itemize}
\item the indices of loops to be declared integer;
\item objects without an explicit type declaration to be declared of the type
given by the variable {\bf DEFTYPE!*}. \ttindex{DEFTYPE"!*}
\end{itemize}
See also section~\ref{implicit:type} on page~\pageref{implicit:type}.
\item default setting:  off
\end{itemize}
\end{describe}

\begin{describe}{KEEPDECS}
\index{KEEPDECS switch}
\begin{itemize}
\item when on, prevents declarations being removed from the symbol table when
type declarations are generated.
\item default: off
\end{itemize}
\end{describe}

\begin{describe}{MAKECALLS}
\index{MAKECALLS switch}
\begin{itemize}
\item when turned on, causes GENTRAN to translate functional expressions as
subprogram calls.
\item default setting: on
\end{itemize}
\end{describe}

\begin{describe}{PERIOD}
\index{PERIOD switch}
\begin{itemize}
\item when turned on, causes all integers to be printed out as floating point
numbers except:
\begin{itemize}
\item exponents;
\item variable subscripts;
\item index values in DO-type loops;
\item those which have been declared to be integers.
\end{itemize}
\item default setting:  on
\end{itemize}
\end{describe}


\subsection{Variables}
\index{GENTRAN package ! variables}
Several global variables are provided in GENTRAN to enable the
user to
\begin{itemize}
\item select the target language
\item control expression segmentation
\item change automatically generated variable names and statement numbers
\item modify the code formatter
\end{itemize}

The following four subsections describe these variables\footnote{
Note that when an atomic value (other than an integer) is assigned to a
variable, that value must be quoted.  For example,
{\bf GENTRANLANG!* := 'FORTRAN\$}
assigns the atom {\bf FORTRAN} to the variable {\bf GENTRANLANG!*}.}.

\subsubsection{Target Language Selection}
\begin{describe}{GENTRANLANG!*}
\ttindex{GENTRANLANG"!*}
\begin{itemize}
\item target language (FORTRAN, RATFOR, PASCAL or C)
See also section~\ref{gentranlang} on page~\pageref{gentranlang}.
\item value type:  atom
\item default value:  FORTRAN
\end{itemize}
\end{describe}

\subsubsection{Expression Segmentation Control}
\begin{describe}{MAXEXPPRINTLEN!*}
\ttindex{MAXEXPPRINTLEN"!*}
\begin{itemize}
\item value used to determine whether or not an expression should be
segmented; maximum number of characters permitted in an expression
in the target language (excluding spaces printed for formatting).
See also section~\ref{segmentation} on page~\pageref{segmentation}.
\item value type:  integer
\item default value:  800
\end{itemize}
\end{describe} 

\subsubsection{Variable Names \& Statement Numbers}
\begin{describe}{TEMPVARNAME!*}
\ttindex{TEMPVARNAME"!*}
\begin{itemize}
\item name used as prefix in generating temporary variable names.
See also section~\ref{tempvars} on page~\pageref{tempvars}.
\item value type:  atom
\item default value:  T
\end{itemize}
\end{describe}

\begin{describe}{TEMPVARNUM!*}
\ttindex{TEMPVARNUM"!*}
\begin{itemize}
\item number appended to {\bf TEMPVARNAME!*} to create a temporary variable
name. If the temporary variable name resulting from appending
{\bf TEMPVARNUM!*} onto {\bf TEMPVARNAME!*} has already been generated
and still holds a useful value, then {\bf TEMPVARNUM!*} is incremented
and temporary variable names are compressed until one is found which
was not previously generated or does not still hold a significant value.
See also section~\ref{tempvars} on page~\pageref{tempvars}.
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{TEMPVARTYPE!*}
\ttindex{TEMPVARTYPE"!*}
\begin{itemize}
\item target language variable type (e.g., INTEGER, REAL!*8, FLOAT, etc) used
as a default for automatically generated variables whose type cannot be
determined otherwise.  If {\bf TEMPVARTYPE!*} is NIL, then generated
temporary variables whose type cannot be determined are not automatically
declared.  See also section~\ref{tempvars} on page~\pageref{tempvars}.
\item value type:  atom
\item default value:  NIL
\end{itemize}
\end{describe}

\begin{describe}{GENSTMTNUM!*}
\ttindex{GENSTMTNUM"!*}
\begin{itemize}
\item number used when a statement number must be generated
\item value type:  integer
\item default value:  25000
\end{itemize}
\end{describe}

\begin{describe}{GENSTMTINCR!*}
\ttindex{GENSTMTINCR"!*}
\begin{itemize}
\item number by which {\bf GENSTMTNUM!*} is increased each time a new
statement number is generated.
\item value type:  integer
\item default value:  1
\end{itemize}
\end{describe}

\begin{describe}{DEFTYPE!*}
\ttindex{DEFTYPE"!*}
\begin{itemize}
\item default type for objects when the switch {\bf GETDECS} is on.  See also
section~\ref{implicit:type} on page~\pageref{implicit:type}.
\item value type: atom
\item default value: real
\end{itemize}
\end{describe}

\subsubsection{Code Formatting}
\begin{describe}{FORTCURRIND!*}
\ttindex{FORTCURRIND"!*}
\begin{itemize}
\item number of blank spaces printed at the beginning of each line of
generated FORTRAN code beyond column 6
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{RATCURRIND!*}
\ttindex{RATCURRIND"!*}
\begin{itemize}
\item number of blank spaces printed at the beginning of each line of
generated RATFOR code.
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{CCURRIND!*}
\ttindex{CCURRIND"!*}
\begin{itemize}
\item number of blank spaces printed at the beginning of each line of
generated C code.
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{PASCCURRIND!*}
\ttindex{PASCCURRIND"!*}
\begin{itemize}
\item number of blank spaces printed at the beginning of each line of
generated PASCAL code.
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{TABLEN!*}
\ttindex{TABLEN"!*}
\begin{itemize}
\item number of blank spaces printed for each new level of indentation.
\item value type:  integer
\item default value:  4
\end{itemize}
\end{describe}

\begin{describe}{FORTLINELEN!*}
\ttindex{FORTLINELEN"!*}
\begin{itemize}
\item maximum number of characters printed on each line of generated FORTRAN
code.
\item value type:  integer
\item default value:  72
\end{itemize}
\end{describe}

\begin{describe}{RATLINELEN!*}
\ttindex{RATLINELEN"!*}
\begin{itemize}
\item maximum number of characters printed on each line of generated RATFOR
code.
\item value type:  integer
\item default value:  80
\end{itemize}
\end{describe}

\begin{describe}{CLINELEN!*}
\ttindex{CLINELEN"!*}
\begin{itemize}
\item maximum number of characters printed on each line of generated C code.
\item value type:  integer
\item default value:  80
\end{itemize} 
\end{describe}

\begin{describe}{PASCLINELEN!*}
\ttindex{PASCLINELEN"!*}
\begin{itemize}
\item maximum number of characters printed on each line of generated PASCAL
code.
\item value type:  integer
\item default value:  70
\end{itemize}
\end{describe}

\begin{describe}{MINFORTLINELEN!*}
\ttindex{MINFORTLINELEN"!*}
\begin{itemize}
\item minimum number of characters printed on each line of generated FORTRAN
code after indentation.
\item value type:  integer
\item default value:  40
\end{itemize} 
\end{describe}

\begin{describe}{MINRATLINELEN!*}
\ttindex{MINRATLINELEN"!*}
\begin{itemize}
\item minimum number of characters printed on each line of generated RATFOR
code after indentation.
\item value type:  integer
\item default value:  40
\end{itemize} 
\end{describe}
 
\begin{describe}{MINCLINELEN!*}
\ttindex{MINCLINELEN"!*}
\begin{itemize}
\item minimum number of characters printed on each line of generated C
code after indentation.
\item value type:  integer
\item default value:  40
\end{itemize} 
\end{describe}

\begin{describe}{MINPASCLINELEN!*}
\ttindex{MINPASCLINELEN"!*}
\begin{itemize}
\item minimum number of characters printed on each line of generated PASCAL
code after indentation.
\item value type:  integer
\item default value:  40
\end{itemize} 
\end{describe} 

\section{Examples}\label{GENTRAN:examples}
\index{GENTRAN package ! example}

Short examples have been given throughout this manual to illustrate
usage of the GENTRAN commands.  This section gives complete code
generation examples.

\subsection{Interactive Code Generation} \index{GENTRAN package ! example}
\index{interactive code generation}
Suppose we wish to generate a FORTRAN subprogram which can be used for
\index{Graeffe's Root-Squaring Method}
computing the roots of a polynomial by Graeffe's Root-Squaring Method\footnote{
This is for instance convenient for ill-conditioned polynomials.  More
details are given in {\it Introduction to Numerical Analysis\/} by
C. E. Froberg, Addison-Wesley Publishing Company, 1966.}. This
method states that the roots $x_i$ of a polynomial
$$P_n(x) = \sum_{i=0}^{n}{a_i x^{n-i}} $$
can be found by constructing the polynomial
$$P^{*}_n\left({x^2}\right) = \left( a_0x^n + a_2x^{n-2} + \dots\right)^2 -
\left( a_1x^{n-1} + a_3x^{n-3} + \dots\right)^2$$
with roots $x_i^2$
When read into REDUCE, the following file of REDUCE statements
will place the coefficients of $P^{*}_n$
into the list B for some user-entered value of n greater than zero.

Contents of file {\tt graeffe.red}:\footnote{
In accordance with section~\ref{explicit:type},
the subscripts of A are I+1 instead of I.}
\begin{framedverbatim}
OPERATOR A$                                               
Q := FOR I := 0 STEP 2 UNTIL n   SUM (A(I+1)*X^(n-I))$
R := FOR I := 1 STEP 2 UNTIL n-1 SUM (A(I+1)*X^(n-I))$    
P := Q^2 - R^2$                                           
LET X^2 = Y$                                              
B := COEFF(P,Y)$                                             
END$                                                      
\end{framedverbatim}

Now a numerical subprogram can be generated with assignment
statements for the coefficients of $P^{*}_n$ (now stored in list B in
REDUCE).  Since these coefficients are given in terms of the coefficients
of $P_n$ (i.e., operator A in REDUCE), the subprogram will need two
parameters:  A and B, each of which must be arrays of size n+1.

The following REDUCE session will create subroutine GRAEFF for a polynomial
of degree n=10 and write it to file {\tt graeffe.f}:
{\small
\begin{verbatim}
1: n := 10$ 

2: IN "graeffe.red"$

3: GENTRANLANG!* := 'FORTRAN$ 

4: ON DOUBLE$

5: GENTRAN 
5: ( 
5:      PROCEDURE GRAEFF(A,B); 
5:      BEGIN 
5:      DECLARE 
5:      << 
5:          GRAEFF : SUBROUTINE; 
5:          A(11),B(11) : REAL
5:      >>; 
5:      LITERAL 
5:       "C",CR!*, 
5:       "C",TAB!*,"GRAEFFE ROOT-SQUARING METHOD TO FIND",CR!*,
5:       "C",TAB!*,"ROOTS OF A POLYNOMIAL",CR!*, 
5:       "C",CR!*; 
5:      B(1) :=: PART (B,1);
5:      B(2) :=: PART (B,2);
5:      B(3) :=: PART (B,3);
5:      B(4) :=: PART (B,4);
5:      B(5) :=: PART (B,5);
5:      B(6) :=: PART (B,6);
5:      B(7) :=: PART (B,7);
5:      B(8) :=: PART (B,8);
5:      B(9) :=: PART (B,9);
5:      B(10) :=: PART (B,10);
5:      B(11) :=: PART (B,11)
5:      END 
5: ) 
5: OUT "graeffe.f"$ 
\end{verbatim}
}

Contents of file {\tt graeffe.f}:
\begin{framedverbatim}
      SUBROUTINE GRAEFF(A,B)
      DOUBLE PRECISION A(11),B(11)
C
C     GRAEFFE ROOT-SQUARING METHOD TO FIND
C     ROOTS OF A POLYNOMIAL
C
      B(1)=A(11)**2
      B(2)=2.0D0*A(11)*A(9)-A(10)**2
      B(3)=2.0D0*A(11)*A(7)-(2.0D0*A(10)*A(8))+A(9)**2
      B(4)=2.0D0*A(11)*A(5)-(2.0D0*A(10)*A(6))+2.0D0*A(9)*A(7
     . )-A(8)**2
      B(5)=2.0D0*A(11)*A(3)-(2.0D0*A(10)*A(4))+2.0D0*A(9)*A(5
     . )-(2.0D0*A(8)*A(6))+A(7)**2
      B(6)=2.0D0*A(11)*A(1)-(2.0D0*A(10)*A(2))+2.0D0*A(9)*A(3
     . )-(2.0D0*A(8)*A(4))+2.0D0*A(7)*A(5)-A(6)**2
      B(7)=2.0D0*A(9)*A(1)-(2.0D0*A(8)*A(2))+2.0D0*A(7)*A(3)-
     . (2.0D0*A(6)*A(4))+A(5)**2
      B(8)=2.0D0*A(7)*A(1)-(2.0D0*A(6)*A(2))+2.0D0*A(5)*A(3)-
     . A(4)**2
      B(9)=2.0D0*A(5)*A(1)-(2.0D0*A(4)*A(2))+A(3)**2
      B(10)=2.0D0*A(3)*A(1)-A(2)**2
      B(11)=A(1)**2
      RETURN
      END
\end{framedverbatim}

\subsection{Code Generation, Segmentation \& Temporary Variables}
\index{GENTRAN package ! example}
The following 3 x 3 inertia matrix M was derived in the course of
some research \footnote{For details see:
Bos, A. M. and M. J. L. Tiernego.  ``Formula Manipulation in the
Bond Graph Modelling and Simulation of Large Mechanical Systems'',
{\it Journal of the Franklin Institute} , Pergamon Press Ltd.,
Vol. 319, No. 1/2, pp. 51-65, January/February 1985.}:
\begin{eqnarray*}
M(1,1) & = & 18*\cos (q_3)*\cos (q_2)*m_{30}*p^2 - \sin ^2(q_3) *j_{30}y +
 \sin ^2(q_3) \\
  & & *j_{30}z - 9*\sin ^2(q_3) *m_{30}*p^2  + j_{10}y + j_{30}y +
 m_{10}*p^2  + \\
 & & 18*m_{30}*p^2\\
M(1,2) & = & 9*\cos (q_3)*\cos (q_2)*m_{30}*p^2  - \sin ^2(q_3) *j_{30}y
 +\sin ^2(q_3) \\
  & & *j_{30}z - 9*\sin ^2(q_3) *m_{30}*p^2 + j_{30}y + 9* m_{30}*p^2\\
M(2,1) & = & M(1,2)\\
M(1,3) & = & - 9*\sin (q_3)*\sin (q_2)*m_{30}*p^2\\
M(3,1) & = & M(1,3)\\
M(2,2) & = & - \sin ^2(q_3) *j_{30}y + \sin ^2(q_3) *j_{30}z -
 9*\sin ^2(q_3)*m_{30}*p^2 \\
& & + j_{30}y + 9*m_{30}*p^2\\
M(2,3) & = & 0\\
M(3,2) & = & M(2,3)\\
M(3,3) & = & 9*m_{30}*p^2 + j_{30}x\\
\end{eqnarray*}
We know M is symmetric.  We wish to generate numerical code
to compute values for M and its inverse matrix.

\subsubsection{Code Generation}
\label{code:example}
Generating code for matrix M and its inverse matrix is
straightforward.  We can simply generate an assignment statement
for each element of M, compute the inverse matrix MIV, and generate
an assignment statement for each element of MIV.  Since we
know M is symmetric, we know that MIV will also be symmetric.  To
avoid duplicate computations, we will not generate assignments
for elements below the main diagonals of these matrices.  Instead,
we will copy elements across the main diagonal by generating
nested loops.  The following REDUCE session will write to the file {\tt m1.f}:

\begin{verbatim}
1: IN "m.red"$ % Initialize M

2: GENTRANOUT "m1.f"$ 

3: GENTRANLANG!* := 'FORTRAN$

4: ON DOUBLE$

5: FOR J := 1 : 3 DO 
5:      FOR K := J : 3 DO 
5:          GENTRAN M(J,K) ::=: M(J,K)$

6: MIV := M^(-1)$ 

7: FOR J := 1 : 3 DO 
7:      FOR K := J : 3 DO 
7:          GENTRAN MIV(J,K) ::=: MIV(J,K)$

8: GENTRAN 
8:      FOR J := 1 : 3 DO 
8:          FOR K := J+1 : 3 DO 
8:          << 
8:              M(K,J) := M(J,K); 
8:              MIV(K,J) := MIV(J,K) 
8:          >>$ 

9: GENTRANSHUT "m1.f"$
\end{verbatim}
The contents of {\tt m1.f} are reproduced in~\ref{appc} on page~\pageref{appc}.

This code was generated with the segmentation facility turned off.  However,
most FORTRAN compilers cannot handle statements more than 20 lines
long.  The next section shows how to generate segmented assignments.

\subsubsection{Segmentation}
\label{seg:example}
\index{segmented assignments}
Large arithmetic expressions can be broken into pieces of manageable
size with the expression segmentation facility.  The following REDUCE
session will write segmented assignment statements to the
file {\tt m2.f}.  Large arithmetic expressions will be broken into
subexpressions of approximately 300 characters in length.

\begin{verbatim}
1: IN "m.red"$ % Initialize M

2: GENTRANOUT "m2.f"$ 

3: ON DOUBLE$

4: ON GENTRANSEG$ 

5: MAXEXPPRINTLEN!* := 300$ 

6: FOR J := 1 : 3 DO 
6:      FOR K := J : 3 DO 
6:          GENTRAN M(J,K) ::=: M(J,K)$ 

7: MIV := M^(-1)$ 

8: FOR J := 1 : 3 DO 
8:      FOR K := J : 3 DO 
8:          GENTRAN MIV(J,K) ::=: MIV(J,K)$ 

9: GENTRAN 
9:      FOR J := 1 : 3 DO 
9:          FOR K := J+1 : 3 DO 
9:          << 
9:              M(K,J) := M(J,K); 
9:              MIV(K,J) := MIV(J,K) 
9:          >>$ 

10: GENTRANSHUT "m2.f"$ 
\end{verbatim}

The contents of file {\tt m2.f} are reproduced in~\ref{appc} on
page~\pageref{appc}.

\subsubsection{Generation of Temporary Variables to Suppress Simplification}
\label{tempvar:example}
We can dramatically improve the efficiency of the code generated
in sections~\ref{code:example} on page~\pageref{code:example} and
\ref{seg:example} on page~\pageref{seg:example}
by replacing expressions by temporary variables before computing the
inverse matrix.  This effectively suppresses simplification; these
expressions will not be substituted into later computations.  We
will replace each non-zero element of the REDUCE matrix M by a
generated variable name, and generate a numerical assignment statement
to reflect that substitution in the numerical program being generated.

The following REDUCE session will write to the file {\tt m3.f}:
\begin{verbatim}
1: in "m.red"$ % Initialize M

2: GENTRANOUT "m3.f"$ 

3: GENTRANLANG!* := 'FORTRAN$ 

4: ON DOUBLE$

5: FOR J := 1 : 3 DO 
5:      FOR K := J : 3 DO 
5:          GENTRAN M(J,K) ::=: M(J,K)$ 

6: SHARE VAR$ 

7: FOR J := 1 : 3 DO 
7:      FOR K := J : 3 DO 
7:          IF M(J,K) NEQ 0 THEN 
7:          << 
7:              VAR := TEMPVAR(NIL)$ 
7:              MARKVAR VAR$ 
7:              M(J,K) := VAR$ 
7:              M(K,J) := VAR$ 
7:              GENTRAN 
7:                  EVAL(VAR) := M(EVAL(J),EVAL(K)) 
7:          >>$ 

8: COMMENT ** Contents of matrix M: **$ 

9: M; 

[T0  T1  T2]
[          ]
[T1  T3  0 ]
[          ]
[T2  0   T4]


10: MIV := M^(-1)$ 

11: FOR J := 1 : 3 DO 
11:      FOR K := J : 3 DO 
11:          GENTRAN MIV(J,K) ::=: MIV(J,K)$ 

12: GENTRAN 
12:      FOR J := 1 : 3 DO 
12:          FOR K := J+1 : 3 DO 
12:          << 
12:              M(K,J) := M(J,K); 
12:              MIV(K,J) := MIV(J,K) 
12:          >>$ 

13: GENTRANSHUT "m3.f"$ 
\end{verbatim}

Contents of file {\tt m3.f}:

\begin{framedverbatim}
      M(1,1)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*Y*J30)+DSIN(DBLE(Q3))**2*J30Z+18.0D0*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**2*M30+18.0D0*P**2*M30+P**2*M10
     . +J30Y+J10Y
      M(1,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*DCOS(DBLE(
     . Q3))*DCOS(DBLE(Q2))*P**2*M30+9.0D0*P**2*M30+J30Y
      M(1,3)=-(9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30)
      M(2,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*P**2*M30+
     . J30Y
      M(2,3)=0.0D0
      M(3,3)=9.0D0*P**2*M30+J30X
      T0=M(1,1)
      T1=M(1,2)
      T2=M(1,3)
      T3=M(2,2)
      T4=M(3,3)
      MIV(1,1)=-(T4*T3)/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      MIV(1,2)=(T4*T1)/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      MIV(1,3)=(T2*T3)/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      MIV(2,2)=(-(T4*T0)+T2**2)/(T4*T1**2-(T4*T3*T0)+T2**2*
     . T3)
      MIV(2,3)=-(T1*T2)/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      MIV(3,3)=(T1**2-(T3*T0))/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      DO 25009 J=1,3
          DO 25010 K=J+1,3
              M(K,J)=M(J,K)
              MIV(K,J)=MIV(J,K)
25010     CONTINUE
25009 CONTINUE
\end{framedverbatim}

\subsection{Template Processing} \index{template processing}
\index{GENTRAN package ! example} \index{Automatic Circuitry Code Generator}
Circuit simulation plays a vital role in computer hardware
development.  A recent paper\footnote{Loe, K. F., N. Ohsawa, and E.
Goto.  ``Design of an Automatic Circuitry Code Generator (ACCG)'',
{\it RSYMSAC Proceedings}, Wako-shi, Saitama, Japan.  1984.} describes
the design of an Automatic Circuitry Code Generator (ACCG), which
generates circuit simulation programs based on user-supplied circuit
specifications.  The actual code generator consists of a series of
REDUCE {\bf WRITE} statements, each of which writes one line of
FORTRAN code.

This section presents an alternative implementation for the ACCG
which uses GENTRAN's template processor to generate code.  Template
processing is a much more natural method of code generation than the
REDUCE {\bf WRITE} statement method.

First we will put all REDUCE calculations into two files:  {\tt rk.red} and
{\tt ham.red}.

Contents of file {\tt rk.red}:\footnote{
Line 11 of procedure RUNGEKUTTA was changed from
\begin{center}
{\tt K41 := HH*SUB(TT=TT+HH, P=P+K31, Q=Q+K32, P2);}
\end{center}
as given in (Loe84), to
\begin{center}
{\tt K42 := HH*SUB(TT=TT+HH, P=P+K31, Q=Q+K32, P2);}
\end{center}
}
\begin{framedverbatim}
COMMENT  -- RUNGE-KUTTA METHOD --$                        
PROCEDURE RUNGEKUTTA(P1, P2, P, Q, TT);                   
BEGIN                                                     
SCALAR K11,K12,K21,K22,K31,K32,K41,K42;                   
K11 := HH*P1;                                             
K12 := HH*P2;                                             
K21 := HH*SUB(TT=TT+HH/2, P=P+K11/2, Q=Q+K12/2, P1);      
K22 := HH*SUB(TT=TT+HH/2, P=P+K11/2, Q=Q+K12/2, P2);      
K31 := HH*SUB(TT=TT+HH/2, P=P+K21/2, Q=Q+K22/2, P1);      
K32 := HH*SUB(TT=TT+HH/2, P=P+K21/2, Q=Q+K22/2, P2);      
K41 := HH*SUB(TT=TT+HH,   P=P+K31,   Q=Q+K32,   P1);      
K42 := HH*SUB(TT=TT+HH,   P=P+K31,   Q=Q+K32,   P2);
PN := P + (K11 + 2*K21 + 2*K31 + K41)/6;                  
QN := Q + (K12 + 2*K22 + 2*K32 + K42)/6                   
END$                                                      
END$                                                      
\end{framedverbatim}

Contents of file {\tt ham.red}:

\begin{framedverbatim}
COMMENT  -- HAMILTONIAN CALCULATION --$                   
DIFQ := DF(H,P)$                                          
DIFP := -DF(H,Q) - SUB(QDOT=P/M, DF(D,QDOT))$             
RUNGEKUTTA(DIFP, DIFQ, P, Q, TT)$                         
END$                                                      
\end{framedverbatim}

Next we will create a template file with an outline of the target
FORTRAN program and GENTRAN commands.

Contents of file {\tt runge.tem}:

\begin{framedverbatim}
      PROGRAM RUNGE                                       
      IMPLICIT DOUBLE PRECISION (K,M)                                 
C                                                         
C  INPUT                                                  
C                                                         
      WRITE(6,*) 'INITIAL VALUE OF P'                     
      READ(5,*) P                                         
      WRITE(6,*) ' P = ', P                               
      WRITE(6,*) 'INITIAL VALUE OF Q'                     
      READ(5,*) Q                                         
      WRITE(6,*) ' Q = ', Q                               
      WRITE(6,*) 'VALUE OF M'                             
      READ(5,*) M                                         
      WRITE(6,*) ' M = ', M                               
      WRITE(6,*) 'VALUE OF K0'                            
      READ(5,*) K0                                        
      WRITE(6,*) ' K0 = ', K0                             
      WRITE(6,*) 'VALUE OF B'                             
      READ(5,*) B                                         
      WRITE(6,*) ' B = ', B                               
      WRITE(6,*) 'STEP SIZE OF T'                         
      READ(5,*) HH                                        
      WRITE(6,*) ' STEP SIZE OF T = ', HH                 
      WRITE(6,*) 'FINAL VALUE OF T'                       
      READ(5,*) TP                                        
      WRITE(6,*) ' FINAL VALUE OF T = ', TP               
C                                                         
C  INITIALIZATION                                         
C                                                         
      TT=0.0D0
;BEGIN;  
      GENTRAN                                             
        LITERAL                                           
          TAB!*, "WRITE(9,*) ' H = ", EVAL(H), "'", CR!*, 
          TAB!*, "WRITE(9,*) ' D = ", EVAL(D), "'", CR!*$ 
;END;                                                     
      WRITE(9,901) C                                      
901   FORMAT(' C= ',D20.10)                               
      WRITE(9,910) TT, Q, P                               
910   FORMAT(' '3D20.10)                                  
C                                                         
C  LOOP                                                   
C                                                         
;BEGIN;                                                   
      GENTRAN                                             
          REPEAT                                          
          <<                                              
              PN :=: PN;                                  
              Q  :=: QN;                                  
              P  := PN;                                   
              TT := TT + HH;                              
              LITERAL                                     
                TAB!*, "WRITE(9,910) TT, QQ, P", CR!*     
          >>                                              
          UNTIL TT >= TF$                                 
;END;                                                     
      STOP                                                
      END                                                 
;END;                                                     
\end{framedverbatim}

Now we can generate a circuit simulation program simply by starting
a REDUCE session and following three steps:
\begin{enumerate}
\item Enter circuit specifications.
\item Perform calculations.
\item Call the GENTRAN template processor.
\end{enumerate}
For example, the following REDUCE session will write a simulation
program to the file {\tt runge.f}:
\begin{verbatim}
1: COMMENT  -- INPUT --$ 

2: K := 1/(2*M)*P^2$    % kinetic energy 

3: U := K0/2*Q^2$       % potential energy 

4: D := B/2*QDOT$       % dissipating function 

5: H := K + U$          % hamiltonian 

6: COMMENT  -- CALCULATIONS --$ 

7: IN "rk.red", "ham.red"$ 

8: COMMENT  -- FORTRAN CODE GENERATION --$ 

9: GENTRANLANG!* := 'FORTRAN$ 

10: ON DOUBLE$

11: GENTRANIN "runge.tem" OUT "runge.f"$ 
\end{verbatim}

Contents of file {\tt runge.f}:
\begin{framedverbatim}
      PROGRAM RUNGE
      IMPLICIT DOUBLE PRECISION (K,M)
C
C  INPUT
C
      WRITE(6,*) 'INITIAL VALUE OF P'
      READ(5,*) P
      WRITE(6,*) ' P = ', P
      WRITE(6,*) 'INITIAL VALUE OF Q'
      READ(5,*) Q
      WRITE(6,*) ' Q = ', Q
      WRITE(6,*) 'VALUE OF M'
      READ(5,*) M
      WRITE(6,*) ' M = ', M
      WRITE(6,*) 'VALUE OF K0'
      READ(5,*) K0
      WRITE(6,*) ' K0 = ', K0
      WRITE(6,*) 'VALUE OF B'
      READ(5,*) B
      WRITE(6,*) ' B = ', B
      WRITE(6,*) 'STEP SIZE OF T'
      READ(5,*) HH
      WRITE(6,*) ' STEP SIZE OF T = ', HH
      WRITE(6,*) 'FINAL VALUE OF T'
      READ(5,*) TP
      WRITE(6,*) ' FINAL VALUE OF T = ', TP
C
C  INITIALIZATION
C
      TT=0.0D0                     
      WRITE(9,*) ' H = (M*Q**2*K0+P**2)/(2.0D0*M)'
      WRITE(9,*) ' D = (B*QDOT)/2.0D0'
      WRITE(9,901) C
901   FORMAT(' C= ',D20.10)
      WRITE(9,910) TT, Q, P
910   FORMAT(' '3D20.10)
C
C  LOOP
C
25001 CONTINUE
          PN=(-(12.0D0*B*M**2*HH)+2.0D0*B*M*K0*HH**3+24.0D0*
     .     M**2*P-(24.0D0*M**2*Q*K0*HH)-(12.0D0*M*P*K0*HH**2)
     .     +4.0D0*M*Q*K0**2*HH**3+P*K0**2*HH**4)/(24.0D0*M**2
     .     )
          Q=(-(12.0D0*B*M*HH**2)+B*K0*HH**4+48.0D0*M**2*Q+
     .     48.0D0*M*P*HH-(24.0D0*M*Q*K0*HH**2)-(8.0D0*P*K0*HH
     .     **3)+2.0D0*Q*K0**2*HH**4)/(48.0D0*M**2)
          P=PN
          TT=TT+HH
          WRITE(9,910) TT, QQ, P
      IF (.NOT.TT.GE.TF) GOTO 25001
      STOP
      END
\end{framedverbatim}

\section{Symbolic Mode Functions}
\index{symbolic mode ! in GENTRAN}

Thus far in this manual, commands have been presented which are meant
to be used primarily in the algebraic mode of REDUCE.  These commands
are designed to be used interactively.  However, many code generation
applications require code to be generated under program control\footnote{
\cite{vandenHeuvel:86ms} contains one such example.}. In these
applications, it is generally more convenient to generate code from
(computed) prefix forms.  Therefore, GENTRAN provides code generation
and file handling functions designed specifically to be used in the
symbolic mode of REDUCE.  This section presents the symbolic functions
which are analogous to the code generation, template processing, and
output file handling commands presented in sections \ref{GENTRAN:inter},
 \ref{GENTRAN:template}, and \ref{GENTRAN:output}.

\subsection{Code Generation and Translation}
Sections~\ref{translation} through \ref{comments}
describe interactive commands and functions which
generate and translate code, declare variables to be of 
specific types, and insert literal strings of characters into the
stream of generated code.  This section describes analogous symbolic
mode code generation functions.

\subsubsection{Translation of Prefix Forms}
In algebraic mode, the {\bf GENTRAN} command translates algorithmic
specifications supplied in the form of REDUCE statements into
numerical code.  Similarly, the symbolic function {\bf SYM!-GENTRAN}
\index{SYM"!-GENTRAN command}
translates algorithmic specifications supplied in the form of REDUCE
prefix forms into numerical code.

\begin{describe}{Syntax:}
{\bf SYM!-GENTRAN} {\it form\/};
\end{describe}
\begin{describe}{Function Type:}
expr
\end{describe} 
\begin{describe}{Argument:}
{\it form\/} is any LISP prefix form that evaluates to a
REDUCE prefix form that can be translated by GENTRAN into the target 
language\footnote{
See~\ref{appa} on page~\pageref{appa} for a complete listing of REDUCE
prefix forms that can be translated.}.
{\it form\/} may contain any number of occurrences of the special forms 
\ttindex{EVAL} \ttindex{LSETQ} \ttindex{RSETQ} \ttindex{LRSETQ}
\ttindex{DECLARE} \ttindex{LITERAL}
{\bf EVAL}, {\bf LSETQ}, {\bf RSETQ}, {\bf LRSETQ}, {\bf DECLARE}, and 
{\bf LITERAL} (see sections~\ref{sym:cg} through \ref{special} on
pages~\pageref{sym:cg}--\pageref{special}).
\end{describe}
\begin{describe}{Side Effects:}
{\bf SYM!-GENTRAN} translates {\it form\/} into formatted code in the target
language and writes it to the file(s) currently selected for output.
\end{describe}
\begin{describe}{Returned Value:}
{\bf SYM!-GENTRAN} returns the name(s) of the file(s) to which code
was written.  If code was written to one file, the returned value is an atom;
otherwise, it is a list.
\end{describe} 
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS

   OVERWRITE FILE? (Y/N)

***** WRONG TYPE OF ARG
\end{verbatim}
{\it exp}
\begin{verbatim}
***** CANNOT BE TRANSLATED
\end{verbatim}
\end{describe} 
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: SYMBOLIC$ 

2: GENTRANLANG!* := 'FORTRAN$

3:   SYM!-GENTRAN '(FOR I (1 1 n) DO (SETQ (V I) 0))$

     DO 25001 I=1,N
          V(I)=0.0
25001 CONTINUE

4: GENTRANLANG!* := 'RATFOR$

5: SYM!-GENTRAN '(FOR I (1 1 N) DO 
5:                    (FOR J ((PLUS I 1) 1 N) DO 
5:                         (PROGN 
5:                            (SETQ (X J I) (X I J)) 
5:                            (SETQ (Y J I) (Y I J)))))$ 

DO I=1,N
   DO J=I+1,N
        {
            X(J,I)=X(I,J)
            Y(J,I)=Y(I,J)
        }

6: GENTRANLANG!* := 'C$ 

7: SYM!-GENTRAN '(SETQ P (FOR I (1 1 N) PRODUCT I))$

{
    P=1;
    for (I=1;I<=N;++I)
        P*=I;
}

8:  GENTRANLANG!* := 'PASCAL$

9: SYM!-GENTRAN '(SETQ C
9:     (COND ((LESSP A B) A) (T B)))$
IF A<B THEN
    C:=A;
ELSE
    C:=B;

\end{verbatim}
\end{describe}


\subsubsection{Code Generation} \index{code generation}
\label{sym:cg}
Sections~\ref{eval} through~\ref{lrsetq} on
pages~\pageref{eval}--\pageref{lrsetq} described the special functions
and operators {\bf EVAL}, {\bf ::=}, {\bf :=:}, and {\bf ::=:} that
could be included in arguments to the {\bf GENTRAN} command to
indicate that parts of those arguments were to be given to REDUCE FOR
Evaluation prior to translation.  This section describes the analogous
functions that can be supplied in prefix form to the {\bf SYM!-GENTRAN}
function.

The following special forms may be interleaved arbitrarily in forms
supplied as arguments to {\bf SYM!-GENTRAN} to specify partial
\ttindex{EVAL} \ttindex{LSETQ} \ttindex{RSETQ} \ttindex{LRSETQ}
evaluation:  {\bf EVAL}, {\bf LSETQ}, {\bf RSETQ}, and {\bf LRSETQ}.
Sections~\ref{sym:eval} through \ref{sym:lrsetq} describe these forms. Then
section~\ref{lispeval} through \ref{share}
present examples of the usage of these
forms for evaluation of expressions in both symbolic and algebraic modes.

\paragraph{The EVAL Form}
\label{sym:eval}
\begin{describe}{Syntax:} \ttindex{EVAL}
{\bf (EVAL} {\it form\/}{\bf )}
\end{describe} 
\begin{describe}{Argument:}
{\it form\/} is any LISP prefix form that evaluates to a REDUCE prefix form
that can be translated by GENTRAN into the target language.
\end{describe} 

\paragraph{The LSETQ Form} \ttindex{LSETQ}
\begin{describe}{Syntax:}
{\bf (LSETQ} {\it svar exp\/}{\bf )}
\end{describe} 
\begin{describe}{Arguments:}
{\it svar\/} is a subscripted variable in LISP prefix form.  Its subscripts
must evaluate to REDUCE prefix forms that can be translated
into the target language.  {\it exp\/} is any REDUCE expression in
prefix form that can be translated by GENTRAN.
\end{describe} 

\paragraph{The RSETQ Form} \ttindex{RSETQ}
\begin{describe}{Syntax:}
{\bf (RSETQ} {\it var exp\/}{\bf )}
\end{describe}
\begin{describe}{Arguments:}
{\it var\/} is a variable in REDUCE prefix form.  {\it exp\/} is a LISP
prefix form which evaluates to a translatable REDUCE prefix form.
\end{describe} 

\paragraph{The LRSETQ Form} \ttindex{RSETQ}
\label{sym:lrsetq}
\begin{describe}{Syntax:}
{\bf (LRSETQ} {\it svar exp\/}{\bf )}
\end{describe} 
\begin{describe}{Arguments:}
{\it svar\/} is a subscripted variable in LISP prefix form with
subscripts that evaluate to REDUCE prefix forms
that can be translated by GENTRAN.  {\it exp\/} is a LISP prefix
form that evaluates to a translatable REDUCE prefix form.
\end{describe}

\paragraph{Symbolic Mode Evaluation}
\label{lispeval}
The symbolic mode evaluation forms that have just been described are
analogous to their algebraic mode counterparts, except that
by default, they evaluate their argument(s) in symbolic mode.  The
following is an example of evaluation of subscripts in symbolic mode:
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: SYMBOLIC$

2: FOR i:=1:2 DO 
2:     FOR j:=1:2 DO 
2:         SYM!-GENTRAN '(LSETQ (M i j) 0)$

     M(1,1)=0.0
     M(1,2)=0.0
     M(2,1)=0.0
     M(2,2)=0.0
\end{verbatim}
\end{describe} 

\paragraph{Algebraic Mode Evaluation}
As we have just seen, the symbolic mode evaluation forms evaluate their
argument(s) in symbolic mode.  This default evaluation mode can be
overridden by explicitly requesting evaluation in algebraic mode with
the REDUCE {\bf AEVAL} function.\ttindex{AEVAL}

\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: ALGEBRAIC$

2: F := 2*x^2 - 5*X + 6$ 

3: SYMBOLIC$ 

4: SYM!-GENTRAN '(SETQ Q (QUOTIENT 
4:                           (EVAL (AEVAL 'F)) 
4:                           (EVAL (AEVAL '(DF F X)))))$

     Q=(2.0*X**2-5.0*X+6.0)/(4.0*X-5.0)

5: ALGEBRAIC$ 

6: M := MAT(( A,   0,  -1,  1), 
6:          ( 0, B^2,   0,  1), 
6:          (-1,   B, B*C,  0), 
6:          ( 1,   0,  -C, -D))$ 

7: SYMBOLIC$ 

8: FOR i:=1:4 DO 
8:      SYM!-GENTRAN '(LRSETQ (M i i) 
                    (AEVAL (MKQUOTE (LIST 'M i i))))$

     M(1,1)=A
     M(2,2)=B**2
     M(3,3)=B*C
     M(4,4)=-D
\end{verbatim}
\end{describe}

\paragraph{SHAREd Variables}
\label{share} \index{SHARE command}
The REDUCE {\bf SHARE} command enables variables to be shared
between algebraic and symbolic modes.  Thus, we can derive an expression in
algebraic mode, assign it to a shared variable, and then access the value
of that variable to generate code from symbolic mode.

\begin{describe}{Example:}
\begin{verbatim}
1: ALGEBRAIC$

2: SHARE dfx1$

3: dfx1 := DF(X**4 - X**3 + 2*X**2 + 1, X)$

4: SYMBOLIC$

5: SYM!-GENTRAN '(RSETQ DERIV dfx1)$
      DERIV=4.0*X**3-(3.0*X**2)+4.0*X
\end{verbatim}
\end{describe} 

\subsubsection{Special Translatable Forms}
\label{special}
Sections~\ref{explicit:type} through \ref{comments} described special
functions that could be used to declare variable types and insert
literal strings of characters into generated code.  This section
contains explanations of analogous prefix forms for usage in symbolic
mode.

\paragraph{Explicit Type Declarations}
A similar form of the algebraic mode {\bf DECLARE} function is provided in
symbolic mode:
\begin{describe}{Syntax:} \index{DECLARE function}
\begin{tabular}{ll}
{\bf (DECLARE} & {\bf (}{\it type1 v1 v2 \dots\  vn1\/}{\bf )}\\
& {\bf (}{\it type2 v1 v2 \dots\  vn2\/}{\bf )}\\
& \ \ \ :\\
& {\bf (}{\it typen v1 v2 \dots\  vnn\/}{\bf )) }\\
\end{tabular}
\end{describe} 
\begin{describe}{Arguments:}
Each {\it v1 v2 \dots\ vn\/} is a sequence of one or more variables
(optionally subscripted to indicate array dimensions -- in prefix form), or
variable ranges (two letters concatenated together with "-" in between). {\it
v\/}s are not evaluated unless given as arguments to {\bf EVAL}.

Each {\it type\/} is a variable type in the target language.  Each
must be an atom, optionally concatenated to the atom {\bf IMPLICIT!\ }
(note the trailing space).  \index{IMPLICIT"!  atom}
{\it type\/}s are not evaluated unless given as arguments to {\bf EVAL}.
\end{describe} 
\begin{describe}{Side Effect:}
Entries are placed in the symbol table for each variable or
variable range declared in the call to this function.  The
function call itself is removed from the statement group
being translated.  Then after translation, type declarations are
generated from these symbol table entries before the resulting
executable statements are printed.
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: SYMBOLIC$ 

2: GENTRANLANG!* := 'FORTRAN$

3: SYM!-GENTRAN 
3:    '(PROGN 
3:        (DECLARE (IMPLICIT! REAL!*8 A!-H O!-Z) 
3:                 (INTEGER (M 4 4))) 
3:        (FOR I (1 1 4) DO 
3:             (FOR J (1 1 4) DO 
3:                  (COND ((EQUAL I J) (SETQ (M I J) 1)) 
3:                        (T (SETQ (M I J) 0))))) 
3:        (DECLARE (INTEGER I J)) 
      :
      :
3:     )$ 

     IMPLICIT REAL*8 (A-H,O-Z)
     INTEGER M(4,4),I,J
     DO 25001 I=1,4
          DO 25002 J=1,4
              IF (I.EQ.J) THEN
                  M(I,J)=1
              ELSE
                  M(I,J)=0
              ENDIF
25002     CONTINUE
25001 CONTINUE
      :
      :

4: GENTRANLANG!* := 'RATFOR$

5: SYM!-GENTRAN 
5:    '(PROCEDURE FAC NIL EXPR (N) 
5:        (BLOCK () 
5:               (DECLARE (FUNCTION FAC) 
5:                        (INTEGER FAC N)) 
5:               (SETQ F (FOR I (1 1 N) PRODUCT I)) 
5:               (DECLARE (INTEGER F I)) 
5:               (RETURN F)))$

INTEGER FUNCTION FAC(N)
INTEGER N,F,I
{
    F=1
    DO I=1,N
        F=F*I
}
RETURN(F)
END

6: GENTRANLANG!* := 'C$

7: SYM!-GENTRAN 
7:    '(PROCEDURE FAC NIL EXPR (N) 
7:        (BLOCK () 
7:               (DECLARE (INTEGER FAC N I F)) 
7:               (SETQ F (FOR I (1 1 N) PRODUCT I)) 
7:               (RETURN F)))$ 

int FAC(N)
int N;
{
    int I,F;
    {
        F=1;
        for (I=1;I<=N;++I)
            F*=I;
    }
    return(F);
}

8:  GENTRANLANG!* := 'PASCAL$

9:  SYM!-GENTRAN
9:     '(PROCEDURE FAC NIL EXPR (N)
9:         (BLOCK ()
9:                (DECLARE (INTEGER FAC N I F))
9:                (SETQ F (FOR I (1 1 N) PRODUCT I))
9:                (RETURN F)))$
FUNCTION FAC(N:INTEGER):INTEGER;
LABEL
    99999;
VAR
    I,F: INTEGER;
BEGIN
    BEGIN
        F:=1;
        FOR I:=1 TO N DO
            F:=F*I
    END;
    BEGIN
        FAC:=F;
        GOTO 99999{RETURN}
    END;
99999:
END;

\end{verbatim}
\end{describe} 

\paragraph{Comments and Literal Strings}
\index{comments ! in GENTRAN} \index{literals ! in GENTRAN}
\ttindex{LITERAL}
A form similar to the algebraic mode {\bf LITERAL} function is provided in
symbolic mode:
\begin{describe}{Syntax:}
{\bf (LITERAL} {\it arg1 arg2 \dots\  argn\/}{\bf )}
\end{describe} 
\begin{describe}{Arguments:}
{\it arg1 arg2 \dots\  argn\/} is an argument sequence containing one or more
{\it arg\/}s, where each {\it arg\/} either is, or evaluates to, an atom.  The
atoms {\bf TAB!*} and {\bf CR!*} have special meanings. \ttindex{TAB"!*}
\ttindex{CR"!*} {\it arg\/}s are
not evaluated unless given as arguments to {\bf EVAL}.
\end{describe} 
\begin{describe}{Side Effect:}
This form is replaced by the character sequence resulting from
concatenation of the given atoms.  Double quotes are stripped from
all string type {\it arg\/}s, and the reserved atoms {\bf TAB!*}
and {\bf CR!*} are replaced by a tab to the current level of indentation,
and an end-of-line character, respectively.
\end{describe} 
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: SYMBOLIC$ 

2: GENTRANLANG!* := 'FORTRAN$

3: N := 100$

4: SYM!-GENTRAN 
4:  '(PROGN 
4:    (LITERAL C TAB!* "--THIS IS A FORTRAN COMMENT--"
4:             CR!* C CR!*) 
4:    (LITERAL TAB!* "DATA N/" (EVAL N) "/" CR!*))$

C     --THIS IS A FORTRAN COMMENT--
C
     DATA N/100/

5: GENTRANLANG!* := 'RATFOR$

6: SYM!-GENTRAN 
6:  '(FOR I (1 1 N) DO 
6:      (PROGN 
6:       (LITERAL TAB!* "# THIS IS A RATFOR COMMENT" CR!*) 
6:       (LITERAL TAB!* "WRITE(6,10) (M(I,J),J=1,N)" CR!* 
6:         10 TAB!* "FORMAT(1X,10(I5,3X))" CR!*)))$

DO I=1,N
   {
        # THIS IS A RATFOR COMMENT
        WRITE(6,10) (M(I,J),J=1,N)
10      FORMAT(1X,10(I5,3X))
   }

7: GENTRANLANG!* := 'C$

8: SYM!-GENTRAN 
8:  '(PROGN 
8:    (SETQ X 0) 
8:    (LITERAL "/* THIS IS A" CR!* "
8:             C COMMENT */" CR!*))$

{
    X=0.0;
/* THIS IS A
   C COMMENT */
}

9: GENTRANLANG!* := 'PASCAL$

10: SYM!-GENTRAN
10:  '(PROGN
10:     (SETQ X (SIN Y))
10:     (LITERAL "{ THIS IS A PASCAL COMMENT }" CR!*))$
BEGIN
    X:=SIN(Y)
{ THIS IS A PASCAL COMMENT }
END;

\end{verbatim}
\end{describe} 

\subsection{Template Processing}
\index{template processing}
The template processor can be invoked from either algebraic or
symbolic mode.  Section~\ref{templates} described the algebraic mode
command.  This section describes the analogous symbolic mode function.
\begin{describe}{Syntax:}\index{SYM"!-GENTRANIN command}
{\bf SYM!-GENTRANIN} {\it list-of-fnames\/};
\end{describe} 
\begin{describe}{Function Type:}
expr
\end{describe} 
\begin{describe}{Argument:}
{\it list-of-fnames\/} evaluates to a LISP list containing one or more
{\it fname\/}s, where each {\it fname\/} is one of:

\begin{tabular}{lll}
{\it an atom} & = & a template (input) file\\
{\bf T} & = & the terminal\\
\end{tabular}
\end{describe} 
\begin{describe}{Side Effects:}
{\bf SYM!-GENTRANIN} processes each template file in {\it list-of-fnames\/}
sequentially.

A template file may contain any number of parts, each of which
is either an active or an inactive part.  All active parts start with
the character sequence {\bf ;BEGIN;} and end with {\bf ;END;}.  The end
of the template file is indicated by an extra {\bf ;END;} character sequence.

Inactive parts of template files are assumed to contain code in
the target language (FORTRAN, RATFOR, PASCAL or C, depending on
the value of the global varibale {\bf GENTRANLANG!*}).  All
inactive parts are copied to the output.  Comments delimited
by the appropriate characters are also copied in their entirety
to the output.  Thus the character sequences {\bf ;BEGIN;} and {\bf ;END;}
have no special meanings within comments. \index{;BEGIN; marker}
\index{;END; marker}

Active parts may contain any number of REDUCE expressions, statements,
and commands.  They are not copied directly to the output.  Instead,
they are given to REDUCE for evaluation in algebraic mode\footnote{
Active parts are evaluated in algebraic mode unless the mode is
explicitly changed to symbolic from within the active part itself.
This is true regardless of which mode the system was in when the
template processor was called.}.  All output generated by each
evaluation is sent to the file(s) currently selected for output.
Returned values are only printed on the terminal.

Active parts will most likely contain calls to GENTRAN to generate
code.  This means that the result of processing a template file will
be the original template file with all active parts replaced by
generated code.
\end{describe} 
\begin{describe}{Returned Value:}
{\bf SYM!-GENTRANIN} returns the name(s) of the file(s) to which code was
written.  If code was written to one file, the returned value is an atom;
otherwise, it is a list.
\end{describe} 
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS

   OVERWRITE FILE? (Y/N)

***** NONEXISTENT INPUT FILE

***** TEMPLATE FILE ALREADY OPEN FOR INPUT

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe} 

\subsection{Output Redirection}
\index{output redirection (temporary)}
Section~\ref{GENTRAN:output} describes four slgebraic mode commands
which select, open, and close output files.  The algebraic mode commands
\index{GENTRANOUT command} \index{GENTRANSHUT command}
\index{GENTRANPUSH command} \index{GENTRANPOP command}
{\bf GENTRANOUT}, {\bf GENTRANSHUT}, {\bf GENTRANPUSH}, and {\bf
GENTRANPOP} are analogous to the symbolic mode {\bf
SYM!-GENTRANOUT}, {\bf SYM!-GENTRANSHUT}, {\bf SYM!-GENTRANPUSH}, and
{\bf SYM!-GENTRANPOP} functions, respectively.

\subsubsection{SYM!-GENTRANOUT} \index{SYM"!-GENTRANOUT command}
\begin{describe}{Syntax:}
{\bf SYM!-GENTRANOUT} {\it list-of-fnames\/};
\end{describe} 
\begin{describe}{Function Type:}
expr
\end{describe} 
\begin{describe}{Argument:}
{\it list-of-fnames\/} evaluates to a LISP list containing one or more
{\it fname\/}s, where each {\it fname} is one of:

\begin{tabular}{lll}
{\it an atom} & = & an output file\\
{\bf T} & = & the terminal\\
{\bf NIL} & = &  the current output file(s)\\
{\bf ALL!*} & = &  all files currently open for output \\
& &  by GENTRAN\\
\end{tabular}
\end{describe}
\begin{describe}{Side Effect:}
GENTRAN maintains a list of files currently open for output by GENTRAN
{\it only}.  {\bf SYM!-GENTRANOUT} inserts each file name represented in
{\it list-of-fnames\/} into that list and opens each one
for output.  It also resets the currently selected output file(s) to be
all of the files represented in {\it list-of-fnames}.
\end{describe} 
\begin{describe}{Returned Value:}
{\bf SYM!-GENTRANOUT} returns the name(s) of the file(s) represented
by {\it list-of-fnames\/}; i.e., the current output file(s) after the
command has been executed.  If there is only one file
selected for output, the returned value is an atom; otherwise, it is
a list.
\end{describe} 
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}

*** OUTPUT FILE ALREADY EXISTS

   OVERWRITE FILE? (Y/N)

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe} 

\subsubsection{SYM!-GENTRANSHUT}\index{SYM"!-GENTRANSHUT command}
\begin{describe}{Syntax:}
{\bf SYM!-GENTRANSHUT} {\it list-of-fnames\/} ;
\end{describe} 
\begin{describe}{Function Type:}
expr
\end{describe} 
\begin{describe}{Argument:}
{\it list-of-fnames\/} evaluates to a LISP list containing one or more 
{\it fnames}, where each {\it fname\/} is one of:

\begin{tabular}{lll}
{\it an atom} & = &  an output file\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{describe} 
\begin{describe}{Side Effects:}
{\bf SYM!-GENTRANSHUT} creates a list of file names from {\it list-of-fnames},
deletes each from the output file list,
and closes the corresponding files.  If (all of) the
current output file(s) are closed, then the current output
file is reset to the terminal.
\end{describe} 
\begin{describe}{Returned Value:}
{\bf SYM!-GENTRANSHUT} returns the name(s) of the file(s) selected for
output after the command has been executed.  If there is
only one file selected for output, the returned value is an atom;
otherwise, it is a list.
\end{describe} 
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** FILE NOT OPEN FOR OUTPUT

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe} 

\subsubsection{SYM!-GENTRANPUSH}\index{SYM"!-GENTRANPUSH command}
\begin{describe}{Syntax:}
{\bf SYM!-GENTRANPUSH} {\it  list-of-fnames\/};
\end{describe} 
\begin{describe}{Function Type:}
expr
\end{describe} 
\begin{describe}{Argument:}
{\it list-of-fnames\/} evaluates to a LISP list containing one or more 
{\it fname}s, each of which is one of:

\begin{tabular}{lll}
{\it an atom} & = &  an output file\\
{\bf T} & = & the terminal\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{describe} 
\begin{describe}{Side Effects:}
{\bf SYM!-GENTRANPUSH} creates a list of file name(s) from
{\it lis-of-fnames\/}
and pushes that list onto the output stack.  Each file in the list that
is not already open for output is opened at this time.  The current
output file is reset to this new element on the top of the stack.
\end{describe} 
\begin{describe}{Returned Value:}
{\bf SYM!-GENTRANPUSH} returns the name(s) of the file(s) represented by 
{\it list-of-fnames\/}; i.e., the current output
file(s) after the command has been executed.  If there is
only one file selected for output, the returned value is an
atom; otherwise, it is a list.
\end{describe} 
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS

   OVERWRITE FILE? (Y/N)

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}

\subsubsection{SYM!-GENTRANPOP} \index{SYM"!-GENTRANPOP command}
\begin{describe}{Syntax:}
{\bf SYM!-GENTRANPOP} {\it list-of-fnames\/};
\end{describe} 
\begin{describe}{Function Type:}
expr
\end{describe} 
\begin{describe}{Argument:}
{\it list-of-fnames\/} evaluates to a LISP list containing one or more
{\it fname\/}s, where each {\it fname\/} is one of:

\begin{tabular}{lll}
{\it an atom} & = &  an output file\\
{\bf T} & = & the terminal\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{describe} 
\begin{describe}{Side Effects:}
{\bf SYM!-GENTRANPOP} deletes the top-most occurrence of the
single element containing the file name(s) represented by
{\it list-of-fnames\/} from the output stack.  Files whose names have been
completely removed from the output stack are closed.  The current output file
is reset to the (new) element on the top of the output stack.
\end{describe} 
\begin{describe}{Returned Value:}
{\bf SYM!-GENTRANPOP} returns the name(s) of the file(s)
selected for output after the command has been executed.  If there is
only one file selected for output, the returned value is an atom; otherwise,
it is a list.
\end{describe} 
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** FILE NOT OPEN FOR OUTPUT

***** WRONG TYPE OF ARG

\end{verbatim}
\end{describe}

\section{Translatable REDUCE Expressions \& Statements}
\label{appa}
A substantial subset of all REDUCE expressions and statements
can be translated by GENTRAN into semantically equivalent code
in the target numerical language\footnote{
It should be noted that call-by-value parameter passing is used
in REDUCE, whereas call-by-address parameter passing is normally
used in FORTRAN and RATFOR.  GENTRAN does {\it not} attempt
to simulate call-by-value passing in FORTRAN and RATFOR, although
this could be done by generating temporary variables, assigning
values to them, and using them in subprogram calls.
\index{call-by-value} \index{call-by-address}}. This
section contains examples and a formal definition of translatable REDUCE
expressions and statements.

\subsection{Examples of Translatable Statements}
The following three tables contain listings of REDUCE statement types
that can be translated by GENTRAN.  An example of each statement
type is shown, and FORTRAN, RATFOR, PASCAL and C code generated for each
example is also shown.

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf FORTRAN CODE} \\ \hline\hline
    simple     &{\bf V:=X\^{}2+X\$} &\verb!      V=X**2+X!\\
& & \\
    matrix     &{\bf M:=MAT((U,V),} &\verb!      M(1,1)=U!\\
& {\bf\ \ \ \ \ \ \ \ (W,X))\$ } &\verb!      M(1,2)=V!\\
& &\verb!      M(2,1)=W!\\
& &\verb!      M(2,2)=X!\\
& & \\
    sum &{\bf S:=FOR I:=1:10} &\verb!      S=0.0!\\
&{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb!      DO 25001 I=1,10!\\
& &\verb!          S=S+V(I)!\\
& &\verb!25001 CONTINUE!\\
& & \\
    product    &{\bf P:=FOR I:=2 STEP 2} &\verb!      P=1!\\
&{\bf\ \ \ \ \ \ \ \ UNTIL N} &\verb!      DO 25002 I=2,N,2!\\
&{\bf \ \ \ \ PRODUCT I\$} &\verb!          P=P*I!\\
& &\verb!25002 CONTINUE!\\
& & \\
conditional & {\bf X := IF A$<$B THEN} &\verb!      IF (A.LT.B) THEN!\\
& {\bf \ \ \ \ \ \ \ \ A ELSE B\$} &\verb!          X=A!\\
& &\verb!      ELSE!\\
& &\verb!          X=B!\\
& &\verb!      ENDIF!\\
& & \\ \hline\hline
\end{tabular}
\caption{REDUCE assignments translatable to FORTRAN}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf FORTRAN CODE} \\ \hline\hline
    for &{\bf FOR I:=1:8 DO} &\verb!      DO 25003 I=1,8!\\
&{\bf \ \ \ \ V(I):=0.0\$} &\verb!          V(I)=0.0!\\
& &\verb!25003 CONTINUE!\\
& & \\
    while      &{\bf WHILE F(N)$>$0.0 DO} &\verb!25004 IF(.NOT.F(N).GT.0.0)!\\
               &                          &\verb!     .   GOTO 25005!\\
&{\bf \ \ \ \ N:=N+1\$} &\verb!          N=N+1!\\
& &\verb!          GOTO 25004!\\
& &\verb!25005 CONTINUE!\\
& & \\
   repeat     &{\bf REPEAT X:=X/2.0} &\verb!25006 CONTINUE!\\
&{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb!          X=X/2.0!\\
& &\verb!      IF(.NOT.F(X).LT.0.0)!\\
& &\verb!     .   GOTO 25006!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE Loop structures translatable to FORTRAN}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf FORTRAN CODE} \\ \hline\hline
  Conditionals:&     &\\
&     &\\
    if  &{\bf IF X$>$0.0} &\verb!  IF (X.GT.0.0) THEN!\\
& {\bf \ \ \ \ \ \ \  THEN Y:=X\$} &\verb!      Y=X!\\
& &\verb!  ENDIF!\\
&     &\\
    if - else  &{\bf IF X$>$0.0 THEN Y:=X} &\verb!  IF (X.GT.0.0) THEN!\\
&{\bf\ \ \ \  ELSE Y:=-X\$}&\verb!      Y=X!\\
&     &\verb!  ELSE!\\
&     &\verb!      Y=-X!\\
&     &\verb!  ENDIF!\\
& & \\\hline
  Unconditional&     &\\
  Transfer of  &     &\\
  Control:     &     &\\
&     &\\
    goto&{\bf GOTO LOOP\$} &\verb!  GOTO 25010!\\
&     &\\
    call&{\bf CALCV(V,X,Y,Z)\$} &\verb!  CALL CALCV(V,X,Y,Z)!\\
&     &\\
    return     &{\bf RETURN X\^{}2\$} &\verb!  !{\it
 functionname\/}\verb!=X**2!\\
&     &\verb!  RETURN!\\
& & \\\hline
Sequences \&    &     &\\
Groups: &     &\\
&     &\\
    sequence   &{\bf $<$$<$ U:=X\^{}2;}&\verb!  U=X**2!\\
& {\bf \ \ \ \ \ \ \ \ V:=Y\^{}2$>$$>$\$}    &\verb!  V=Y**2!\\
&     &\\
    group      &{\bf BEGIN}&\verb!  U=X**2!\\
&{\bf\ \ \ \  U:=X\^{}2;}&\verb!  V=Y**2!\\
&{\bf\ \ \ \  V:=Y\^{}2} &\\
&{\bf END\$}&\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE control structures translatable to FORTRAN}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf RATFOR CODE} \\ \hline\hline

Assignments: & &\\
& & \\
    simple     &{\bf V:=X\^{}2+X\$} &\verb!V=X**2+X!\\
& & \\
    matrix     &{\bf M:=MAT((U,V),(W,X))\$} &\verb!M(1,1)=U!\\
& &\verb!M(1,2)=V!\\
& &\verb!M(2,1)=W!\\
& &\verb!M(2,2)=X!\\
& & \\
    sum &{\bf S:=FOR I:=1:10} &\verb!S=0.0!\\
&{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb!DO I=1,10!\\
& &\verb!    S=S+V(I)!\\
& & \\
    product    &{\bf P:=FOR I:=2 STEP 2} &\verb!P=1!\\
&{\bf\ \ \ \ \ \ \ \ UNTIL N} &\verb!DO I=2,N,2!\\
&{\ \ \ \ PRODUCT I\$} &\verb!    P=P*I!\\
& & \\
conditional & {\bf X := IF A$<$B THEN} &\verb!IF (A<B)!\\
& {\bf \ \ \ \ \ \ \ \ A ELSE B\$} &\verb!    X=A!\\
& &\verb!ELSE!\\
& &\verb!    X=B!\\
& & \\\hline
Control & & \\
Structures: & &\\
& & \\
  Loops: & &\\
& &\\
    for &{\bf FOR I:=1:8 DO} &\verb!DO I=1,8!\\
&{\bf \ \ \ \ V(I):=0.0\$} &\verb!    V(I)=0.0!\\
& & \\
    while      &{\bf WHILE F(N)$>$0.0 DO} &\verb!WHILE(F(N)>0.0)!\\
&{\bf \ \ \ \ N:=N+1\$} &\verb!    N=N+1!\\
& & \\
   repeat     &{\bf REPEAT X:=X/2.0} &\verb!REPEAT!\\
&{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb!    X=X/2.0!\\
& &\verb!UNTIL(F(X)<0.0)!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to RATFOR}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf RATFOR CODE} \\ \hline\hline
  Conditionals:&     &\\
&     &\\
    if  &{\bf IF X$>$0.0 THEN Y:=X\$} &\verb!IF(X>0.0)!\\
&     &\verb!    Y=X!\\
&     &\\
    if - else  &{\bf IF X$>$0.0 THEN Y:=X} &\verb!IF(X>0.0)!\\
&{\bf\ \ \ \  ELSE Y:=-X\$}&\verb!    Y=X!\\
&     &\verb!ELSE!\\
&     &\verb!    Y=-X!\\
& & \\\hline
  Unconditional&     &\\
  Transfer of  &     &\\
  Control:     &     &\\
&     &\\
    goto&{\bf GOTO LOOP\$} &\verb!GOTO 25010!\\
&     &\\
    call&{\bf CALCV(V,X,Y,Z)\$} &\verb!CALL CALCV(V,X,Y,Z)!\\
&     &\\
    return     &{\bf RETURN X\^{}2\$} &\verb!RETURN(X**2)!\\
& & \\\hline
Sequences \&    &     &\\
Groups: &     &\\
&     &\\
    sequence   &{\bf $<$$<$ U:=X\^{}2;V:=Y\^{}2$>$$>$\$}&\verb!U=X**2!\\
&     &\verb!V=Y**2!\\
&     &\\
    group      &{\bf BEGIN}&\verb!{!\\
&{\bf\ \ \ \  U:=X\^{}2;}& \verb!      U=X**2!\\
&{\bf\ \ \ \  V:=Y\^{}2} & \verb!      V=Y**2!\\
&{\bf END\$}&\verb!}!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to RATFOR}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf PASCAL CODE} \\ \hline\hline
Assignments: & &\\
& & \\
    simple     &{\bf V:=X\^{}2+X\$} &\verb!V=X**2+X;!\\
& & \\
    matrix     &{\bf M:=MAT((U,V),} &\verb!BEGIN!\\
& {\bf \ \ \ \ \ \ \ \ (W,X))\$} &\verb!    M(1,1)=U;!\\
& &\verb!    M(1,2)=V;!\\
& &\verb!    M(2,1)=W;!\\
& &\verb!    M(2,2)=X;!\\
& &\verb!END;!\\
& & \\
    sum &{\bf S:=FOR I:=1:10} &\verb!BEGIN!\\
&{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb!    S=0.0!\\
& &\verb!    FOR I:=1 TO 10 DO!\\
& &\verb!        S:=S+V(I)!\\
& &\verb!END;!\\
& & \\
    product    &{\bf P:=FOR I:=2:N} &\verb!BEGIN!\\
&{\bf \ \ \ \ PRODUCT I\$} &\verb!    P:=1;!\\
& &\verb!    FOR I:=2 TO N DO!\\
& &\verb!        P:=P*I!\\
& &\verb!END;!\\
& & \\
conditional & {\bf X := IF A$<$B THEN} &\verb!IF (A<B) THEN!\\
& \ \ \ \ \ \ {\bf \ \ \ \ \ \ \ \ A ELSE B\$} &\verb!    X:=A;!\\
& &\verb!ELSE!\\
& &\verb!    X:=B;!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to PASCAL}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf PASCAL CODE} \\ \hline\hline
Control & & \\
Structures: & &\\
& & \\
  Loops: & &\\
& &\\
    for &{\bf FOR I:=1:8 DO} &\verb!FOR I:=1 TO 8 DO!\\
&{\bf \ \ \ \ V(I):=0.0\$} &\verb!    V(I):=0.0;!\\
& & \\
    while      &{\bf WHILE F(N)$>$0.0 DO} &\verb!WHILE (F(N)>0.0)!\\
&{\bf \ \ \ \ N:=N+1\$} &\verb!    N:=N+1.0;!\\
& & \\
   repeat     &{\bf REPEAT X:=X/2.0} &\verb!REPEAT!\\
&{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb!    X:=X/2.0!\\
& &\verb!UNTIL F(X)<0.0;!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to PASCAL}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf PASCAL CODE} \\ \hline\hline
  Conditionals:&     &\\
&     &\\
    if  &{\bf IF X$>$0.0 THEN Y:=X\$} &\verb!IF X>0.0 THEN!\\
& &\verb!    Y:=X;!\\
&     &\\
    if - else  &{\bf IF X$>$0.0 THEN Y:=X} &\verb!IF X>0.0 THEN!\\
&{\bf\ \ \ \  ELSE Y:=-X\$}&\verb!    Y:=X;!\\
&     &\verb!ELSE!\\
&     &\verb!    Y:=-X;!\\
& & \\\hline
  Unconditional&     &\\
  Transfer of  &     &\\
  Control:     &     &\\
&     &\\
    goto&{\bf GOTO LOOP\$} &\verb!GOTO 25010;!\\
&     &\\
    call&{\bf CALCV(V,X,Y,Z)\$} &\verb!CALCV(V,X,Y,Z);!\\
&     &\\
    return     &{\bf RETURN X\^{}2\$} &{\it functionname\/}\verb!=X**2;!\\
&     &\verb!GOTO 99999{RETURN}!\\
&     &\verb!99999;!\\
& & \\\hline
Sequences \&    &     &\\
Groups: &     &\\
&     &\\
    sequence   &{\bf $<$$<$ U:=X\^{}2;V:=Y\^{}2$>$$>$\$}&\verb!BEGIN!\\
&&\verb!    U:=X**2;!\\
&&\verb!    V:=Y**2!\\
&&\verb!END;!\\
&     &\\
    group      &{\bf BEGIN}&\verb!BEGIN!\\
&{\bf\ \ \ \  U:=X\^{}2;}&\verb!    U:=X**2;!\\
&{\bf\ \ \ \  V:=Y\^{}2} &\verb!    V:=Y**2!\\
&{\bf END\$}&\verb!END!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to PASCAL}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf C CODE} \\ \hline\hline
Assignments: & &\\
& & \\
    simple     &{\bf V:=X\^{}2+X\$} &\verb!V=power(X,2)+X;!\\
& & \\
    matrix     &{\bf M:=MAT((U,V),(W,X))\$} &\verb!M[1][1]=U;!\\
& &\verb!M[1][2]=V;!\\
& &\verb!M[2][1]=W;!\\
& &\verb!M[2][2]=X;!\\
& & \\
    sum &{\bf S:=FOR I:=1:10} &\verb!S=0.0;!\\
&{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb!for(I=1;I<=10;++I)!\\
& &\verb!    S+=V[I];!\\
& & \\
    product    &{\bf P:=FOR I:=2 STEP 2} &\verb!P=1;!\\
&{\bf\ \ \ \ \ \ \ \ UNTIL N} &\verb!for(I=2;I<=N;++I)!\\
&{\ \ \ \ PRODUCT I\$} &\verb!    P*=I;!\\
& & \\
conditional & {\bf X := IF A$<$B THEN} &\verb!if (A<B)!\\
& {\bf \ \ \ \ \ \ \ \ A ELSE B\$} &\verb!    X=A;!\\
& &\verb!else!\\
& &\verb!    X=B;!\\
& & \\\hline
Control & & \\
Structures: & &\\
& & \\
  Loops: & &\\
& &\\
    for &{\bf FOR I:=1:8 DO} &\verb!for(I=1;I<=8;++I)!\\
&{\bf \ \ \ \ V(I):=0.0\$} &\verb!    V[I]=0.0;!\\
& & \\
    while      &{\bf WHILE F(N)$>$0.0 DO} &\verb!while(F(N)>0.0)!\\
&{\bf \ \ \ \ N:=N+1\$} &\verb!    N+=1;!\\
& & \\
   repeat     &{\bf REPEAT X:=X/2.0} &\verb!do!\\
&{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb!    X/=2.0;!\\
& &\verb!while(F(X)>=0.0);!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to C}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} &
 \multicolumn{1}{c||}{\bf C CODE} \\ \hline\hline
  Conditionals:&     &\\
&     &\\
    if  &{\bf IF X$>$0.0 THEN Y:=X\$} &\verb!if(X>0.0)!\\
&     &\verb!    Y=X;!\\
&     &\\
    if - else  &{\bf IF X$>$0.0 THEN Y:=X} &\verb!if(X>0.0)!\\
&{\bf\ \ \ \  ELSE Y:=-X\$}&\verb!    Y=X;!\\
&     &\verb!else!\\
&     &\verb!    Y=-X;!\\
& & \\\hline
  Unconditional&     &\\
  Transfer of  &     &\\
  Control:     &     &\\
&     &\\
    goto&{\bf GOTO LOOP\$} &\verb!goto LOOP;!\\
&     &\\
    call&{\bf CALCV(V,X,Y,Z)\$} &\verb!CALCV(V,X,Y,Z);!\\
&     &\\
    return     &{\bf RETURN X\^{}2\$} &\verb!return(power(X,2) );!\\
& & \\\hline
Sequences \&    &     &\\
Groups: &     &\\
&     &\\
    sequence   &{\bf $<$$<$ U:=X\^{}2;V:=Y\^{}2$>$$>$\$}&\verb!U=power(X,2);!\\
&     &\verb!V=power(Y,2);!\\
&     &\\
    group      &{\bf BEGIN}&\verb!{!\\
&{\bf\ \ \ \  U:=X\^{}2;}& \verb!      U=power(x,2);!\\
&{\bf\ \ \ \  V:=Y\^{}2} & \verb!      V=power(Y,2);!\\
&{\bf END\$}&\verb!}!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to C}
\end{table}

\subsection{Formal Definition}
The remainder of this section contains a formal definition of all
REDUCE expressions, statements, and prefix forms that can be translated by
GENTRAN into FORTRAN, RATFOR, PASCAL and C code.

\begin{describe}{Preliminary Definitions}
An {\it id\/} is an identifier.  Certain {\it id\/}'s are reserved words
and may not be used as array names or subprogram names.  The
complete list appears in the {\it Reserved Words\/} section.

A {\it string\/} consists of any number of characters (excluding double
quotes) which are enclosed in double quotes.
\end{describe}

\begin{describe}{Reserved Words}\index{reserved words}
The following reserved words may not be used as array names or
subprogram names\footnote{Note that names of other built-in REDUCE functions
{\it can\/} be translated, but remember that they will be translated
{\it literally\/} unless {\bf EVAL}'d first.  For example:
{\bf GENTRAN~DERIV~:=~DF(2*X\^{}2-X-1,~X)\$}
generates {\tt DERIV=DF(2*X**2-X-1,X)}
whereas
{\bf GENTRAN~DERIV~:=:~DF(2*X\^{}2-X-1,~X)\$}
generates {\tt DERIV=4*X-1} }:

{\bf AND, BLOCK, COND, DIFFERENCE, EQUAL, EXPT, FOR, GEQ,
GO, GREATERP, LEQ, LESSP, MAT, MINUS, NEQ, NOT, OR,
PLUS, PROCEDURE, PROGN, QUOTIENT, RECIP, REPEAT,
RETURN, SETQ, TIMES, WHILE, WRITE}
\end{describe} 

\subsubsection{Translatable REDUCE Expressions and Statements}
\begin{describe}{Expressions}
\begin{tabular}{lll}
\multicolumn{3}{l}{Arithmetic Expressions:} \\
& & \\
exp & ::= & {\it number} $\mid$  var  $\mid$  funcall  $\mid$  - exp $\mid$
/ exp  $\mid$  exp + exp  $\mid$ \\
        & & exp - exp $\mid$ exp * exp  $\mid$  exp / exp  $\mid$  exp ** exp
 $\mid$ \\
        & & exp \^{} exp  $\mid$ ( exp )\\\\
& & \\
var & ::= & {\it id} $\mid$ {\it id} ( exp$_1$, exp$_2$, \dots\ , exp$_n$ )
 $n > 0$ \\
& & \\
funcall & ::= & {\it id} ( arg$_1$, arg$_2$, \dots\ , arg$_n$ ) $n \geq 0$ \\
& & \\
arg & ::=  & exp $\mid$ logexp $\mid$ {\it string} \\
& &\\
\multicolumn{3}{l}{Logical Expressions:}\\
& & \\
logexp & ::= & {\it T} $\mid$ {\it NIL} $\mid$  var  $\mid$  funcall $\mid$
        exp $>$ exp  $\mid$  exp $>$= exp $\mid$\\
        & & exp = exp  $\mid$ exp {\it NEQ} exp $\mid$ exp $<$ exp $\mid$ \\
        & & exp $<$= exp $\mid$ {\it NOT\/} logexp  $\mid$ logexp {\it AND\/}
 logexp $\mid$ \\
        & & logexp {\it OR\/} logexp  $\mid$  ( logexp )\\
\end{tabular}
\end{describe}

\begin{describe}{Operator Precedence}
The following is a list of REDUCE arithmetic and logical
operators in order of decreasing precedence:
\begin{center}
** (or \^{})  /  *  ---  +  $<$  $<$=  $>$  $>$=  NEQ  = NOT  AND  OR
\end{center}

When unparenthesised expressions are translated which contain
operators whose precedence in REDUCE differs from that in the
target language, parentheses are automatically generated.  Thus
the meaning of the original expression is preserved\footnote{
For example in REDUCE, {\bf NOT~A~=~B} and {\bf NOT~(A~=~B)}
are equivalent, whereas in C, {\bf !~A~==~B} and {\bf (!A)~==~B}
are equivalent.  Therefore, {\bf NOT~A~=~B}
is translated into C code which forces the REDUCE precedence rules:
{\bf !(A~==~B)}
}.
\end{describe}
\begin{describe}{Statements}
\begin{tabular}{lll}
stmt & ::= & assign  $\mid$  break  $\mid$  cond  $\mid$  while $\mid$
           repeat  $\mid$  for  $\mid$  goto  $\mid$  label $\mid$ \\
& &   call  $\mid$  return  $\mid$  stop  $\mid$  stmtgp \\
\end{tabular}

Assignment Statements:

\begin{tabular}{llll}
assign & ::= & \multicolumn{2}{l}{var := assign'  $\mid$  matassign $\mid$
 cond}\\
& & & \\
assign' & ::= & \multicolumn{2}{l}{exp  $\mid$  logexp}\\
& & & \\
matassign & ::= & {\it id} := {\it MAT\/}(&(exp$_{11}$, \dots\ , exp$_{1m}$),\\
 & & &(exp$_{21}$, \dots\ , exp$_{2m}$ ),\\
 & & & \ \ \ \ \ \ :\\
 & & & \ \ \ \ \ \ :\\
 & & &( exp$_{n1}$, \dots\ , exp$_{nm}$ ) ) $n,m > 0$ \\
\end{tabular}

Break Statement:

break  ::= {\it BREAK()}

Conditional Statements:

\begin{tabular}{lll}
cond & ::= & {\it IF\/} logexp {\it THEN\/} stmt\\
& & {\it IF\/} logexp {\it THEN\/} stmt {\it ELSE\/} stmt\\
\end{tabular}

Loops:
\index{FOR loop} \index{WHILE loop} \index{REPEAT loop}

\begin{tabular}{lll} 
while & ::= & {\it WHILE\/} logexp {\it DO\/} stmt\\
& &\\
repeat & ::= & {\it REPEAT\/} stmt {\it UNTIL\/} logexp\\
& &\\
for & ::= & {\it FOR\/} var := exp {\it STEP\/} exp {\it UNTIL\/} exp
{\it DO\/} stmt $\mid$\\
& &{\it FOR\/} var := exp {\it UNTIL\/} exp {\it DO\/} stmt $\mid$\\
& &{\it FOR\/} var := exp : exp {\it DO\/} stmt $\mid$\\
& &var := for' $\mid$ \\
& &\\
for' & ::= & var := for' $\mid$\\
& &{\it FOR\/} var := exp {\it STEP\/} exp {\it UNTIL\/} exp {\it SUM\/} exp
 $\mid$\\
& &{\it FOR\/} var := exp {\it UNTIL\/} exp {\it SUM\/} exp $\mid$\\
& &{\it FOR\/} var := exp : exp {\it SUM\/} exp $\mid$\\
& &{\it FOR\/} var := exp {\it STEP\/} exp {\it UNTIL\/} exp\\
& & \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {\it PRODUCT\/} exp $\mid$ \\
& &{\it FOR\/} var := exp {\it UNTIL\/} exp {\it PRODUCT\/} exp $\mid$\\
& &{\it FOR\/} var := exp : exp {\it PRODUCT\/} exp\\
\end{tabular}

Goto Statement:

\begin{tabular}{lll}
goto & ::= & {\it GOTO\/} label  $\mid$ {\it GO TO\/} label\\
label & ::= & {\it id\/} :\\
\end{tabular}

Subprogram Calls \& Returns \footnote{ Note that return statements can
only be translated from inside of procedure definitions.
\index{LITERAL command} The LITERAL function must be used to generate
a return statement from anywhere else.}:

\begin{tabular}{lll}
call & ::= & {\it id\/} ( arg$_1$, arg$_2$, \dots\ , arg$_n$ ) $n \geq 0$\\
& &\\
return & ::= & {\it RETURN\/} $\mid$ {\it RETURN\/} arg\\
\end{tabular}

Stop \& Exit Statements \footnote{
In certain cases it may be convenient to generate a FORTRAN
STOP statement or a C EXIT statement.  Since there is no
semantically equivalent REDUCE statement, STOP() can be used
and will be translated appropriately.}:

stop  ::= {\it STOP\/}()

Statement Groups \footnote{
Note that REDUCE BEGIN\dots\ END statement groups are translated
into RATFOR or C \{\dots\ \} statement groups, whereas
REDUCE $<$$<$\dots\ $>$$>$ statement groups are translated into RATFOR or
C statement {\it sequences}.  When the target language is FORTRAN, both
types of REDUCE statement groups are translated into statement
sequences.}:

\begin{tabular}{lll}
stmtgp & ::= & $<$$<$ stmt$_1$ ; stmt$_2$ ; \dots\  ; stmt$_n$ $>$$>$
 $\mid$\\
& &{\it BEGIN\/} stmt$_1$ ; stmt$_2$ ; \dots\  ; stmt$_n$ {\it END\/} $ n >
 0$\\
\end{tabular}
\end{describe}
\begin{describe}{Subprogram Definitions}
\begin{tabular}{lll} 
defn & ::= & {\it PROCEDURE id\/} ({\it id$_1$, id$_2$, \dots\ , id$_n$\/}) ;
 stmt $\mid$\\
& & {\it PROCEDURE id\/} ({\it id$_1$, id$_2$, \dots\ , id$_n$\/}) ;
 exp\ \ \ \ \ \  $n \geq 0$ \\
\end{tabular}
\end{describe}

\subsubsection{Translatable REDUCE Prefix Forms}
\begin{describe}{Expressions}

Arithmetic Expressions:

\begin{tabular}{lll}
exp & ::= & {\it number\/} $\mid$  funcall  $\mid$  var  $\mid$ 
({\it DIFFERENCE\/} exp exp) $\mid$\\
& &({\it EXPT\/} exp exp)  $\mid$  ({\it MINUS\/} exp)  $\mid$  ({\it PLUS\/}
 exp exp') $\mid$\\
& & ({\it QUOTIENT\/} exp exp)  $\mid$  ({\it RECIP\/} exp) $\mid$\\
& & ({\it TIMES\/} exp exp exp')  $\mid$  ({\it !*SQ\/} sqform)\\
\end{tabular}

where sqform is a standard quotient form equivalent to any acceptable prefix
form.

exp' ::=  exp$_1$ exp$_2$ \dots\  exp$_n$  $n \geq 0$

Logical Expressions:

\begin{tabular}{lll}
logexp & ::= & {\it NIL\/} $\mid$ {\it T\/} $\mid$  funcall  $\mid$  var
$\mid$\\
& &  ({\it AND\/} logexp logexp logexp')  $\mid$  ({\it EQUAL\/} exp exp)
$\mid$\\
& & ({\it GEQ\/} exp exp)  $\mid$  ({\it GREATERP\/} exp exp)  $\mid$ \\
& & ({\it LEQ\/} exp exp) $\mid$ ({\it LESSP\/} exp exp)  $\mid$ \\
& & ({\it NEQ\/} exp exp) $\mid$ ({\it NOT\/} logexp) $\mid$ \\
& & ({\it OR\/} logexp logexp logexp')\\
& &\\
logexp' & ::= & logexp$_1$ logexp$_2$ \dots\  logexp$_n$  $n \geq 0$\\
\end{tabular}
\end{describe}

\begin{describe}{Statements}
\begin{tabular}{lll}
stmt & ::= &  assign  $\mid$  break  $\mid$  call  $\mid$  cond  $\mid$
for  $\mid$  goto $\mid$\\
& & label  $\mid$  read  $\mid$  repeat  $\mid$  return  $\mid$  stmtgp
$\mid$\\
& & stop  $\mid$  while  $\mid$  write \\
& &\\
stmt' &  ::= & stmt$_1$ stmt$_2$ \dots\  stmt$_n$   $n \geq 0$\\
\end{tabular}

Assignment Statements:

assign  ::=  ({\it SETQ\/} var exp)  $\mid$  ({\it SETQ\/} var logexp) $\mid$
             ({\it SETQ\/} id ({\it MAT\/} list list'))

Conditional Statements:

\begin{tabular}{lll}
cond & ::= & ({\it COND\/} (logexp stmt) cond1) \\
& & \\
cond1 & ::= & (logexp stmt$_1$) \dots\  (logexp stmt$_n$) $n \geq 0$\\
\end{tabular}

Loops:

\begin{tabular}{lll}
for & ::= & ({\it FOR\/} var (exp exp exp) {\it DO\/} stmt) $\mid$\\
& &  ({\it SETQ\/} var ({\it FOR\/} var (exp exp exp) {\it SUM\/} exp) $\mid$\\
& & ({\it SETQ\/} var ({\it FOR\/} var (exp exp exp) \\
& & \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {\it PRODUCT\/} exp)\\
& &\\
repeat & ::= & ({\it REPEAT\/} stmt logexp)\\
& &\\
while & ::= & ({\it WHILE\/} logexp stmt)
\end{tabular}

Go To Statements:

\begin{tabular}{lll} 
break & ::= & ({\it BREAK\/})\\
& & \\
goto & ::= & ({\it GO\/} label)\\
& & \\
label & ::= & {\it id}\\
\end{tabular}

Subprogram Calls \& Returns:

\begin{tabular}{lll}
call & ::= & ({\it id\/} arg')\\
& &\\
return & ::= & ({\it RETURN\/})  $\mid$  ({\it RETURN\/} arg)\\
\end{tabular}

Stop \& Exit Statements:

stop ::= ({\it STOP\/})

Statement Groups:

stmtgp  ::=  ({\it PROGN\/} stmt stmt')  $\mid$  ({\it BLOCK\/} (id') stmt')

I/O Statements:

\begin{tabular}{lll}
read & ::= & ({\it SETQ\/} var ({\it READ\/}))\\
& &\\
write & ::= & ({\it WRITE\/} arg arg')\\
\end{tabular}

Subprogram Definitions:

defn  ::=  ({\it PROCEDURE id NIL EXPR\/} (id') stmt)

\end{describe}

\begin{describe}{Miscellaneous}
\begin{tabular}{lll} 
funcall & ::= & ({\it id\/} arg')\\
& &\\
var & ::= & {\it id\/} $\mid$  ({\it id\/} exp exp')\\
& &\\
arg & ::= & {\it string\/} $\mid$  exp  $\mid$  logexp\\
& &\\
arg' & ::= & arg$_1$ arg$_2$ \dots\  arg$_n$  $n \geq 0$ \\
& &\\
list & ::= & (exp exp')\\
& &\\
list' & ::= & list$_1$ list$_2$ \dots\  list$_n$   $n \geq 0$ \\
& &\\
id' &  ::= & {\it id$_1$ id$_2$} \dots\ {\it id$_n$}  $n \geq 0$ \\
\end{tabular}
\end{describe}

\section{List of Commands, Switches, \& Variables}
\label{appb}
\begin{describe}{COMMANDS}
\index{GENTRAN command}
{\bf GENTRAN} {\it stmt\/} [{\bf OUT}{\it  f1,f2,\dots\ ,fn\/}]{\it ;}

\index{GENTRANIN command}
{\bf GENTRANIN} {\it f1,f2,\dots\ ,fm\/} [{\bf OUT}{\it  f1,f2,\dots\
,fn\/}]{\it ;}

\index{GENTRANOUT command}
{\bf GENTRANOUT} {\it f1,f2,\dots\ ,fn;}

\index{GENTRANSHUT command}
{\bf GENTRANSHUT} {\it f1,f2,\dots\ ,fn;}

\index{GENTRANPUSH command}
{\bf GENTRANPUSH} {\it f1,f2,\dots\ ,fn;}

\index{GENTRANPOP command}
{\bf GENTRANPOP} {\it f1,f2,\dots\ ,fn;}
\end{describe}

\begin{describe}{SPECIAL FUNCTIONS \& OPERATORS}

\ttindex{EVAL}
{\bf EVAL} {\it exp}

\index{::=}
{\it var} {\bf ::=} {\it exp;}

\index{:=:}
{\it var} {\bf :=:} {\it exp;}

\index{::=:}
{\it var} {\bf ::=:} {\it exp;}

\ttindex{LSETQ}
{\it var} {\bf LSETQ} {\it exp;}

\ttindex{RSETQ}
{\it var} {\bf RSETQ} {\it exp;}

\ttindex{LRSETQ}
{\it var} {\bf LRSETQ} {\it exp;}

\index{DECLARE function}
{\bf DECLARE} {\it v1,v2,\dots\ ,vn\/}{\bf :} {\it  type;}

\begin{tabular}{ll}
{\bf DECLARE}\\
{\bf $<$$<$}\\
&{\it v11,v12,\dots\ ,v1n} {\bf :} {\it type1\/}{\bf ;}\\
&{\it v12,v22,\dots\ ,v2n} {\bf :} {\it type2\/}{\bf ;}\\
& \ \ \ :\\
& \ \ \ :\\
&{\it vm1,vm2,\dots\ ,vmn} {\bf :} {\it typen\/}{\bf ;}\\
{\bf $>$$>$}{\it ;}
\end{tabular}

\ttindex{LITERAL}
{\bf LITERAL} {\it arg1,arg2,\dots\ ,argn;}
\end{describe}

\begin{describe}{MODE SWITCHES}
{\bf PERIOD} \index{PERIOD switch}

{\bf GENTRANSEG} \index{GENTRANSEG switch}

{\bf GENDECS} \index{GENDECS switch}

{\bf DOUBLE} \index{DOUBLE switch}

{\bf MAKECALLS} \index{MAKECALLS switch}

{\bf KEEPDECS} \index{KEEPDECS switch}

{\bf GETDECS} \index{GETDECS switch}

\end{describe}

\begin{describe}{VARIABLES}
{\bf GENTRANLANG!*}  \ttindex{GENTRANLANG!*}

{\bf MAXEXPPRINTLEN!*}  \ttindex{MAXEXPPRINTLEN!*}

{\bf TEMPVARNAME!*}  \ttindex{TEMPVARNAME!*}

{\bf TEMPVARNUM!*}  \ttindex{TEMPVARNUM!*}

{\bf TEMPVARTYPE!*}  \ttindex{TEMPVARTYPE!*}

{\bf GENSTMTNUM!*}  \ttindex{GENSTMTNUM!*}

{\bf GENSTMTINCR!*}  \ttindex{GENSTMTINCR!*}

{\bf TABLEN!*}  \ttindex{TABLEN!*}

{\bf FORTLINELEN!*}  \ttindex{FORTLINELEN!*}

{\bf RATLINELEN!*}  \ttindex{RATLINELEN!*}

{\bf CLINELEN!*}  \ttindex{CLINELEN!*}

{\bf PASCLINELEN!*}  \ttindex{PASCLINELEN!*}

{\bf MINFORTLINELEN!*}  \ttindex{MINFORTLINELEN!*}

{\bf MINRATLINELEN!*}  \ttindex{MINRATLINELEN!*}

{\bf MINCLINELEN!*}  \ttindex{MINCLINELEN!*}

{\bf MINPASCLINELEN!*}  \ttindex{MINPASCLINELEN!*}

{\bf DEFTYPE!*} \ttindex{DEFTYPE!*}
\end{describe}

\begin{describe}{TEMPORARY VARIABLE GENERATION, MARKING \& UNMARKING}
{\bf TEMPVAR} {\it type;} \ttindex{TEMPVAR}

{\bf MARKVAR} {\it var;} \ttindex{MARKVAR}

{\bf UNMARKVAR} {\it var;} \ttindex{UNMARKVAR}
\end{describe}

\begin{describe}{EXPLICIT GENERATION OF TYPE DECLARATIONS}
{\bf GENDECS} {\it subprogname;} \ttindex{GENDECS switch}
\end{describe}

\begin{describe}{SYMBOLIC MODE FUNCTIONS}
{\bf SYM!-GENTRAN} {\it form;} \index{SYM"!-GENTRAN command}

{\bf SYM!-GENTRANIN} {\it list-of-fnames;} \index{SYM"!-GENTRANIN command}

{\bf SYM!-GENTRANOUT} {\it list-of-fnames;} \index{SYM"!-GENTRANOUT command}

{\bf SYM!-GENTRANSHUT} {\it list-of-fnames;} \index{SYM"!-GENTRANSHUT command}

{\bf SYM!-GENTRANPUSH} {\it list-of-fnames;} \index{SYM"!-GENTRANPUSH command}

{\bf SYM!-GENTRANPOP} {\it list-of-fnames;} \index{SYM"!-GENTRANPOP command}
\end{describe}

\begin{describe}{SYMBOLIC MODE SPECIAL FORMS}
\begin{tabular}{ll}
\ttindex{DECLARE}
{\bf (DECLARE} & {\bf (}{\it type1 v11 v12 \dots\  v1n\/}{\bf )}\\
& {\bf (}{\it type2 v21 v22 \dots\  v2n\/}{\bf )}\\
& \ \ \ :\\
& \ \ \ :\\
& {\bf (}{\it typen vn1 vn2 \dots\  vnn\/}{\bf ))}\\
\end{tabular}

{\bf (LITERAL} {\it arg1 arg2 \dots\  argn\/}{\bf )} \ttindex{LITERAL}

{\bf (EVAL} {\it exp\/}{\bf )} \ttindex{EVAL}

{\bf (LSETQ} {\it var exp\/}{\bf )} \ttindex{LSETQ}

{\bf (RSETQ} {\it var exp\/}{\bf )} \ttindex{RSETQ}

{\bf (LRSETQ} {\it var exp\/}{\bf )} \ttindex{LRSETQ}
\end{describe}

\section{The Programs {\tt M1.F} and {\tt M2.F}.}
\label{appc}

This section contains the two files generated in chapter 6.
Contents of file m1.f:
\begin{framedverbatim}
      M(1,1)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*Y*J30)+DSIN(DBLE(Q3))**2*J30Z+18.0D0*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**2*M30+18.0D0*P**2*M30+P**2*M10
     . +J30Y+J10Y
      M(1,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*DCOS(DBLE(
     . Q3))*DCOS(DBLE(Q2))*P**2*M30+9.0D0*P**2*M30+J30Y
      M(1,3)=-(9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30)
      M(2,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*P**2*M30+
     . J30Y
      M(2,3)=0.0D0
      M(3,3)=9.0D0*P**2*M30+J30X
      MIV(1,1)=(-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y)+9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P**2*
     . M30*J30X)-(DSIN(DBLE(Q3))**2*J30Y*J30X)+DSIN(DBLE(Q3))
     . **2*J30Z*J30X+81.0D0*P**4*M30**2+9.0D0*P**2*M30*J30Y+
     . 9.0D0*P**2*M30*J30X+J30Y*J30X)/(729.0D0*DSIN(DBLE(Q3))
     . **4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0*DSIN(DBLE(Q3
     . ))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-(81.0D0*DSIN(
     . DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Z)+
     . 81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(81.0D0*
     . DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(DBLE(Q3
     . ))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**
     . 2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*
     . J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN
     . (DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*
     . J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(
     . DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y
     . *J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**
     . 2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2)
     . )**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6
     . *M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*
     . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*
     . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2*
     . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-(
     . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2*
     . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN(
     . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2
     . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3))
     . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6*
     . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+
     . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0*
     . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2*
     . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30*
     . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      MIV(1,2)=(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Y-(9.0D0*DSIN(DBLE(Q3))
     . **2*P**2*M30*J30Z)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*
     . J30X+DSIN(DBLE(Q3))**2*J30Y*J30X-(DSIN(DBLE(Q3))**2*
     . J30Z*J30X)-(81.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**4*
     . M30**2)-(9.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30*
     . J30X)-(81.0D0*P**4*M30**2)-(9.0D0*P**2*M30*J30Y)-(
     . 9.0D0*P**2*M30*J30X)-(J30Y*J30X))/(729.0D0*DSIN(DBLE(
     . Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0*DSIN(DBLE
     . (Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-(81.0D0*
     . DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Z)+
     . 81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(81.0D0*
     . DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(DBLE(Q3
     . ))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**
     . 2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*
     . J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN
     . (DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*
     . J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(
     . DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y
     . *J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**
     . 2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2)
     . )**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6
     . *M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*
     . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*
     . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2*
     . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-(
     . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2*
     . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN(
     . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2
     . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3))
     . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6*
     . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+
     . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0*
     . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2*
     . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30*
     . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      MIV(1,3)=(-(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**
     . 4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2
     . *M30*J30Y)+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2
     . *M30*J30Z+81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**4*
     . M30**2+9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30*
     . J30Y)/(729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**
     . 6*M30**3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P
     . **4*M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2
     . ))**2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*
     . Y*M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*
     . J30Y)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)+9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(9.0D0*DSIN(DBLE
     . (Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(DBLE(Q3))**4*P**
     . 2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y
     . *J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*J30-(DSIN(DBLE(Q3
     . ))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3))**4*J30Y**2*J30X
     . )+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(729.0D0*DSIN(DBLE(
     . Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DSIN(
     . DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y)-(
     . 729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(81.0D0*DSIN(
     . DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN(DBLE(Q3))**
     . 2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))**2*P**4*M30
     . **2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J10Y)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30Y
     . *J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30X*J30)+
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2-(9.0D0*DSIN(
     . DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*DSIN(DBLE(Q3))
     . **2*P**2*M30*J30Z*J10Y+9.0D0*DSIN(DBLE(Q3))**2*P**2*
     . M30*J30Z*J30X-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J10Y*
     . J30X)-(DSIN(DBLE(Q3))**2*P**2*J30Y*M10*J30X)+DSIN(DBLE
     . (Q3))**2*P**2*J30Z*M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*
     . J30X*J30)+DSIN(DBLE(Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3
     . ))**2*J30Y*J10Y*J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X
     . -(729.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30
     . **3)-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*
     . J30X+J30Y*J10Y*J30X)
      MIV(2,2)=(-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*
     . P**4*M30**2)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+9.0D0*DSIN(
     . DBLE(Q3))**2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*M30*J30X)-(DSIN(DBLE(Q3))**2*Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Z*J30X+162.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2
     . ))*P**4*M30**2+18.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P
     . **2*M30*J30X+162.0D0*P**4*M30**2+9.0D0*P**4*M30*M10+
     . 9.0D0*P**2*M30*J30Y+9.0D0*P**2*M30*J10Y+18.0D0*P**2*
     . M30*J30X+P**2*M10*J30X+J30Y*J30X+J10Y*J30X)/(729.0D0*
     . DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0
     . *DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-
     . (81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**
     . 2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(
     . 81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*
     . Y*M30*J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y
     . **2)+9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0
     . *DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))
     . **4*Y*J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30
     . )-(DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*
     . J30Y*J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2
     . ))**2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE
     . (Q2))**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*
     . P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10
     . )-(81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*
     . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*
     . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2*
     . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-(
     . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2*
     . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN(
     . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2
     . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3))
     . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6*
     . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+
     . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0*
     . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2*
     . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30*
     . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      MIV(2,3)=(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**4*
     . M30**2+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30
     . *J30Y-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30
     . *J30Z)-(81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**4*M30**2)-(81.0D0*DSIN(DBLE(Q3
     . ))*DSIN(DBLE(Q2))*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))*
     . DSIN(DBLE(Q2))*P**2*M30*J30Y))/(729.0D0*DSIN(DBLE(Q3))
     . **4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0*DSIN(DBLE(Q3)
     . )**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-(81.0D0*DSIN(
     . DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Z)+
     . 81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(81.0D0*
     . DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(DBLE(Q3
     . ))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**
     . 2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*
     . J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN
     . (DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*
     . J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(
     . DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y
     . *J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**
     . 2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2)
     . )**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6
     . *M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*
     . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*
     . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2*
     . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-(
     . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2*
     . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN(
     . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2
     . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3))
     . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6*
     . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+
     . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0*
     . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2*
     . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30*
     . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      MIV(3,3)=(9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30-(9.0D0
     . *DSIN(DBLE(Q3))**4*P**2*M30*J30Y)+DSIN(DBLE(Q3))**4*Y*
     . J30Y*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2)+DSIN(DBLE(Q3))**4*J30Y*J30Z-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30*M10)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y)-(DSIN(DBLE(Q3))**2*P**2*J30Y*
     . M10)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10-(DSIN(DBLE(Q3))**
     . 2*Y*J30Y*J30)+DSIN(DBLE(Q3))**2*J30Y**2-(DSIN(DBLE(Q3)
     . )**2*J30Y*J10Y)+DSIN(DBLE(Q3))**2*J30Z*J10Y-(81.0D0*
     . DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*M30**2)+
     . 81.0D0*P**4*M30**2+9.0D0*P**4*M30*M10+9.0D0*P**2*M30*
     . J30Y+9.0D0*P**2*M30*J10Y+P**2*J30Y*M10+J30Y*J10Y)/(
     . 729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30
     . **2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P
     . **4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**
     . 2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE
     . (Q3))**4*P**2*Y*M30*J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*
     . P**2*M30*J30Y**2)+9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*
     . J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30X)
     . +DSIN(DBLE(Q3))**4*Y*J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*
     . Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN
     . (DBLE(Q3))**4*J30Y*J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**
     . 2*DSIN(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3)
     . )**2*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y)-(729.0D0*DSIN
     . (DBLE(Q3))**2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **6*M30**2*M10)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**
     . 2*J30)+81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J10Y)-(81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30X)-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*
     . J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30X*J30)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*M30*J30Y*J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2
     . *M30*J30Z*J10Y+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*
     . J30X-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(
     . DSIN(DBLE(Q3))**2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**
     . 2*P**2*J30Z*M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*
     . J30)+DSIN(DBLE(Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2
     . *J30Y*J10Y*J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(
     . 729.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**
     . 3)-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0
     . *P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2
     . *M30*J30Y*J30X+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*
     . J30X+J30Y*J10Y*J30X)
      DO 25005 J=1,3
          DO 25006 K=J+1,3
              M(K,J)=M(J,K)
              MIV(K,J)=MIV(J,K)
25006     CONTINUE
25005 CONTINUE
\end{framedverbatim}

\newpage

Contents of file m2.f:
\begin{framedverbatim}
      M(1,1)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*Y*J30)+DSIN(DBLE(Q3))**2*J30Z+18.0D0*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**2*M30+18.0D0*P**2*M30+P**2*M10
     . +J30Y+J10Y(1,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(
     . DSIN(DBLE(Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*
     . DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30+9.0D0*P**2*M30+
     . J30Y(1,3)=-(9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*
     . M30)
      M(2,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*P**2*M30+
     . J30Y
      M(2,3)=0.0D0
      M(3,3)=9.0D0*P**2*M30+J30X
      T1=-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(9.0D0*DSIN(
     . DBLE(Q3))**2*P**2*M30*J30Y)+9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30X)-(
     . DSIN(DBLE(Q3))**2*J30Y*J30X)+DSIN(DBLE(Q3))**2*J30Z*
     . J30X+81.0D0*P**4*M30**2+9.0D0*P**2*M30*J30Y+9.0D0*P**2
     . *M30*J30X+J30Y*J30X
      T0=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T0=T0+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T0=T0-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T0=T0+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T0=T0-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     ; M30*J30Y*J30X
      MIV(1,1)=T1/(T0+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*
     . J30X+J30Y*J10Y*J30X)
      T0=81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2+9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J30Y-(9.0D0*DSIN(DBLE(Q3))**2*P**2*
     . M30*J30Z)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30X+DSIN(
     . DBLE(Q3))**2*J30Y*J30X-(DSIN(DBLE(Q3))**2*J30Z*J30X)-(
     . 81.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**4*M30**2)-(
     . 9.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30*J30X)-(
     . 81.0D0*P**4*M30**2)-(9.0D0*P**2*M30*J30Y)
      T1=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T1=T1+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T1=T1-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T1=T1-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T1=T1+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T1=T1-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(1,2)=(T0-(9.0D0*P**2*M30*J30X)-(J30Y*J30X))/(T1+
     . 9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*
     . J30X)
      T0=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T0=T0+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T0=T0-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T0=T0+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T0=T0-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(1,3)=(-(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**
     . 4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2
     . *M30*J30Y)+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2
     . *M30*J30Z+81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**4*
     . M30**2+9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30*
     . J30Y)/(T0+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*J30X+
     . J30Y*J10Y*J30X)
      T0=-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+9.0D0*DSIN(DBLE(Q3))
     . **2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*
     . J30X)-(DSIN(DBLE(Q3))**2*Y*J30X*J30)+DSIN(DBLE(Q3))**2
     . *J30Z*J30X+162.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**4*
     . M30**2+18.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30*
     . J30X+162.0D0*P**4*M30**2
      T1=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T1=T1+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T1=T1-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T1=T1-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T1=T1+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T1=T1-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(2,2)=(T0+9.0D0*P**4*M30*M10+9.0D0*P**2*M30*J30Y+
     . 9.0D0*P**2*M30*J10Y+18.0D0*P**2*M30*J30X+P**2*M10*J30X
     . +J30Y*J30X+J10Y*J30X)/(T1+9.0D0*P**2*M30*J10Y*J30X+P**
     . 2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      T0=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T0=T0+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T0=T0-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T0=T0+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T0=T0-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(2,3)=(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**4*
     . M30**2+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30
     . *J30Y-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30
     . *J30Z)-(81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**4*M30**2)-(81.0D0*DSIN(DBLE(Q3
     . ))*DSIN(DBLE(Q2))*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))*
     . DSIN(DBLE(Q2))*P**2*M30*J30Y))/(T0+9.0D0*P**2*M30*J10Y
     . *J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      T0=9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30-(9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y)+DSIN(DBLE(Q3))**4*Y*J30Y*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30)-(DSIN(DBLE(Q3))**4*
     . J30Y**2)+DSIN(DBLE(Q3))**4*J30Y*J30Z-(81.0D0*DSIN(DBLE
     . (Q3))**2*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30*M10)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z
      T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J10Y)-(DSIN(
     . DBLE(Q3))**2*P**2*J30Y*M10)+DSIN(DBLE(Q3))**2*P**2*
     . J30Z*M10-(DSIN(DBLE(Q3))**2*Y*J30Y*J30)+DSIN(DBLE(Q3))
     . **2*J30Y**2-(DSIN(DBLE(Q3))**2*J30Y*J10Y)+DSIN(DBLE(Q3
     . ))**2*J30Z*J10Y-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2
     . ))**2*P**4*M30**2)+81.0D0*P**4*M30**2+9.0D0*P**4*M30*
     . M10+9.0D0*P**2*M30*J30Y
      T1=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T1=T1+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T1=T1-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T1=T1-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T1=T1+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T1=T1-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(3,3)=(T0+9.0D0*P**2*M30*J10Y+P**2*J30Y*M10+J30Y*
     . J10Y)/(T1+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*J30X+
     . J30Y*J10Y*J30X)
      DO 25007 J=1,3
          DO 25008 K=J+1,3
              M(K,J)=M(J,K)
              MIV(K,J)=MIV(J,K)
25008     CONTINUE
25007 CONTINUE
\end{framedverbatim}
\bibliography{gentran}
\bibliographystyle{plain}
\end{document}

Added r34.1/doc/groebner.bib version [36d46646a2].





































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
% Bibliography for groebner.tex

@ARTICLE{Boege:86,
 AUTHOR = "W. Boege and R. Gebauer and H. Kredel",
 TITLE = "Some Examples for Solving Systems of Algebraic Equations
by Calculating {Groebner} Bases",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1986, VOLUME = 2, NUMBER = 1, PAGES = "83-98", MONTH = "March"}

@INCOLLECTION{Buchberger:85,
  AUTHOR = "B. Buchberger",
  TITLE = "Groebner Bases: An Algorithmic Method in Polynomial Ideal Theory",
  EDITOR = "N. K. Bose",
  BOOKTITLE = "Progress, directions and open problems in multidimensional
systems theory",
  PAGES = "184-232",
  PUBLISHER = "Dordrecht: Reidel",
  YEAR = 1985}

@INCOLLECTION{Buchberger:88,
  AUTHOR = "B. Buchberger",
  TITLE = "Applications of Groebner Bases in Non-Linear Computational
Geometry",
  EDITOR = "R. Janssen",
  BOOKTITLE = "Trends in Computer Algebra",
  PAGES = "52-80",
  PUBLISHER = "Berlin, Heidelberg", YEAR = 1988}

@BOOK{Davenport:88a,
 AUTHOR = "J. H. Davenport and Y. Siret and E. Tournier",
 TITLE = "Computer Algebra, Systems and Algorithms for Algebraic
Computation",
 PUBLISHER = "Academic Press", PRINTING = "2nd", YEAR = 1989}

@INCOLLECTION{Ebert:81,
  AUTHOR = "K. H. Ebert and P. Deuflhard",
  EDITOR = "W. Jaeger",
  TITLE = "Modelling of Chemical Reaction Systems",
  PUBLISHER = "Springer Verlag",
  BOOKTITLE = "Springer Ser. Chem. Phys", VOLUME = 18, YEAR = 1981}

@TECHREPORT{Faugere:89,
  AUTHOR = "J. C. Faug{\`e}re and P. Gianni and  D. Lazard and T. Mora",
  TITLE = "Efficient Computation of Zero-Dimensional Groebner Bases by Change
of Ordering",
  YEAR = 1989}

@ARTICLE{Gebauer:88,
 AUTHOR = "R{\"u}diger Gebauer and H. Michael M{\"o}ller",
 TITLE = "On an Installation of {Buchberger's} Algorithm",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1988, VOLUME = 6, NUMBER = "2 and 3", PAGES = "275-286"}

@ARTICLE{Kredel:88,
 AUTHOR = "Heinz Kredel",
 TITLE = "Admissible termorderings used in Computer Algebra Systems",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1988, VOLUME = 22, NUMBER = 1, PAGES = "28-31", MONTH = "January"}

@TECHREPORT{Melenk:88,
 AUTHOR = "H. Melenk and H. M. M{\"o}ller and W. Neun",
 TITLE = "On Gr{\"o}bner Bases Computation on a Supercomputer
Using {REDUCE}",
 INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik
Berlin",
 YEAR = 1988, TYPE = "Preprint", NUMBER = "SC 88-2", MONTH = "January"}

Added r34.1/doc/groebner.tex version [8b158513e2].

















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
\documentstyle[11pt,reduce]{article}
\title{GROEBNER: A Package for Calculating Groebner Bases}
\date{}
\author{
H. Melenk \& W. Neun \\[0.05in]
Konrad--Zuse--Zentrum \\
f\"ur Informationstechnik Berlin \\
Heilbronner Strasse 10 \\
D--1000 Berlin 31 \\
Federal Republic of Germany \\[0.05in]
Email:  melenk@sc.zib--berlin.de \\[0.05in]
and \\[0.05in]
H.M. M\"oller \\[0.05in]
Fernuniversit\"at Hagen \\
FB Math und Informatik\\
Postfach 940 \\
D--5800 Hagen \\
Federal Republic of Germany\\[0.05in]
Email: ma105@dhafeu11.bitnet}

\begin{document}
\maketitle

\index{Groebner Bases}
Groebner bases are a valuable tool for solving problems in
connection with multivariate polynomials, such as solving systems of
algebraic equations and analyzing polynomial ideals. For a definition
of Groebner bases, a survey of possible applications and further
references, see~\cite{Buchberger:85}. Examples are given in \cite{Boege:86},
in \cite{Buchberger:88} and also in the test file for this package.

\index{GROEBNER package} \index{Buchberger's Algorithm}
The GROEBNER package calculates Groebner bases using the
Buchberger algorithm.  It can be used over a variety of different
coefficient domains, and for different variable and term orderings.

The current version of the package uses parts of the previous
version, written by  R. Gebauer, A.C. Hearn, H. Kredel and M.
M\"oller. The algorithms implemented in the current version are
documented in \cite{Faugere:89} and \cite{Gebauer:88}.

\subsubsection*{Incompatibilities with the Groebner package in
REDUCE 3.3:}
\begin{itemize}
\item In contrast to the previous version, the polynomials in the
Groebner bases by default now have non fractional coefficients;
the fractional forms can be generated by dividing each polynomial
by its leading coefficient or by setting ON RATIONAL.

\ttindex{GREDUCE} \index{PREDUCE}
\item The routines GREDUCE and PREDUCE now avoid fractional coefficients
by reducing a constant multiple of the input polynomial instead of the
polynomial itself (``pseudo reduction'' ) as long as RATIONAL is off.

\item The term order modes were cleaned up so that their names
now correspond to the literature:
\begin{center}
\begin{tabular}{c}
INVLEX $\rightarrow$ LEX, INVTOTALDEGREE $\rightarrow$
GRADLEX, \\
TOTALDEGREE $\rightarrow$ REVGRADLEX
\end{tabular}
\end{center}
 For compatibility reasons, the old names (except the old LEX, which
 did not represent an order usable in the Groebner context) are
 still supported.
\end{itemize}

\section{Background}

% Section 1.1
\subsection{Variables, Domains and Polynomials}

The various functions of the Groebner package manipulate
equations and/or polynomials; equations are internally
transformed into  polynomials by forming the difference of
left-hand side and right-hand side.

All manipulations take place in a ring of polynomials in some
variables $x1, \ldots , xn$ over a coefficient domain $D$:
\[
D [x1,\ldots , xn],
\]
where $D$ is a field or at least a ring without zero divisors.
The set of variables $x1,\ldots ,xn$ can be given explicitly by the
user (optional parameter) or it is extracted automatically from the
input expressions.

All REDUCE kernels can play the role of ``variables'' in this context;
examples are

%{\small
\begin{verbatim}
X Y Z22 SIN(ALPHA) COS(ALPHA) C(1,2,3) C(1,3,2) FARINA4711
\end{verbatim}
%}

The domain $D$ is the current REDUCE domain with those kernels
adjoined, which are not members of the list of variables. So the
elements of $D$ may be complicated polynomials themselves over
kernels not in the list of variables; if, however, the variables are
extracted automatically from the input expressions, $D$ is identical
with the current REDUCE domain. It is useful to regard kernels not
being members of the list of variables as ``parameters'', e.g.
\[
\begin{array}{c}
 a * x + (a - b) * y**2 \;\mbox{ with ``variables''}\{x,y\} \\
\mbox{and ``parameters''  $\;a\;$ and $\;b\;$}\;.
\end{array}
\]

The current version of the Buchberger algorithm has two internal
modes, a field mode and a ring mode. In the starting phase the
algorithm analyzes the domain type; if it recognizes $D$ as being a
ring it uses the ring mode, otherwise the field mode is needed.
Normally field calculations occur only if all coefficients are numbers
and if the current REDUCE domain is a field (e.g. rational numbers,
modular numbers). In general, the ring mode is the faster one
(compared in cases where both are applicable). When no specific
REDUCE domain is selected, the ring mode is used, even if the input
formulas contain fractional coefficients: they are multiplied by their
common denominators so that they become integer polynomials.

%Section 1.2
\subsection{Term Ordering} \par
In the theory of Groebner bases, the terms of polynomials are
considered as ordered. The following order modes are available in
the current package:
\index{LEX ! term order} \index{GRADLEX ! term order}
\index{REVGRADLEX ! term order}

\begin{center}
LEX, GRADLEX, REVGRADLEX
\end{center}

All orderings are based on an ordering among the variables. For
each pair of variables $(a,b)$ an order relation must be defined, e.g.
``$ a\gg b $''. The greater sign $\gg$  does not represent a numerical
relation among the variables; it can be interpreted only in terms of
formula representation: ``$a$'' will be placed in front of ``$b$'' or
``$a$''  is more complicated than ``$b$''.

The sequence of variables constitutes this order base. So the notion
of
\[
\{x1,x2,x3\}
\]

as a list of variables at the same time means
\[
x1 \gg x2 \gg x3
\]
with respect to the term order.

If terms (products of powers of variables) are compared with LEX,
that term is chosen which has a greater variable or a higher degree
if the greatest variable is the first in both. With GRADLEX the sum of
all exponents (the total degree) is compared first, and if that does
not lead to a decision, the LEX method is taken for the final decision.
The REVGRADLEX method also compares the total degree first, but
afterward it uses the LEX method in the reverse direction; this is the
method originally used by Buchberger.

\example with $\{x,y,z\}$: \index{GROEBNER package ! example}

\[
\begin{array}{rlll}
\multicolumn{2}{l}{\hspace*{-1cm}\mbox{\bf LEX:}}\\
 x * y **3 & \gg & y ** 48 & \mbox{(heavier variable)} \\
 x**4 * y**2 & \gg  & x**3 * y**10 & \mbox{(higher degree in 1st
variable)} \vspace*{2mm} \\
\multicolumn{2}{l}{\hspace*{-1cm}\mbox{\bf GRADLEX:}} \\
  y**3 * z**4 & \gg & x**3 * y**3 & \mbox{(higher total degree)} \\
  x**3 * y**3  & \gg & y**3 * z**3  & \mbox{(equal total degree)}
\vspace*{2mm}\\
\multicolumn{2}{l}{\hspace*{-1cm}\mbox{\bf
REVGRADLEX:}} \\
 y**3 * z**4 & \gg &  x**3 * y**3 & \mbox{(higher total degree)} \\
 x**3 * y**3 & \ll  &  y**3 * z**3  & \mbox{(equal total degree,} \\
 & & & \mbox{so reverse order of LEX)}
\end{array}
\]

The formal description of the term order modes is similar to
\cite{Kredel:88}; this description regards only the exponents of a term,
which are written as vectors of integers with $0$ for exponents of a
variable which does not occur:
\[
\begin{array}{l}
  (e) = (e1,\ldots , en) \;\mbox{ representing }\; x1**e1 \ x2**e2 \cdots
  xn**en. \\
  \deg(e) \; \mbox{ is the sum over all elements of } \;(e) \\
  (e) \gg (l) \Longleftrightarrow (e)-(l)\gg (0) = (0,\ldots ,0)
\end{array}
\]
\[
\begin{array}{rll}
\multicolumn{1}{l}{\hspace*{-.5cm}\mbox{\bf LEX:}} \\
  (e) > lex > (0) & \Longrightarrow  & e_k > 0 \mbox{ and } e_j =0
\mbox{ for }\; j=1,\ldots , k-1\vspace*{2mm} \\
\multicolumn{1}{l}{\hspace*{-.5cm}\mbox{\bf
GRADLEX:}} \\
  (e) >gl> (0)  & \Longrightarrow  & \deg(e)>0  \mbox { or } (e) >lex>
(0)\vspace*{2mm} \\
\multicolumn{1}{l}{\hspace*{-.5cm}\mbox{\bf
REVGRADLEX:}}\\
  (e) >rgl> (0) & \Longrightarrow & \deg(e)>0  \mbox{ or }(e)  <lex<
(0)
\end{array}
\]

Note that the LEX ordering is identical to the standard REDUCE
kernel ordering, when KORDER is set explicitly to the sequence of
variables.

\index{default ! term order}
LEX is the default term order mode in the Groebner package.

It is beyond the scope of this manual to discuss the functionality of
the term order modes. See \cite{Buchberger:88}.

Most operators in this package accept a list of variables as an
optional last parameter. If this parameter is given explicitly, it
defines the names of the variables and their sequence at the same
time. If the parameter is omitted, the variables are extracted from
the expressions automatically and the REDUCE system order defines
their sequence; this can be influenced by setting an explicit order
via the KORDER statement.

The result of a Groebner calculation is algebraically correct only
with respect to the term order mode and the variable sequence
which was in effect during the calculation. This is important if
several calls to the Groebner package are done with the result of the
first being the input of the second call.

% Section 1.3
\subsection{The Buchberger Algorithm}
\index{Buchberger's Algorithm}
The Buchberger algorithm of the package is based on {\sc
Gebauer/M\"oller} \cite{Gebauer:88}. Most of the
improvements are documented in \cite{Melenk:88}.

% Chapter 2
\section{Loading of the Package}
The following command loads the Groebner basis package into
REDUCE (this syntax may vary according to implementation):
\begin{center}
load groebner;
\end{center}

The package contains various operators, and switches for control
over the reduction process. These are discussed in the following.

% Chapter 3
\section{The Basic Operators}

% Section 3.1
\subsection{Term Ordering Mode}

\begin{description}
\ttindex{TORDER}
\item [{\it TORDER}] $m$;

where $m$ is the name of a term ordering mode LEX, GRADLEX,
REV\-GRAD\-LEX (or another implemented mode).

TORDER sets the term ordering mode.  The default mode is LEX. The
previous ordering mode is returned.

\ttindex{GVARS}
\item[{\it GVARS}] ({\it\{exp$1$, exp$2$, $ \ldots$, exp$n$\}});

 where $\{exp1, exp2, \ldots , expn\}$ is a list of expressions or
equations.

GVARS extracts from the expressions $\{exp1, exp2, \ldots , expn\}$
the kernels, which can play the role of variables for a Groebner
calculation. \end{description}

% Section 3.2
\subsection{GROEBNER: Calculation of a Groebner Basis}
\begin{description}
\ttindex{GROEBNER}
\item[{\it GROEBNER}] $(\{exp1, exp2, \ldots , expm\}[,\{var1, var2,
\ldots , varn\}]); $

where $\{exp1, exp2, \ldots , expm\}$is a list of
expressions or equations, and \linebreak[4] $\{var1, var2, \ldots ,
varn\}$ is an optional list of variables.

GROEBNER calculates the Groebner basis of the given set of
expressions with respect to the given set of variables in the order
given.  If the variable list is omitted, the variables in the expression
list are used, ordered according to the system variable order. The
Groebner basis is a list of polynomials.

The Groebner basis $\{1\}$ means that the ideal generated by the
input polynomials is the whole polynomial ring, or equivalently, that
the input polynomials have no zeros in common.

As a side effect, the sequence of variables is stored as a REDUCE list
in the shared variable
\ttindex{gvarslast}
\begin{center}
gvarslast .
\end{center}

This is important if the variables are extracted automatically or if
the variables are reordered because of optimization and if the
sequences are needed afterwards for subsequent calculations (e.g.
for GREDUCE).
\end{description}

\example \index{GROEBNER package ! example}

${\it groebner}  (\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x - 3, $ \\
\hspace*{+1cm}$2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x + 3,$ \\
\hspace*{+1cm}$x**3*y + x**2*y + 3*x**3 + 2*x**2 \}); $

%{\small
\begin{verbatim}
               2
     {8*X - 2*Y  + 5*Y + 3,

         3      2
      2*Y  - 3*Y  - 16*Y + 21}
\end{verbatim}
%}
{\it gvarslast};  \\
%{\small
\begin{verbatim}
{X,Y}
\end{verbatim}
%}

This example used the default system variable ordering, which was
$\{x,y\}$. With the other variable ordering, a different basis results:

{\it groebner} $(\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x = 3,$ \\
\hspace*{+1cm} $2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x = -3,$ \\
\hspace*{+1cm} $x**3*y + x**2*y + 3*x**3 + 2*x**2 \}, \{y,x\})$;

%{\small
\begin{verbatim}
               2
     {2*Y + 2*X  - 3*X - 6,

         3      2
      2*X  - 5*X  - 5*X}
\end{verbatim}
%}

Another basis yet again results with a different term ordering:
\begin{center}
{\it torder revgradlex;}
\end{center}
LEX

{\it groebner} $(\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x = 3,$ \\
\hspace*{+1cm} $2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x = -3,$ \\
\hspace*{+1cm}  $x**3*y + x**2*y + 3*x**3 + 2*x**2 \}, \{y,x\}); $

%{\small
\begin{verbatim}
         2
     {2*X  - 3*X + 2*Y - 6,

      X*Y + X - Y + 3,

         2
      2*Y  - 8*X - 5*Y - 3}
\end{verbatim}
%}


The operation of GROEBNER can be controlled by the following
switches:
\begin{description}
\ttindex{GROEBOPT}
\item[GROEBOPT] -- If set ON, the sequence of variables is optimized
with respect to execution speed; the algorithm involved is described
in~\cite{Boege:86}; note that the final list of variables is available in
\ttindex{GVARSLAST}
GVARSLAST.

An explicitly declared dependency supersedes the
variable optimization. For example
\begin{center}
{\it depend} $a$, $x$, $y$;
\end{center}
guarantees that $a$ will be placed in front of $x$ and $y$. So
GROEBOPT can be used even in cases where elimination of variables is
desired.

By default GROEBOPT is off, conserving the original variable
sequence.

\ttindex{GROEBPREREDUCE}
\item[GROEBPREREDUCE] -- If set ON, GROEBNER tries to simplify the
input expressions: if the head term of an input expression is a
multiple of the head term of another expression, it can be reduced;
these reductions are done cyclicly as long as possible in order to
shorten the main part of the algorithm.

By default GROEBPREREDUCE is off;

\ttindex{GROEBFULLREDUCTION}
\item[GROEBFULLREDUCTION] -- If set off, the reduction steps during
the \linebreak[4] GROEBNER operation are limited to the pure head
term reduction; subsequent terms are reduced otherwise.

By default GROEBFULLREDUCTION is on.

\ttindex{GLTBASIS}
\item[GLTBASIS] -- If set on, the leading terms of the result basis are
extracted. They are collected in a basis of monomials, which is
available as value of the global variable with the name GLTB.
\end{description}
The following switches control the print output of GROEBNER; by
default all these switches are set OFF and nothing is printed.
\begin{description}
\ttindex{GROEBSTAT}
\item[GROEBSTAT] -- A summary of the computation is printed
including the computing time, the number of intermediate
$H$--polynomials and the counters for the hits of the criteria.

\ttindex{TRGROEB}
\item[TRGROEB] -- Includes GROEBSTAT and the printing of the
intermediate $H$-polynomials.

\ttindex{TRGROEBS}
\item[TRGROEBS] -- Includes TRGROEB and the printing of
intermediate $S$--poly\-nomials.

\ttindex{TRGROEB1}
\item[TRGROEB1] -- The internal pairlist is printed when modified.
\end{description}

%Section3.3new
\subsection{GZERODIM?: Test of $\dim = 0$}
\begin{description}
\ttindex{GZERODIM?}
\item[{\it GZERODIM}!?] $\left(bas[,\{var1,\ldots , varn\}]\right)$ \\
where {\it bas} is a Groebner basis in the current ordering with the
specified variables. The result is {\it NIL}, if {\it bas} is the
basis of an ideal of polynomials with more than finitely many common zeros.
If the ideal is zero dimensional, i. e. the polynomials of the ideal have only
finitely many zeros in common, the result is an integer $k$ which is the number
of these common zeros (counted with multiplicities).
\end{description}

 %Section 3.4new
\subsection{GLEXCONVERT: Conversion of an Arbitrary Groebner Basis
into a Lexical One}
\begin{description}
\ttindex{GLEXCONVERT}
\item[{\it GLEXCONVERT}] $ \left(\{exp,\ldots , expm\} \left[,\{var1
\ldots , varn\}\right]\left[,MAXDEG=mx\right]\right.$ \\
$\left.\left[,NEWVARS=\{nv1, \ldots , nvk\}\right]\right) $ \\
when $\{exp1, \ldots , expm\}$ is Groebner basis with variables
$\{var1, \ldots , varn\}$ in the current term order mode,
$mx$ is an integer,
$\{nv1, \ldots , nvk\}$ is a subset of the basis variables.
\end{description}

GLEXCONVERT converts a basis of a zero-dimensional ideal (finite number
of isolated solutions) from arbitrary ordering into a basis under {\it
lex} ordering. During the call of GLEXCONVERT the original ordering of
the input basis must be still active!

NEWVARS defines the new variable sequence. If omitted, the
original variable sequence is used. If only a subset of variables is
specified here, the partial ideal basis is evaluated. For the
calculation of a univariate polynomial, NEW\-VARS should be a list
with one element.

MAXDEG is an upper limit for the degrees. The algorithm stops with
an error message, if this limit is reached.

A warning occurs, if the ideal is not zero dimensional.

GLEXCONVERT is an implementation of the FLGM algorithm by
\linebreak[4] {\sc Faug{\`e}re}, {\sc Gianni}, {\sc Lazard} and {\sc
Mora} \cite{Faugere:89}. In general, the calculation of a Groebner basis
with a graded ordering and subsequent conversion to {\it lex} is
faster than a direct {\it lex} calculation. Additionally, GLEXCONVERT
can be used to transform a {\it lex} basis into one with different
variable sequence, and it supports the calculation of a univariate
polynomial. If the latter exists, the algorithm is even applicable in
the non zero-dimensional case, if such polynomial exists.

\example \index{GROEBNER package ! example}

{\it torder gradlex;}

$ g  :=  groebner  (\{ f1 := 45*p + 35*s -165*b -36,$ \\
\hspace*{+1cm} $35*p + 40*z + 25*t - 27*s, 15*w + 25*p*s +30*z -18*t $ \\
\hspace*{+1cm} $-165*b**2, -9*w + 15*p*t  + 20*z*s, $ \\
\hspace*{+1cm} $ w*p + 2*z*t - 11*b**3, 99*w - 11*s*b +3*b**2, $ \\
\hspace*{+1cm} $ b**2 + 33/50*b + 2673/10000\}, \{w,p,z,t,s,b\});$

\begin{verbatim}
  G := {60000*W + 9500*B + 3969,

      1800*P - 3100*B - 1377,

      18000*Z + 24500*B + 10287,

      750*T - 1850*B + 81,

      200*S - 500*B - 9,
             2
      10000*B  + 6600*B + 2673}
\end{verbatim}

{\it
glexconvert}$\left(g,\{w,p,z,t,s,b\},maxdeg=5,newvars=\{w\}\right)$
\begin{verbatim}
               2
    100000000*W  + 2780000*W + 416421
\end{verbatim}

{\it glexconvert}$\left(g,\{w,p,z,t,s,b\},maxdeg=5,
newvars=\{p\}\right),$
\begin{verbatim}
          2
    6000*P  - 2360*P + 3051

\end{verbatim}

% Section 3.4
\subsection{GROEBNERF: Factorizing Groebner Bases}

% Subsection 3.4.1
\subsubsection{Background}
If Groebner bases are computed in order to solve systems of
equations or to find the common roots of systems of polynomials,
the factorizing version of the Buchberger algorithm can be used.
The theoretical background is simple: if a polynomial $p$ can be
represented as a product of two (or more) polynomials, e.g. $h= f*g$,
then $h$ vanishes if and only if one of the factors vanishes. So if
during the calculation of a Groebner basis $h$ of the above form is
detected, the whole problem can be split into two (or more)
disjoint branches. Each of the branches is simpler than the complete
problem; this saves computing time and space. The result of this
type of computation is a list of (partial) Groebner bases; the
solution set of the original problem is the union of the solutions of
the partial problems, ignoring the multiplicity of an individual
solution. If a branch results in a basis $\{1\}$, then there is no
common zero, i.e. no additional solution for the original problem,
contributed by this branch.

% Subsection 3.4.2
\subsubsection{GROEBNERF Call}
\ttindex{GROEBNERF}
The syntax of GROEBNERF is the same as for GROEBNER.
\[
\mbox{\it GROEBNERF}(\{exp1, exp2, \ldots , expm\}[,\{var1, var2,
\ldots , varn\}]);
\]
where $\{exp1, exp2, \ldots , expm\} $ is a list of expressions or
equations, \linebreak[4] and $\{var1, var2,\ldots , varn\}$ is an
optional list of variables.

GROEBNERF tries to separate polynomials into individual factors and
to branch the computation in a recursive manner (factorization tree).
The result is a list of partial Groebner bases. If no factorization can
be found or if all branches but one lead to the trivial basis $\{1\}$,
the result has only one basis; nevertheless it is a list of lists of
polynomials. If no solution is found, the result will be $\{\{1\}\}$.
Multiplicities (one factor with a higher power, the same partial basis
twice) are deleted as early as possible in order to speed up the
calculation. The factorizing is controlled by some switches.

As a side effect, the sequence of variables is stored as REDUCE list in
the shared variable
\begin{center}
gvarslast .
\end{center}
If GLTBASIS is on, a corresponding list of leading term bases is
also produced and is available in the variable GLTB.

\example \index{GROEBNER package ! example}

{\it groebnerf} $(\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x = 3,$  \\
\hspace*{+1cm} $ 2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x = -3, $\\
\hspace*{+1cm} $ x**3*y + x**2*y + 3*x**3 + 2*x**2 \}, \{y,x\});$

%{\small
\begin{verbatim}
       {{Y - 3,X},

                      2
    {2*Y + 2*X - 1,2*X  - 5*X - 5}}
\end{verbatim}
%}

It is obvious here that the solutions of the equations can be read
off immediately.

All switches from GROEBNER are valid for GROEBNERF as well:
\ttindex{GROEBOPT} \ttindex{GROEBPREREDUCE} \ttindex{GLTBASIS}
\ttindex{BROEBFULLREDUCTION} \ttindex{GROEBSTAT} \ttindex{TRGROEB}
\ttindex{TRGROEBS} \ttindex{TRGROEB1}
\begin{center}
\begin{tabular}{l}
GROEBOPT \\
GROEBPREREDUCE \\
GLTBASIS \\
GROEBFULLREDUCTION \\
GROEBSTAT \\
TRGROEB \\
TRGROEBS \\
TRGROEB1
\end{tabular}
\end{center}

\subsubsection*{Additional switches for GROEBNERF:}
\begin{description}
\ttindex{GROEBRES}
\item[GROEBRES] -- If ON, a resultant is calculated under certain
circumstances (one bivariate $H$--polynomial is followed by another
one). This shortens the calculation sometimes.

By default GROEBRES is off.

\ttindex{TRGROEBR}
\item[TRGROEBR] -- All intermediate partial basis are printed when
detected.

By default TRGROEBR is off.
\end{description}
{\bf GROEBMONFAC  GROEBRESMAX  GROEBRESTRICTION} \\
\hspace*{.5cm} These variables are described in the following
paragraphs.

% Subsection 3.4.3
\subsubsection{Suppression of Monomial Factors}
The factorization in GROEBNERF is controlled by the following
\ttindex{GROEBMONFAC}
switches and variables.  The variable GROEBMONFAC is connected to
the handling of ``monomial factors''.  A monomial factor is a product
of variable powers as a factor, e.g. $ x**2*y$  in  $x**3*y -
2*x**2*y**2$.  A monomial factor represents a solution of the type
``$ x = 0$  or  $y = 0$'' with a certain multiplicity.  With
GROEB\-NERF \ttindex{GROEBNERF}
the multiplicity of monomial factors is lowered to the value of the
shared variable
\ttindex{GROEBMONFAC}
\begin{center}
GROEBMONFAC
\end{center}
which by default is 1 (= monomial factors remain present, but their
multiplicity is brought down). With
\begin{center}
GROEBMONFAC := 0
\end{center}
the monomial factors are suppressed completely.

\example\index{GROEBNER package ! example}

Equations extracted from a differential equation system for a
chemical reaction system for pyridine, in: {\sc Ebert/Deuflhard/Jaeger}
(1981) \cite{Ebert:81}).

\[
\begin{array}{lll}
f1 & := & -1*A + p9*B; \\
f2 & := & p1*A - p2*B - p3*C*B + p7*D - p9*B + p10*D*F; \\
f3 & := & p2*B - p3*B*C - 2*p4*C*C - p6*C + p8*E \\
& &  \;\;+ p10*D*F + 2*p11*E*F;\\
f4 & := & p3*B*C - p5*D - p7*D - p10*D*F; \\
f5 & := & p4*C*C + p5*D -p8*E - p11*E*F; \\
f6 & := & p3*B*C + p4*C*C + p6*C - p10*D*F - p11*E*F; \\
f7 & := & p6*C + p7*D + p8*E; \\
\multicolumn{3}{l}{\mbox{\it polys}\; :=\;\{f1,f2,f3,f4,f5,f6,f7\} \$
 \,vars\; :
=\;
\{A,B,C,D,E,F\}\$} \\
\multicolumn{3}{l}{\mbox{\it groebmonfac}\; :=\; 1;  \%\mbox{\it
allowing monomial factors with exponent $1$}} \\
\multicolumn{3}{l}{\mbox{\it res} \;:=\; \mbox{\it  groebnerf
$($polys,vars$)$};}
\end{array}
\]

%{\small
\begin{verbatim}
   RES := {{A,E,B,D,C},

       {A, - E*P8 - C*P6,B,F*P6*P11 + C*P4*P8 + P6*P8,D}}

% the above result has two partial bases; they have in
% common that A,B and D are forced to zero
\end{verbatim}
%}

groebmonfac := 0; \% now suppressing monomial factors at all
\[
\mbox{\it res} := \mbox{\it groebnerf }(\mbox{\it polys,vars});
\]
%{\small
\begin{verbatim}
   RES := {{1}};

   % with this configuration there is no solution at all. (The
   % system has no solution with only nonzero variable values)
\end{verbatim}
%}

% Subsection 3.4.4
\subsubsection{Limitation on the Number of Results}
The shared variable
\ttindex{GROEBRESMAX}
\begin{center}
GROEBRESMAX
\end{center}
controls the number of partial results. Its default value is 300. If
groebresmax partial results are calculated, the calculation is
terminated.

% Subsection 3.4.5
\subsubsection{Restriction to Real Nonnegative Solutions}
In some applications only nonnegative values or positive definite
values for the variables are interesting as solutions for a given set
of equations. If a polynomial has no (strictly) positive zero, then
every system containing it has no nonnegative or strictly positive
solution. Therefore, the Buchberger algorithm tests the coefficients of
the polynomials for equal sign if requested. For example, in $13*x +
15*y*z $ can be zero with real nonnegative values for $x, y$ and $z$
only if $x=0$ and $y=0$ or $ z=0$; this is a sort of ``factorization by
restriction''. A polynomial $13*x + 15*y*z + 20$ never can vanish
with nonnegative real variable values. By setting the shared variable
\ttindex{GROEBRESTRICTION}
\begin{center} GROEBRESTRICTION \end{center}
GROEBNERF is informed of the type of restriction the user wants to
impose on the solutions:
\begin{center}
\begin{tabular}{l}
{\it GROEBRESTRICTION:=NONEGATIVE;} \\
\hspace*{+.5cm} only nonnegative real solutions are of
interest\vspace*{4mm} \\
{\it GROEBRESTRICTION:=POSITIVE;} \\
\hspace*{+.5cm}only nonnegative and nonzero solutions are of
interest.
\end{tabular}
\end{center}

If GROEBNERF detects a polynomial which formally conflicts with the
restriction, it either splits the calculation into separate branches, or,
if a violation of the restriction is determined, it cancels the actual
calculation branch.

% Section 3.6
\subsection{GREDUCE, PREDUCE: Reduction of Polynomials}

% Subsection 3.6.1
\subsubsection{Background} \label{GROEBNER:background}
Reduction of a polynomial ``p'' modulo a given sets of polynomials
``B'' is done by the reduction algorithm incorporated in the
Buchberger algorithm. Informally it can be described for
polynomials over a field as follows:
\begin{center}
\begin{tabular}{l}
loop1: \hspace*{2mm}\% head term elimination \\
\hspace*{-1cm} if there is one polynomial $b$ in $B$ such that the
leading \\ term of $p$ is a multiple of the leading term of $p$ do \\
$p := p - lt(p)/lt(b) * b$  (the leading term vanishes)\\
\hspace*{-1cm} do this loop as long as possible; \\
loop2: \hspace*{2mm} \% elimination of subsequent terms \\
\hspace*{-1cm} for each term $s$ in $p$ do \\
if there is one polynomial $b$ in $B$ such that $s$ is a\\
multiple of the leading term of $p$ do \\
$p := p - s/lt(b) * b$ (the term $s$ vanishes) \\
\hspace*{-1cm}do this loop as long as possible;
\end{tabular}
\end{center}

If the coefficients are taken from a ring without zero divisors we
cannot divide by each possible number like in the field case. But
using that in the field case  $c*p $ is reduced to  $c*q $, if $ p $
is reduced to $ q $, for arbitrary numbers $ c $,  the reduction for
the ring case uses the least $ c $ which makes the (field) reduction
for $ c*p $ integer. The result of this reduction is returned as
(ring) reduction of $ p $ eventually after removing the content, i.e.
the greatest common divisor of the coefficients. The result of this
type of reduction is also called a pseudo reduction of $ p $.


% Subsection 3.5.2
\subsubsection{Reduction via Groebner Basis Calculation}
\ttindex{GREDUCE}
\[
\mbox{\it  GREDUCE}(exp, \{exp1, exp2, \ldots , expm\}[,\{var1, var2,
\ldots , varn\}]);
\]
where {\it exp} is an expression, and $\{exp1, exp2,\ldots , expm\}$ is
a list of any number of expressions or equations and $\{var1, var2,$
$\ldots , varn\}$ is an optional list of variables.

GREDUCE first converts the list of expressions $\{exp1, \ldots ,
expn\}$ to a Groeb\-ner basis, and then reduces the given expression
modulo that basis.  An error results if the list of expressions is
inconsistent. The returned value is an expression representing the
reduced polynomial. As a side effect, GREDUCE sets the variable {\it
gvarslast} in the same manner as GROEBNER does.

\example\index{GROEBNER package ! example}

(Note: This example assumes a new session, and not the above
settings.)

{\it greduce} $( 5*y**2 + 2*x**2*y + 5/2*x*y + 3/2*y$\\
\hspace*{+1cm} $ + 8*x**2 + 3/2*x - 9/2, $\\
\hspace*{+1cm} $\{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x - 3,$ \\
\hspace*{+1cm} $ 2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x + 3,$ \\
\hspace*{+1cm} $ x**3*y + x**2*y + 3*x**3 + 2*x**2 \});$
%{\small
\begin{verbatim}
      2
     Y
\end{verbatim}
%}
% Subsection 3.5.3
\subsubsection{Reduction with Respect to Arbitrary Polynomials}
\ttindex{PREDUCE}
\[
 PREDUCE(exp, \{exp1, exp2,\ldots , expm\}[,\{var1, var2,\ldots ,
varn\}]);
\]
where $ exp $  is an expression, and $\{exp1, exp2, \ldots ,
expm \}$ is a list of any number of expressions or equations and
$\{var1, var2, \ldots , varn\}$ is an optional list of variables.

PREDUCE reduces the given expression modulo the set $\{exp1,
\ldots , expm\}$. If this set is a Groebner basis, the obtained reduced
expression is uniquely determined. If not, then it depends on the
subsequence of the single reduction steps
(see~\ref{GROEBNER:background}). PREDUCE does not check, whether
$\{exp1, exp2, \ldots , expm\}$ is a Groebner basis in the actual
order. Therefore, if the expressions are a Groebner basis calculated
earlier with a variable sequence given explicitly or modified by
optimization, the sequence of variables should be given as a parameter
explicitly.

\example (PREDUCE with an arbitrary set of polynomials):
\index{GROEBNER package ! example}

{\it preduce} $ ( 5*y**2 + 2*x**2*y + 5/2*x*y + 3/2*y + 8*x**2 +
3/2*x - 9/2, $ \\ \hspace*{+1cm} $ \{ 3*x**2*y + 2*x*y + y + 9*x**2 +
5*x - 3, $ \\ \hspace*{+1cm} $ 2*x**3*y - x*y - y + 6*x**3 - 2*x**2 -
3*x + 3, $ \\ \hspace*{+1cm} $  x**3*y + x**2*y + 3*x**3 + 2*x**2 \});
$

%{\small
\begin{verbatim}
          2                      2
      12*X  + 7*X*Y - 11*X + 30*Y  + 5*Y - 15
\end{verbatim}
%}
\example (PREDUCE called with a Groebner basis):
\index{GROEBNER package ! example}

\[
\begin{array}{ll}
 gb := groebner & ( \{ 3*x**2*y + 2*x*y + y + 9*x**2 + 5*x - 3, \\
& 2*x**3*y - x*y - y + 6*x**3 - 2*x**2 - 3*x + 3, \\
& x**3*y + x**2*y + 3*x**3 + 2*x**2 \}) \\
\multicolumn{2}{l}{preduce (5*y**2 + 2*x**2*y + 5/2*x*y + 3/2*y} \\
\multicolumn{2}{l}{\hspace*{+1cm}+ 8*x**2 + 3/2*x - 9/2, gb);}
\end{array}
\]
%{\small
\begin{verbatim}
      2
     Y
\end{verbatim}
%}

% Subsection 3.5.4
\subsubsection{Reduction Tree}
In some case not only the results produced by GREDUCE and
PREDUCE are of interest, but the reduction process is of some value
too. If the switch
\ttindex{GROEBPROT}
\begin{center}
GROEBPROT
\end{center}
is set on, GREDUCE and PREDUCE produce as a side effect a trace of
their work as a REDUCE list of equations in the shared variable
\ttindex{GROEBPROTFILE}
\begin{center}
GROEBPROTFILE.
\end{center}
Its value is a list of equations with a variable ``candidate'' playing
the role of the object to be reduced. The polynomials are cited as
$``poly1'', ``poly2'', \ldots\;.$ If read as assignments, these equations
form a program which leads from the reduction input to its result.
Note that, due to the pseudo reduction with a ring as the coefficient
domain, the input coefficients may be changed by global factors.

\example \index{GROEBNER package ! example}

{\it on groebprot} \$ \\
{\it preduce} $ (5*y**2 + 2*x**2*y + 5/2*x*y + 3/2*y + 8*x**2 $ \\
\hspace*{+1cm} $+ 3/2*x - 9/2, gb);$
\begin{verbatim}
      2
     Y
\end{verbatim}
{\it groebprotfile;}
\begin{verbatim}
                  2         2                     2
    {CANDIDATE=4*X *Y + 16*X  + 5*X*Y + 3*X + 10*Y  + 3*Y - 9,

              2
     POLY1=8*X - 2*Y  + 5*Y + 3,

              3      2
     POLY2=2*Y  - 3*Y  - 16*Y + 21,
     CANDIDATE=2*CANDIDATE,
     CANDIDATE= - X*Y*POLY1 + CANDIDATE,
     CANDIDATE= - 4*X*POLY1 + CANDIDATE,
     CANDIDATE=4*CANDIDATE,

                   3
     CANDIDATE= - Y *POLY1 + CANDIDATE,
     CANDIDATE=2*CANDIDATE,

                     2
     CANDIDATE= - 3*Y *POLY1 + CANDIDATE,
     CANDIDATE=13*Y*POLY1 + CANDIDATE,
     CANDIDATE=CANDIDATE + 6*POLY1,

                     2
     CANDIDATE= - 2*Y *POLY2 + CANDIDATE,
     CANDIDATE= - Y*POLY2 + CANDIDATE,
     CANDIDATE=CANDIDATE + 6*POLY2}

 \end{verbatim}
This means
\begin{eqnarray*}
\lefteqn{
16 (5 y^2 + 2 x^2 y + \frac{5}{2} x y + \frac{3}{2} y + 8 x^2+ \frac{3}{2} x -
\frac{9}{2})=} \\ & &
(-8 x y -32 x -2 y^3 -3 y^2 + 13 y + 6) \mbox{POLY1} \\
& & \; + (-2 y^2 -2 y + 6) \mbox{POLY2  } \; + y^2.
\end{eqnarray*}



% new 3.6/Sept 21

\subsection{Tracing with GROEBNERT and PREDUCET}
Given a set of polynomials $\{f_1,\ldots ,f_k\}$ and their Groebner
basis $\{g_1,\ldots ,g_l\}$, it is well known that there are matrices of
polynomials $C_{ij}$ and $D_{ji}$ such that
\[
f_i = \displaystyle{\sum\limits_j} C_{ij} g_j \;\mbox{  and  } g_j =
\displaystyle{\sum\limits_i} D_{ji} f_i
\]
and these relations are needed explicitly sometimes.
In {\sc Buchberger} \cite{Buchberger:85}, such cases are described in the
context of linear polynomial equations. The standard technique for
computing the above formulae is to perform
Groebner reductions, keeping track of the
computation in terms of the input data. In the current package such
calculations are performed with (an internally hidden) cofactor
technique: the user has to assign unique names to the input
expressions and the  arithmetic combinations are done with the
expressions and with their names simultaneously. So the result is
accompanied by an expression which relates it algebraically to the
input values.

\ttindex{GROEBNERT} \ttindex{PREDUCET}
There are two complementary operators with this feature: GROEBNERT
and PREDUCET; functionally they correspond to GROEBNER and PREDUCE.
However, the sets of expressions here {\it {\bf must be}} equations
with unique single identifiers on their left side and the {\it lhs} are
interpreted as names of the expressions. Their results are
sets of equations (GROEBNERT) or equations (PREDUCET), where
a {\it lhs} is the computed value, while the {\it rhs} is its equivalent
in terms of the input names.

\example \index{GROEBNER package ! example}

We calculate the Groebner basis for an ellipse (named ``$p1$'' ) and a
line (named ``$p2$'' ); $p2$ is member of the basis immediately and so
the corresponding first result element is of a very simple form; the
second member is a combination of $p1$ and $p2$ as shown on the
{\it rhs} of this equation:

\noindent{\it
gb1:=groebnert$({p1=2*x**2+4*y**2-100,p2=2*x-y+1})$;}
\begin{verbatim}   GB1 := {2*X - Y + 1=P2,
           2
        9*Y  - 2*Y - 199= - 2*X*P2 - Y*P2 + 2*P1 + P2}
\end{verbatim}

\example \index{GROEBNER package ! example}

We want to reduce the polynomial \verb+ x**2+ {\it  wrt}
the above Groebner basis and need knowledge about the reduction
formula. We therefore extract the basis polynomials from $GB1$,
assign unique names to them (here $G1$, $G2$) and call PREDUCET.
The polynomial to be reduced here is introduced with the name $Q$,
which then appears on the {\it rhs} of the result. If the name for the
polynomial is omitted, its formal value is used on the right side too.

\noindent{\it gb$2$ := for $k := 1:$length gb$1$ collect
$\Bigl(mkid(g,k) = lhs$ part$(gb1,k)\Bigr)$;}
\begin{verbatim}
                             2
GB2 := {G1=2*X - Y + 1,G2=9*Y  - 2*Y - 199}
\end{verbatim}

\noindent{\it preducet$(q=x**2,gb2)$;}
\begin{verbatim}
 - 16*Y + 208= - 18*X*G1 - 9*Y*G1 + 36*Q + 9*G1 - G2
\end{verbatim}

\noindent{\it preducet$(x**2,gb2)$;}
\begin{verbatim}
                  2
 - 16*Y + 208=36*X  - 18*X*G1 - 9*Y*G1 + 9*G1 - G2

\end{verbatim}

In both cases the output means
\[
x^2 = (\frac{1}{2} x + \frac{1}{4} y - \frac{1}{4}) G1
 + \frac{1}{36} G2 + (-\frac{4}{9} y + \frac{52}{9}).
\]


\example \index{GROEBNER package ! example}

If we reduce a polynomial which is member of the ideal, we
consequently get a result with {\it lhs} zero:

\noindent{\it preducet$(q=2*x**2+4*y**2-100,gb2)$; }
\begin{verbatim}
0= - 2*X*G1 - Y*G1 + 2*Q + G1 - G2
\end{verbatim}

This means
\[ Q = ( x + \frac{1}{2} y - \frac{1}{2}) G1 + \frac{1}{2} G2.
\]

With these operators the matrices $C_{ij}$ and $D_{ji}$ are available
implicitly, $D_{ji}$ as side effect of GROEBNERT, $C_{ij}$ by {\it calls}
of PREDUCET of $f_i$ {\it wrt} $\{g_j\}$. The latter by definition will
have the {\it lhs} zero and a {\it rhs} with linear $f_i$.

If $\{1\}$ is the Groebner basis, the GROEBNERT calculation gives
a ``proof'', showing,  how  $1$ can be computed as combination of the
input polynomials.

\paragraph{Remark:} Compared to the non-tracing algorithms, these
operators are much more time consuming. So they are applicable
only on small sized problems.
% *** SO BESSER ??

%Section 3.8
\subsection{GROEBNERM: Groebner Bases for Modules}

Polynomial r-tuples
 $(p1,\ldots,pr) $ can be added componentwise
and multiplied by $ p*(p1,\ldots,pr) := (p*p1,\ldots,p*pr) $
for arbitrary polynomials $p.$  Given finitely many of
such polynomial r-tuples $P1:=(p11,\ldots,p1r),\ldots,Pm:=(pm1,\ldots,pmr),$
the polynomial module
\[ M := \{ g1*P1 + \cdots + gm*Pm \mid g1,\ldots,gm \mbox{ polynomials} \}
\]
possesses a Groebner basis for arbitrary admissible term orderings and
arbitrary weights. \ttindex{GROEBNERM}
The operator GROEBNERM calculates the Groebner basis of the module
\[
\mbox{GROEBNERM } \bigl(\{expr1, \ldots , exprm\} [,\{var1, \ldots ,
varn\} [, \{w_1, \ldots , w_r] ] \bigr)
\]
where
\begin{quote}
$\{expr1, \ldots , exprm\}$  are r-tuples of polynomials written as list,
\linebreak[4]$\{var1, \ldots , varn\}$ is an optional list of variables and
$\{w_1, \ldots , w_r\}$ is a list of positive integers $<1000$.
\end{quote}
Alternatively the {\it expr} can be expression of the form
\[
p= \{pol1, \ldots , polr\}
\]
with a ``name''--variable as with GROEBNERT. In this case, a tracing
Groebner basis calculation is performed. The $\{w1, \ldots , wr\}$ are
weights assigned to the components of the vector space, if a graduated
ordering is active. If omitted, all components are weighted with 1.

\example \index{GROEBNER package ! example}

\[
\begin{array}{lll}
B & := & \{\{  1 ,  0  ,  0  ,  0  ,  0 \}, \\
& & \;\;\{  0 ,  0  ,  0  ,  0  , -1\}, \\
& & \;\;\{  0 ,  0  ,  0  ,  1  ,  0\}, \\
& & \;\;\{  0 ,  0  , -1  ,  0  , x^2\}\}\$ \vspace*{4mm} \\
D & := & \{\{ -x ,  y  ,  1  ,  0  ,  0 \}, \\
& &\;\;\{  0 ,5x^2 ,  y  ,  1  ,  0 \}, \\
& &\;\;\{  0 ,  0  ,4x^2 , 5y  , y\}, \\
& &\;\;\{  0 ,  5  ,  0  , x^2 ,  y \}\};
\end{array}
\]
groebnerM (append$(b,d)\, ,\;\{x,y\}\,, \;\{4,4,5,6,7\}$);

\begin{verbatim}

         2
{{0,5,0,X ,Y},

            2
 {0,0,-1,0,X },

 { - X,Y,1,0,0},

 {1,0,0,0,0},

 {0,1,0,0,0},

 {0,0,1,0,0},

 {0,0,0,1,0},

 {0,0,0,0,-1}}

\end{verbatim}
\[
\begin{array}{lllll}
\mbox{Btagged} & := & \{t1 & = & \{  1 ,  0  ,  0  ,  0  ,  0 \}, \\
& & \;\; t2 & = & \{  0 ,  0  ,  0  ,  0  , -1 \}, \\
& & \;\; t3 & = & \{  0 ,  0  ,  0  ,  1  ,  0 \}, \\
& & \;\; t4 & = & \{  0 ,  0  , -1  ,  0  , x^2 \}\}\$
\end{array}
\]

\noindent groebnerM (append(btagged,d) , $\{x,y\} \,, \;\{4,4,5,6,7\}$);

\begin{verbatim}
         2
{{0,5,0,X ,Y},

            2
 {0,0,-1,0,X }=T4,

 { - X,Y,1,0,0},

 {1,0,0,0,0}=T1,

                  2
               - X *T3 + Y*T2
 {0,1,0,0,0}=-----------------,
                     5

                 2
 {0,0,1,0,0}= - X *T2 - T4,

 {0,0,0,1,0}=T3,

 {0,0,0,0,-1}=T2}

\end{verbatim}

%Section 3.9
\subsection{Additional Orderings}
Besides the basic orderings, there are ordering options which are used for
special purposes.
%Section 3.7.1
\subsubsection{Separating the Variables into Groups }
\index{grouped ordering}
It is often desirable to separate variables
and formal parameters in a system of polynomials.
This can be done with a {\it lex} Groebner
basis.  That however may be hard to compute as it does more
separation than necessary. The following orderings group the
variables into two (or more) sets, where inside each set a classical
ordering acts, while the sets are handled via their total degrees,
which are compared in elimination style. So the Groebner basis will
eliminate the members of the first set, if algebraically possible. {\it
Torder} here gets an additional parameter which describe the
grouping \ttindex{TORDER}
\begin{center}{\it
\begin{tabular}{l}
TORDER gradlexgradlex, n; \\
TORDER gradlexrevgradlex, n; \\
TORDER lexgradlex, n; \\
TORDER lexrevgradlex, n;
\end{tabular}}
\end{center}
Here the integer $n$ is the number of variables in the first group
and the names combine the local ordering for the first and second
group, e.g.
\begin{center}
\begin{tabular}{llll}
\multicolumn{4}{l}{{\it lexgradlex}, 3 for $\{x_1,x_2,x_3,x_4,x_5\}$:} \\
\multicolumn{4}{l}{$x_1^{i_1}\ldots x_5^{i_5} \gg x_1^{j_1}\ldots
x_5^{j_5}$} \\
if & & & $(i_1,i_2,i_3) \gg_{lex}(j_1,j_2,j_3)$ \\
& or & & $(i_1,i_2,i_3) = (j_1,j_2,j_3)$ \\
& & and & $(i_4,i_5) \gg_{gradlex}(j_4,j_5)$
\end{tabular}
\end{center}
Note that in the second place there is no {\it lex} ordering available;
that would not make sense.

\subsubsection{Weighted Ordering}
\ttindex{TORDER} \index{weighted ordering}
The statement
\begin{center}
\begin{tabular}{cl}
{\it TORDER} & weighted, $n_1,n_2,n_3 \ldots$ ; \\
or \\
{\it TORDER} & weighted, $\{n_1,n_2,\ldots\}$
\end{tabular}
\end{center}
establishes a graduated ordering, where the exponents first are
multiplied by the given weights. If there are less weight values than
variables, the weight 1 is added automatically.

\subsubsection{Arbitrary Ordering}
\index{arbitrary ordering} \ttindex{TORDER}
If none of the given orderings fulfills the requirements, the user can
supply a private ordering in form of a procedure:
\begin{center}
{\it TORDER} private, $\langle${\it name}$\rangle$;
\end{center}
where $\langle${\it name}$\rangle$ is the name of  a procedure. This
procedure must have the following properties:
\begin{itemize}
\item written in symbolic mode (or LISP),
\item accept 2 parameters $v_1$, $v_2$, which are vectors with the
exponents to be compared beginning with index 1
\item return
\[
\begin{array}{rll}
-1 & \mbox{ if } & v_1 \ll v_2 \\
 0 & \mbox{ if } & v_1 = v_2 \\
+1 & \mbox{ if } & v_1 \gg v_2
\end{array}
\]
\end{itemize}
This procedure should be compiled because it is called very frequently.
Operators for fast vector access and fast integer arithmetic should be
used where available. A simple specimen for this procedure is:
 \begin{center}
\begin{tabular}{l}
\hspace*{-1cm}symbolic procedure specimen $(v_1,v_2)$;
\vspace*{1mm}\\
\% simulating a 2 dim {\it lex} ordering. \\
if $getv(v1,1) < getv(v2,1)$ then $-1$ else \\
if $getv(v1,1) > getv(v2,1)$ then $1$ else \\
if $getv(v1,2) < getv(v2,2)$ then $-1$ else \\
if $getv(v1,2) > getv(v2,2)$ then $1$ else 0; \vspace*{2mm} \\
\hspace*{-1cm}torder private, specimen;
\end{tabular}
\end{center}


where e.g. with PSL-based REDUCE {\it getv} should be replaced by {\it
igetv} and $\#>$ resp $\#<$ should be used instead of the generic
comparisons.

During initialization, the Groebner package tests if the procedure
represents an admissible ordering. However, this test cannot be
complete and so the responsibility remains with the user.

% Chapter 4
\section{Ideal Decomposition \& Equation System Solving}
Based on the elementary Groebner operations, the Groebner package offers
additional operators, which allow the decomposition of an ideal or of a
system of equations down to the individual solutions.
% Section 4.1
\subsection{Solutions Based on Lex Type Groebner Bases}
% Subsection 4.1.1
\subsubsection{GROESOLVE: Solution of a Set of Polynomial Equations}
\ttindex{GROESOLVE} \ttindex{GROEBNERF}
The GROESOLVE operator incorporates a macro algorithm;
lexical Groebner bases are computed by GROEBNERF and decomposed
into simpler ones by ideal decomposition techniques; if algebraically
possible, the problem is reduced to univariate polynomials which are
solved by SOLVE; if ROUNDED is on, numerical approximations are
computed for the roots of the univariate polynomials.
\[
 GROESOLVE(\{exp1, exp2, \ldots , expm\}[,\{var1, var2, \ldots ,
varn\}]); \]
where $\{exp1, exp2,\ldots , expm\}$ is a list of any number of
expressions or equations, $\{var1, var2, \ldots , varn\}$ is an
optional list of variables.

The result is a set of subsets. The subsets contain the solutions of the
polynomial equations. If there are only finitely many solutions,
then each subset is a set of expressions of triangular type
$\{exp1, exp2,\ldots , expn\},$ where $exp1$ depends only on
$var1,$ $exp2$ depends only on $var1$ and $var2$ etc. until $expn$ which
depends on $var1,\ldots,varn.$ This allows a successive determination of
the solution components. If there are infinitely many solutions,
some subsets consist in less than $n$ expressions. By considering some
of the variables as ``free parameters'',  these subsets are usually again of
triangular type.


\example (intersections of a line with a circle):
\index{GROEBNER package ! example}

\[
GROESOLVE(\{x**2 - y**2 - a, p*x+q*y+s\},\{x,y\});
\]
%{\small
\begin{verbatim}
                   2      2    2             2    2
   {{X=(SQRT( - A*P  + A*Q  + S )*Q - P*S)/(P  - Q ),
                      2      2    2             2    2
     Y= - (SQRT( - A*P  + A*Q  + S )*P - Q*S)/(P  - Q )},
                      2      2    2             2    2
    {X= - (SQRT( - A*P  + A*Q  + S )*Q + P*S)/(P  - Q ),
                   2      2    2             2    2
     Y=(SQRT( - A*P  + A*Q  + S )*P + Q*S)/(P  - Q )}}
\end{verbatim}
%}
% Subsection 4.1.2
\subsubsection{GROEPOSTPROC: Postprocessing of a Groebner Basis}
\ttindex{GROEPOSTPROC}
In many cases, it is difficult to do the general Groebner processing.
If a Groebner basis with a {\it lex} ordering is calculated already (e.g.
by very individual parameter settings), the solutions can be derived
from it by a call to GROEPOSTPROC. GROESOLVE is functionally
equivalent to a call to GROEBNERF and subsequent calls to
GROEPOSTPROC for each partial basis.
\[
 GROEPOSTPROC(\{exp1, exp2, \ldots , expm\}[,\{var1, var2, \ldots ,
varn\}]);
\]
where $\{exp1, exp2, \ldots , expm\}$ is a list of any number of
expressions, \linebreak[4] $\{var1, var2, \ldots ,$ $ varn\}$ is an
optional list of variables. The expressions must be a {\it lex} Groebner
basis with the given variables; the ordering must be still active.

The result is the same as with GROESOLVE.

\begin{verbatim}
groepostproc({x3**2 + x3 + x2 - 1,
              x2*x3 + x1*x3 + x3 + x1*x2 + x1 + 2,
              x2**2 + 2*x2 - 1,
              x1**2 - 2},{x3,x2,x1});

{{X3= - SQRT(2),

  X2=SQRT(2) - 1,

  X1=SQRT(2)},

 {X3=SQRT(2),

  X2= - (SQRT(2) + 1),

  X1= - SQRT(2)},

      SQRT(4*SQRT(2) + 9) - 1
 {X3=-------------------------,
                 2

  X2= - (SQRT(2) + 1),

  X1=SQRT(2)},

       - (SQRT(4*SQRT(2) + 9) + 1)
 {X3=------------------------------,
                   2

  X2= - (SQRT(2) + 1),

  X1=SQRT(2)},

      SQRT( - 4*SQRT(2) + 9) - 1
 {X3=----------------------------,
                  2

  X2=SQRT(2) - 1,

  X1= - SQRT(2)},

\end{verbatim}

\newpage  %JBM
\begin{verbatim}
       - (SQRT( - 4*SQRT(2) + 9) + 1)
 {X3=---------------------------------,
                     2

  X2=SQRT(2) - 1,

  X1= - SQRT(2)}}
\end{verbatim}

% Subsection 4.1.3
\subsubsection{IDEALQUOTIENT: Quotient of an Ideal and an Expression}
\ttindex{IDEALQUOTIENT} \index{ideal quotient} 
Let $I$ be an ideal and $f$ be a polynomial in the same
variables. Then the algebraic quotient is defined by
\[
I:f = \{ p \;| \; p * f \;\mbox{    member of }\; I\}\;.
\]
The ideal quotient $I:f$ contains $I$ and is obviously part of the
whole polynomial ring, i.e. contained in $\{1\}$. The case $I:f =
\{1\}$ is equivalent to $f$ member of  $I$. The other extremal case,
$I:f=I$, occurs, when $f$ does not vanish at any general zero of $I$.
The explanation of the notion `general zero' introduced by van der
Waerden, however, is beyond the aim of this manual. The operation
of GROESOLVE/GROEPOSTPROC is based on nested ideal quotient
calculations.

If $I$ is given by a basis and $f$ is given as an expression, the
quotient can be calculated by
\[
IDEALQUOTIENT (\{exp1, \ldots , expm\}, exp [,\{var1,
\ldots , varn\}]); \]
where $\{exp1, exp2, \ldots , expm\}$ is a list of any number of
expressions or equations, {\it exp} is a single expression or equation
and $\{var1, var2, \ldots , varn\}$ is an optional list of variables.

IDEALQUOTIENT calculates the algebraic quotient of the ideal $I$
with the basis  $\{exp1, exp2, \ldots , expm\}$ and {\it exp} with
respect to  the variables given or extracted.  $\{exp1, exp2, \ldots ,
expm\}$ is not necessarily a Groebner basis. As long as the switch
GROEBIDQBASIS is on (default), the result is the Groebner basis of
the quotient. With OFF GROEBIDQBASIS, the final Groebner basis
calculation is suppressed; that makes sense, if e.g. a chain of
quotients has to be calculated and the time for the additional
normalizations should be saved; the result then is a basis for the
quotient, which, however, in general does not have the Groebner
properties.

% Section 4.2
\subsection{Operators for Groebner Bases in all Term Orderings}
\index{Hilbert polynomial}
In some cases where no Groebner
basis with lexical ordering can be calculated, a calculation with a total
degree ordering is still possible. Then the Hilbert polynomial gives
information about the dimension of the solutions space and for finite
sets of solutions univariate polynomials can be calculated. The solutions
of the equation system then is contained in the cross product of all
solutions of all univariate polynomials.

% Subsection 4.2.1
\subsubsection{HILBERTPOLYNOMIAL: Hilbert Polynomial of an Ideal}
\ttindex{HILBERTPOLYNOMIAL}
This algorithm was contributed by {\sc Joachim Hollman}, Royal
Institute of Technology, Stockholm (private communication).

\[
HILBERTPOLYNOMIAL (\{exp1, \ldots , expm\}
[,\{var1, \ldots , varn\}])\;;
\]
where $\{exp1, exp2, \ldots , expm\}$ is a list of any number of
expressions or equations, $\{var1, var2, \ldots , varn\}$ is an
optional list of variables.

HILBERTPOLYNOMIAL calculates the Hilbert polynomial of the ideal
with basis $\{exp1, exp2, \ldots , expm\}$ with respect to the
variables given or extracted provided the given term ordering is
compatible with the degree, such as the GRADLEX- or REVGRADLEX-ordering.
The term ordering of the basis
must be active and $\{exp1, exp2,\ldots$, $ expm\}$ should be a
Groebner basis with respect to this ordering. The Hilbert polynomial
gives information about the cardinality of solutions of the system
$\{exp1, exp2, \ldots , expm\}$: if the Hilbert polynomial is an
integer, the system has only a discrete set of solutions and the
polynomial is identical with the number of solutions counted with
their multiplicities. Otherwise the degree of the Hilbert
polynomial is the dimension of the solution space.

If the Hilbert polynomial is not a constant, it is constructed with the
variable ``X'' regardless of whether $x$ is member of $\{var1, var2, \ldots ,
varn\}$ or not. The value of this polynomial at sufficiently
large numbers  ``X''
is the difference
of the dimension of the linear vector space of all polynomials of degree
$ \leq X $ minus the dimension of the subspace of all polynomials of
degree $\leq X $ which belong also to the ideal.

\paragraph{Remark:} The number of zeros in an ideal and the
Hilbert polynomial depend only on the leading terms of the
Groebner basis. So if a subsequent Hilbert calculation is planned, the
Groebner calculation should be performed with ON GLTBASIS and
the value of GLTB (or its elements in a Groebnerf context) should be
given to HILBERTPOLYNOMIAL.  In this manner, a lot of computing time can be
saved in the case of large bases.

% Chapter 5.
\section{Calculations ``by Hand''}
The following operators support the explicit calculation with
polynomials in a distributive representation on the REDUCE top level.
So they allow one to do Groebner type evaluations stepwise by
separate calls. Note that the normal REDUCE arithmetic can be used
for arithmetic combinations of monomials and polynomials.

% Subsection 5.1
\subsection{Representing Polynomials in Distributive Form}
\ttindex{GSORT}
\[
 GSORT (p[,\{var1, var2, \ldots , varm\}]);
\]
where $p$ is a polynomial or a list of polynomials, $\{var1, var2,
\ldots , varm\}$ in the optional list of variables.

If $p$ is a single polynomial, the result is a reordered version of $p$
in the distributive representation according to the variables and the
current term order mode; if $p$ is a list, its members are converted
into distributive representation and the result is the list sorted by
the term ordering of the leading terms; zero polynomials are
eliminated from the result.

\example \index{GROEBNER package ! example}

{\it korder alpha,beta,gamma;}\\
{\it dip} := {\it  gsort$($gamma$*($alpha$-1)**\,2
*($beta$+1)**\,2)$;}


%{\small
\begin{verbatim}
                2     2                2
    DIP := ALPHA *BETA *GAMMA + 2*ALPHA *BETA*GAMMA

           2                     2
    + ALPHA *GAMMA - 2*ALPHA*BETA *GAMMA - 4*ALPHA*BETA*GAMMA

                           2
     - 2*ALPHA*GAMMA + BETA *GAMMA + 2*BETA*GAMMA + GAMMA

 \end{verbatim}
%}

% Subsection 5.2
\subsection{Splitting of a Polynomial into Leading Term and Reductum<}
\ttindex{GSPLIT}
\[
GSPLIT (p[,\{var1, var2,\ldots ,varm\}]);
\]
where $p$ is a polynomial, $\{var1, var2, \ldots , varm\}$ in the
optional list of variables.

GSPLIT converts the polynomial $p$ into distributive representation
and splits it into leading monomial and reductum. The result is a list
with two elements, the leading monomial and the reductum.

\example \index{GROEBNER package ! example}

{\it gsplit(dip); }
%{\small
\begin{verbatim}
          2     2
    {ALPHA *BETA *GAMMA,

            2                   2                     2
     2*ALPHA *BETA*GAMMA + ALPHA *GAMMA - 2*ALPHA*BETA *GAMMA

                         2
     - 4*ALPHA*BETA*GAMMA - 2*ALPHA*GAMMA + BETA *GAMMA


     + 2*BETA*GAMMA + GAMMA}

 \end{verbatim}
%}

% Section 5.3
\subsection{Calculation of Buchberger's S-polynomial}
\ttindex{GSPOLY}
\[
GSPOLY (p1,p2[,\{var1, var2, \ldots , varm\}]);
\]
where $p1$  and $p2$ are polynomials, $\{var1, var2, \ldots ,
varm\}$ in the optional list of variables.

GSPOLY calculates the $S$-polynomial from $p1$  and $p2$;

Example for a complete calculation (taken from {\sc Davenport et al.}
 \cite{Davenport:88a}):

\hspace*{+1cm}{\it \%  initial system} \\
\hspace*{+1cm}{\it korder x,y,z; torder lex;} \\
\hspace*{+1cm} $g1  :=  x**3*y*z - x*z**2;$\\
\hspace*{+1cm} $g2  :=  x*y**2*z - x*y*z; $ \\
\hspace*{+1cm} $g3  :=  x**2*y**2 - z;$

\hspace*{+1cm}{\it \% first S-polynomial} \\
\hspace*{+1cm} $g4  :=  gspoly(g2,g3);$

%{\small
\begin{verbatim}
       2        2
    G4 := X *Y*Z - Z
 \end{verbatim}
%}

\hspace*{+1cm}{\it \% next S-polynomial} \\
\hspace*{+1cm} $p :=  gspoly(g2,g4); $

%{\small
\begin{verbatim}
          2          2
    P := X *Y*Z - Y*Z
 \end{verbatim}
%}

\hspace*{+1cm}{\it \% and reducing, here only by g4, but preduce
needs a list} \\ \hspace*{+1cm} $g5  :=  preduce(p,\{g4\}); $

%{\small
\begin{verbatim}
                2    2
    G5 :=  - Y*Z  + Z
\end{verbatim}
%}

\hspace*{+1cm}{\it \% last S-polynomial} \\
\hspace*{+1cm}$ g6  :=  gspoly(g4,g5);$

%{\small
\begin{verbatim}
           2  2    3
    G6 := X *Z  - Z
\end{verbatim}
%}

\hspace*{+1cm}{\it \% and the final basis sorted descending} \\
\hspace*{+1cm}{\it gsort} $(\{g2,g3,g4,g5,g6\});$

%{\small
\begin{verbatim}
      2  2
    {X *Y  - Z,

      2        2
     X *Y*Z - Z ,

      2  2    3
     X *Z  - Z ,

        2
     X*Y *Z - X*Y*Z,

           2    2
      - Y*Z  + Z }
 \end{verbatim}
%}
\bibliography{groebner}
\bibliographystyle{plain}
\end{document}

Added r34.1/doc/install.tex version [315e3fbdc8].

























































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
\addtolength{\topmargin}{-.5cm}
\documentstyle[11pt]{report}
\parindent 0pt
\parskip 6pt
\pagestyle{empty}
\setlength{\topsep}{0.5\baselineskip}  % above and below environments
\setlength{\itemsep}{\topsep}
\setlength{\abovedisplayskip}{\topsep}  % for "long" equations
\setlength{\belowdisplayskip}{\topsep}

\renewcommand{\arraystretch}{1.3}
\renewcommand{\thechapter}{\arabic{chapter}}
\renewcommand{\thesection}{\arabic{section}.}
\renewcommand{\thesubsection}{\arabic{subsection}.}
\newcommand{\REDUCE}{REDUCE}

% The following are version dependent.

\newcommand{\system}{Sun Microsystems SPARC systems and Sun 4}
\newcommand{\programsize}{2.5}      % megabytes
\newcommand{\virtualsize}{5}        % megabytes
\newcommand{\timingmachine}{Sun 4/260}
\newcommand{\machinefactors}{SparcStation 1+&0.9 
                          \\ SparcStation 2 &0.7 
                          \\ SparcServer    &0.9
                          \\ Sun 4/110      &1.1
                          \\ Sun 4/65       &1.0}
\newcommand{\cartridgecommand}{{\tt tar xbf 126 /dev/rst0}}
\newcommand{\tapespace}{8.8}        % megabytes
\newcommand{\createtime}{11}        % seconds
\newcommand{\executablespace}{2.5}  % megabytes
\newcommand{\testtime}{5.5}         % seconds

\begin{document}
\begin{titlepage}
\samepage
%\vspace*{1cm}
\begin{center}
\begin{minipage}{10cm}
\begin{center}
{\LARGE {\bf REDUCE} Installation Guide for the} \vspace*{2mm} \\
{\LARGE {\system} Workstations} \\[0.3cm]
{\LARGE Version 3.4} \\[0.3cm]
{\large by} \\[0.3cm]
{\Large Anthony C. Hearn}\\
{\large RAND} \\
{\large Santa Monica, CA 90407-2138 USA} \\[0.3cm]
{\large and} \\[0.3cm]
{\Large Winfried Neun}\\
{\large ZIB} \\
{\large 1000 Berlin 31, FRG} \\[0.3cm]
{\large July 1991}\\[0.5cm]
\vfill

{\bf Abstract}
\end{center}
\end{minipage}
\end{center}
This guide describes the {\REDUCE} distribution tape and procedures for
installing, testing and maintaining {\REDUCE} for the {\system} workstation.

\begin{center}
{ZIB Publication M 2.011.04} \\*[1cm]
Copyright \copyright 1991 by RAND and ZIB.  All rights reserved.
\end{center}

\nopagebreak
Registered system holders may reproduce all or any part of this
publication for internal purposes, provided that the source of the
material is clearly acknowledged, and the copyright notice is retained.
\end{titlepage}
\newpage
\tableofcontents
\thispagestyle{empty}

\newpage
\setcounter{page}{1}
\pagestyle{plain}

\section{Introduction}
This guide describes the {\REDUCE} distribution tape and procedures for
installing, testing and maintaining {\REDUCE} on the {\system} workstation.
{\REDUCE} is based on Standard Lisp, and this version requires the
availability of Portable Standard Lisp (PSL), version 3.4 or later.  The
PSL files necessary to run {\REDUCE} are included on the system tape.  This
is not however a complete PSL system and in particular does not include
PSL sources.  A complete PSL, if needed, is available separately from the
Konrad-Zuse-Zentrum by contacting:

\begin{center}
Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin \\
- Symbolik - \\
Heilbronner Str. 10 \\
1000 Berlin 31 \\
Federal Republic of Germany \\

Telephone: (+49) 30 89604 195 \\
Electronic Mail: melenk@sc.ZIB-Berlin.dbp.de \\
or:              melenk@sc.ZIB-Berlin.de  (Internet) \\
Facsimile: (+49) 30 89604 125.
\end{center}

The distributed version of {\REDUCE} requires approximately {\programsize}
megabytes for the program alone without taking into account workspace
requirements.  It takes its default execution size from the underlying PSL 
system, which is approximately {\virtualsize}
megabytes, and can be enlarged at runtime (see REDUCE User's Guide).

The  job  times  given in this guide are for the {\timingmachine}.
The  following  approximate  adjustment  factors  for  other  machines
have been found to apply:
\begin{center}
\begin{tabular}{ll}
\machinefactors
\end{tabular}
\end{center}

\newpage

\section{Description of the {\REDUCE} Distribution Tape}
The distribution tape is in {\tt tar} format, and was written from the
{\REDUCE} root directory.  The files are organized in sub-directories,
where the sub-directory name describes the contents of the directory,
e.g., ./reduce.rootdir/doc.  The names and contents of these
sub-directories are:
\begin{enumerate}
\item[{\bf doc}]   {\REDUCE} documents, including descriptions of all user
contributed
packages and the following:
\begin{center}
\begin{tabular}{rl}
reduce.tex & {\REDUCE} User's Manual in \LaTeX\ format \\
install.tex & Installation instructions in \LaTeX\ format \\
oper.tex & System specific operation notes in \LaTeX\ format \\
sl.doc & Standard LISP Report in plain text format.
% bugs33.doc &  Known bugs and problems in REDUCE 3.3.
\end{tabular}
\end{center}
\item [{\bf fasl} ]  Binary versions of sources for fast loading {\REDUCE}
functions
\item [{\bf lib}] {\REDUCE} user library
\item [{\bf log} ] Depository for log files created during system building
and testing (initially empty)
\item [{\bf psl}] PSL binaries and related files needed to run {\REDUCE}
\item [{\bf src}] Sources for creating {\REDUCE}, written in both PSL and
RLISP
\item [{\bf util}] Appropriate scripts for building {\REDUCE}, etc.
\item [{\bf xlog}] ``Exemplary" log files for comparison with your own such
files
\item [{\bf xmpl}] {\REDUCE} tests, demonstrations and the interactive
lessons.
\end{enumerate}

\section{Installing {\REDUCE}}
The following description assumes that {\tt csh} is used as the command shell.
If a different shell is used, please change the commands accordingly.
To install {\REDUCE}, you need to create a directory for the {\REDUCE} file
system.  This is identified as ``\$reduce" from now on.  It is assumed
that you have write access to this directory.  Connect to this directory,
mount the tape and type for a 1/2" tape
\begin{center}
\begin{tabbing}
and for cartridge tape xxx \= tar x \kill
                                          \> {\tt tar x} \\
and for a cartridge tape \\
                                          \> {\cartridgecommand}
\end{tabbing}
\end{center}
This will retrieve all files, and requires approximately {\tapespace}
megabytes of disk space.
Finally, please run the commands:
\begin{center}
\begin{tabbing}
and for cartridge tape xxx \= tar x \kill
                                          \> util/sparsify psl/bpsl \\
and \\
                                          \> util/sparsify reduce \\
which will diminish the disk space requirements.
\end{tabbing}
\end{center}

In most cases the installation of Reduce is complete after unloading the
tape.  The location of the {\REDUCE} root directory is essential for using
{\REDUCE}.  Please advise users to set the variable {\tt reduce} in their
environment to this location.  It may be useful to add a link from one of
the standard directories for binaries (e.g. /usr/local/bin) to the reduce
root directory.  Alternatively, if you prefer not to ask users to set {\tt
reduce}, the {\tt reduce} script in the util directory, suitably modified
for local file conventions, could be installed in say /usr/local/bin.

{\REDUCE} is stored in the system as a binary executable disk file 
\$reduce/reduce. 
If modifications of the default settings are requested, one can rebuild 
this file, which is on the tape, by the following commands:
\begin{verbatim}
        setenv reduce <REDUCE root directory>
        $reduce/util/mkreduce
\end{verbatim}

Output from this step is logged to the file \$reduce/log/mkreduce.log.

The mkreduce script builds a {\REDUCE} image of the size described above.
This is usually adequate for most calculations.  If you require a larger
(or smaller) image, you should edit the mkreduce script, and modify the
numbers in the call of bpsl.  In particular, the ``td'' parameter is the
total heap and binary program space size (in bytes).

During the building of the {\REDUCE} binary, messages saying that various
functions have been defined, or not defined, are normal, and can therefore
be ignored.

\section{Printing Documents}
The distributed documents are in the directory \$reduce/doc.  The
\LaTeX\ files need processing before they can be printed.  Plain text
files may be printed using standard UNIX utilities.  They are paginated
and formatted with standard ASCII control characters.  A maximum of sixty
print lines per page are assumed.  The left margin offset must be supplied
by the user.

\section{Testing {\REDUCE}}
To test the {\REDUCE} installation enter:
\begin{verbatim}
        reduce.bindir/reduce
        in "$reduce/xmpl/reduce.tst";
\end{verbatim}

This requires about {\testtime} seconds on the system as described above.

Other programs for testing the {\REDUCE} system assembly may also be found
in the directory \$reduce/xmpl.

\section{Running {\REDUCE} Programs}
Once reduce.bindir in the user's search path, {\REDUCE} is simply invoked
with its name:
\begin{verbatim}
        reduce
\end{verbatim}
{\REDUCE} will respond with a banner line and then prompt for the first
line of input:
\begin{verbatim}
        REDUCE 3.4, 15-Jul-91 ...
        1:
\end{verbatim}

Prototypical instructions for using this version of {\REDUCE}
are available as the file \$reduce/doc/oper.tex. You should edit this to
reflect your site-specific implementation before issuing it to users.
System independent instructions for the use of {\REDUCE} are given in the
{\REDUCE} User's Manual.

\section{Working with Minimal Disk Space}
Many of the {\REDUCE} system files are not necessary for running
{\REDUCE}.  In situations where disk space is at a premium, the following
files may be deleted from disk:
\begin{enumerate}
\item[--] all files in the sub-directories doc, src, util, xlog, log and xmpl,
\item[--] the files in the sub-directory psl which are listed in the file
cleanup.csh in this sub-directory,
\item[--] the files alg.b, arith.b, entry.b, mathpr.b, module.b, poly.b,
prolog.b, rend.b, and rlisp.b in the sub-directory fasl.
\end{enumerate}

After rebuilding or copying the files psl/bpsl and reduce, you should run
the program {\tt util/sparsify} with the relevant filename as parameter.
This will drastically reduce the amount of disk space used.

Although the sub-directories doc and xmpl are not necessary, it is
advisable to leave at least the {\REDUCE} manual, system operating
instructions, the documents for the user packages and the {\REDUCE}
interactive lessons on line for users.

\section{Rebuilding REDUCE FASL Files}
Because of its organization into independently compilable modules, the
current {\REDUCE} system is fairly easy to maintain.  If any source
updates are necessary, they can be incorporated into the appropriate files
using a convenient editor.  Once any of the system source files have been
updated, it is necessary to rebuild (compile) the equivalent fast loading
modules in order to utilize the changes.

To rebuild any of the {\REDUCE} fasl files, connect to the directory
\$reduce and call the script:
\begin{verbatim}
        util/mkfasl xxx
\end{verbatim}
where {\tt xxx} is the appropriate package name, e.g. rend to rebuild
\$reduce/fasl/rend.b from \$reduce/src/rend.red.  If any of the fasl files
used in building the {\REDUCE} system are changed (alg, arith, entry,
mathpr, module, poly, prolog, rend, and rlisp), the reduce binary image will
need to be rebuilt with the script:
\begin{verbatim}
        util/mkreduce
\end{verbatim}

A separate utility script \$reduce/util/build is available for completely
rebuilding all of the {\REDUCE} fasl files.  This should normally never be
required and is included only in case the system becomes so corrupted that
it is no longer possible to rebuild even single modules with the mkfasl
procedure.

\section{Maintaining {\REDUCE}}
The {\tt util} directory includes a number of scripts that are useful for
the ongoing maintenance of {\REDUCE}.  Most of these are only of interest
to the system maintainer, although some (such as {\tt mkslfile} and {\tt
test}) may be of interest to the general user.  Several of these scripts
have been described earlier in this Guide.  However, for completeness,
they are all described in this section.  The scripts are as follows:

\paragraph{build}

This is used to rebuild the complete {\REDUCE} fast-loading (fasl) file
system from scratch.  It first uses the script {\tt dbuild} to build a
version of {\REDUCE} suitable for compiling all packages, and then uses
the script {\tt xbuild} to create the actual fasl files.

\paragraph{check-all}

This can be used to check the logs generated by {\tt test-all} with the
``exemplary" versions found in {\tt xlog}.  It produces a {\tt diff} of
each log referenced in {\tt test-all}.

\paragraph{dbuild}

This is used by {\tt build} (q.v.) to build a version of {\REDUCE} suitable
for compiling all packages.

\paragraph{mkfasl}

This creates a single fasl file from a package file.  It is used in the
form {\tt  mkfasl <package-name> }.

\paragraph{mkfasl2}

This creates a single fasl file from a package file in the \$2 directory.
It is normally used to make fasl files from the {\tt lib} directory, in
which it is used in the form {\tt mkfasl <package-name> lib}.

\paragraph{mkreduce}

This has been mentioned earlier.  It creates the {\REDUCE} executable from
PSL sources and {\REDUCE} fasl files.

\paragraph{mkslfile}

This has also been mentioned earlier.  It generates a Lisp
equivalent of {\REDUCE} or RLISP source files.

\paragraph{reduce}

This is a prototypical script that can be installed, say, in /usr/local/bin,
to set the environment variable {\tt reduce}, and call the {\REDUCE}
executable.

\paragraph{reduce-names}

This file is normally used as an argument to {\tt source} to set up
symbolic names for the {\REDUCE} sub-directories.  It must be modified to
conform to local file conventions.

\paragraph{sparsify}

This utility is used to remove ``dead" space from various PSL binary files
that grow in size when copied.   In addition to the executable, the source
({\tt sparsify.c}) and a UNIX ``man" page ({\tt sparsify.l}) are included.

\paragraph{test}

This can be used to run one of the test files in the {\tt xmpl} directory.
{\tt  test <file>} will run a test file, $<$file$>$.tst that does
not require the explicit loading of a package.
If a package must be loaded to run a test (e.g., algint), the name of
the required package should be provided as a second argument to {\tt test}.

\paragraph{test-all}

This script runs all the tests contained in the xmpl directory, using the
{\tt test} script on each one.  This script takes about 45 minutes to run
on a SPARCstation 1.

\paragraph{testlib}

This can be used to run the test files in the {\tt lib} directory.
{\tt  testlib <package>} will run the test file {\tt <package>.tst} in the
{\tt lib} directory, assuming the fasl file for that package has been built.

\paragraph{xbuild}

This is used by {\tt build} to generate a complete set of fasl files by
applying the {\tt mkfasl} script to each package.

\section{Program Registration}
After installing {\REDUCE}, please fill out the accompanying registration
form and send to:
\begin{center}
Dr. Anthony C. Hearn \\
RAND \\
1700 Main Street \\
Santa Monica, CA 90407-2138 \\
Telephone (213) 393-0411 \\
Facsimile (213) 393-4818 \\
Email: reduce@rand.org
\end{center}

This should be done so that you can be advised direct of any changes which
are made to the system.  Furthermore, the copyright statement on the
{\REDUCE} documents requires such registration as a requirement for their
local distribution.  The test time requested on the registration form is
the time printed by the final call of {\tt showtime} in the output from
the test described in the section ``Testing {\REDUCE}".

\section{Inquiries and Reporting of Errors}
We would appreciate hearing about other bugs you encounter or
questions you may have regarding the assembly or the operation of the system.
Suspected errors should be accompanied by the relevant job output and a copy
of the input source.  Corrections for documented problems or other
improvements to the system are also welcomed.

\newpage
\pagestyle{empty}
\begin{center}
{\Large\bf  REDUCE 3.4  Registration Form}
\end{center}
After installing {\REDUCE}, please fill out this form and send to the
listed address.  This should be done so that you can be
advised direct of any changes made to the system.  Furthermore, returning
the registration form is a requirement for local reproduction of the
{\REDUCE} documentation.
\vspace*{3mm} \\
Date: \hrulefill \vspace*{3mm}\\
Contact Person: \hrulefill\ \vspace*{3mm}\\
Organization: \hrulefill \vspace*{3mm} \\
Address: \hrulefill \vspace*{3mm} \\
\hspace*{16 mm} \hrulefill \vspace*{3mm} \\
\hspace*{16 mm} \hrulefill \vspace*{3mm} \\
Telephone: \hrulefill\ \vspace*{3mm} \\
Network Address: \hrulefill \\
{\small (Indicate network: Internet, BITNET, EARN, UUCP, etc)}
\vspace*{3 mm} \\
REDUCE Supplier: \hrulefill \\[3mm]
Computer Description:
\vspace*{3 mm} \\
Vendor: \hrulefill \vspace*{2mm}    Model: \hrulefill \vspace*{2mm}
Operating System: \hrulefill \\
Please indicate the test time as printed by the final call of {\tt showtime}
in the output from the installation test described in the
section ``Testing {\REDUCE}" of the {\REDUCE} Installation Guide.  Also
give the total system time, region (virtual) and real system memory
available, if applicable. \vspace*{4mm}
\\
Time: \hrulefill Total System Time: \hrulefill\   Region: \hrulefill \vspace*{4mm}
\\
Real System Memory: \hrulefill  .\hspace*{5cm}
\vspace*{3 mm} \\
Please also write on the back of this form any comments you may have about
the installation procedure, and system documentation and performance.
\\[3mm]
\noindent
If you would like to be listed in a published registry of {\REDUCE} system
holders, please check here $\Box$ .

\end{document}

Added r34.1/doc/limits.tex version [6dec75d187].







































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
\documentstyle[11pt,reduce]{article}
\title{A REDUCE Limits Package}
\date{}
\author{Stanley L. Kameny \\ Email: stan\%valley.uucp@rand.org}
\begin{document}
\maketitle

\index{LIMITS package}
LIMITS is a fast limit package for REDUCE for functions which are
continuous except for computable poles and singularities, based on some
earlier work by Ian Cohen and John P. Fitch.  The Truncated Power Series
package is used for non-critical points, at which the value of the
function is the constant term in the expansion around that point.
\index{l'H\^{o}pital's rule}
l'H\^{o}pital's rule is used in critical cases, with preprocessing of
$\infty - \infty$ forms and reformatting of product forms in order
to apply l'H\^{o}pital's rule.  A limited amount of bounded arithmetic
is also employed where applicable.

\section{Normal entry points}
\ttindex{LIMIT}
\vspace{.1in}
\noindent {\tt LIMIT}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic}
\vspace{.1in}

This is the standard way of calling limit, applying all of the methods. The
result is the limit of EXPRN as VAR approaches LIMPOINT.


\section{Direction-dependent limits}

\ttindex{LIMIT+} \ttindex{LIMIT-}
\vspace{.1in}
\noindent {\tt LIMIT!+}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic} \\
\noindent {\tt LIMIT!-}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic}
\vspace{.1in}

If the limit depends upon the direction of approach to the {\tt LIMPOINT},
the functions {\tt LIMIT!+} and {\tt LIMIT!-} may be used.  They are
defined by:

\vspace{.1in}
\noindent{\tt LIMIT!+ (LIMIT!-)} (EXP,VAR,LIMPOINT) $\rightarrow$ \\
\hspace*{2em}{\tt LIMIT}(EXP*,$\epsilon$,0)
EXP*=sub(VAR=VAR+(-)$\epsilon^2$,EXP)

\section{Diagnostic Functions}

\ttindex{LIMIT0}
\vspace{.1in}
\noindent {\tt LIMIT0}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic}
\vspace{.1in}

This function will use all parts of the limits package, but it does not
combine log terms before taking limits, so it may fail if there is a sum
of log terms which have a removable singularity in some of the terms.

\ttindex{LIMIT1}
\vspace{.1in}
\noindent {\tt LIMIT1}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic}
\vspace{.1in}

\index{TPS package}
This function uses the TPS branch only, and will fail if the limit point is
singular.

\ttindex{LIMIT2}
\vspace{.1in}
\begin{tabbing}
{\tt LIMIT2}(\=TOP:{\em algebraic}, \\
\>BOT:{\em algebraic}, \\
\>VAR:{\em kernel}, \\
\>LIMPOINT:{\em algebraic}):{\em algebraic}
\end{tabbing}
\vspace{.1in}

This function applies l'H\^{o}pital's rule to the quotient (TOP/BOT).
\end{document}

Added r34.1/doc/odesolve.tex version [2e6aef1b7f].































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
\documentstyle[11pt,reduce]{article}
\date{}
\title{ODESOLVE}
\author{Malcolm A.H. MacCallum \\ Queen Mary and Westfield College, London \\
Email: mm@maths.qmw.ac.uk \\[0.1in]
Other contributors: Francis Wright, Alan Barnes}
\begin{document}
\maketitle

\index{ODESOLVE package}
\index{ordinary differential equations}
The ODESOLVE package is a solver for ordinary differential equations.
At the present time it has very limited capabilities,

\begin{enumerate}
\item it can handle only a single scalar equation presented as an
algebraic expression or equation, and
\item it can solve only first-order equations of simple types,
linear equations with constant coefficients and Euler equations.
\end{enumerate}

\noindent These solvable types are exactly those for
which Lie symmetry techniques give no useful information.

\section{Use}
The only top-level function the user should normally invoke is:
\ttindex{ODESOLVE}

\vspace{.1in}
\begin{tabbing}
{\tt ODESOLVE}(\=EXPRN:{\em expression, equation}, \\
\>VAR1:{\em variable}, \\
\>VAR2:{\em variable}):{\em list-algebraic}
\end{tabbing}
\vspace{.1in}

\noindent {\tt ODESOLVE} returns a list containing an equation (like solve):

\begin{description}
\item[EXPRN] is a single scalar expression such that EXPRN = 0 is the
ordinary differential equation (ODE for short) to be solved,
or is an equivalent equation.
\item[VAR1] is the name of the dependent variable.
\item[VAR2] is the name of the independent variable
\end{description}

\noindent (For simplicity these will be called y and x in the sequel)
The returned value is a list containing the equation giving the
general solution of the ODE (for simultaneous equations this will be a
list of equations eventually). It will contain occurrences of the
\index{ARBCONST operator}
operator {\tt ARBCONST} for the arbitrary constants in the general solution.
The arguments of {\tt ARBCONST} should be new, as with {\tt ARBINT} etc.
in SOLVE. A counter {\tt !!ARBCONST} is used to arrange this (similar to the
way {\tt ARBINT} is implemented).

Some other top-level functions may be of use elsewhere, especially:
\ttindex{SORTOUTODE}

\vspace{.1in}
\noindent{\tt SORTOUTODE}(EXPRN:{\em algebraic}, Y:{\em var}, X:{\em var}):
{\em expression}
\vspace{.1in}

\noindent which finds the order and degree of the EXPRN as a differential
equation for Y with respect to Y and sets the linearity and highest
derivative occurring in reserved variables ODEORDER, ODEDEGREE,
\ttindex{ODEORDER} \ttindex{ODEDEGREE} \ttindex{ODELINEARITY}
\ttindex{HIGHESTDERIV}
ODELINEARITY and HIGHESTDERIV. An expression equivalent to the ODE is
returned, or zero if EXPRN (equated to 0) is not an ODE in the
given vars.

Only in the version using variation of parameters:
\ttindex{CORFACTOR}

\vspace{.1in}
\begin{tabbing}
{\tt COFACTOR}(\=ROW:{\em integer}, \\
\>COLUMN:{\em integer}, \\
\>MATRIX:{\em matrix}):{\em algebraic}
\end{tabbing}
\vspace{.1in}

\noindent The cofactor of the element in row ROW and column COLUMN of matrix
MATRIX is returned. Errors occur if ROW or COLUMN do not simplify to integer 
expressions  or if MATRIX is not square.

\section{Tracing}


Some rudimentary tracing is provided and is activated by the switch TRODE
\index{tracing ! ODESOLVE}
\ttindex{TRODE}
(analogous to TRFAC and TRINT)

\section{Comments}

The intention in the long run is to develop a rather general and
powerful ordinary differential equation solver incorporating the
methods detailed below.  At present the program has not been optimized
for efficiency and much work remains to be done to convert algebraic
mode procedures to more efficient symbolic mode replacements.

No attempt is made to extend the REDUCE integrator, although this is
in some sense a problem of ODEs.  Thus the equation $\frac{dy}{dx} = g(x)$ will
be solved if and only if $\int g(x) dx$ succeeds.

The available and planned coverage is as follows:

\begin{itemize}
\item First-order equations: (first degree unless otherwise stated)

\begin{itemize}
\item Quadrature of $\frac{df}{dx} = g(x)$
\item Linear equations
\item Separable equations
\item (Algebraically) homogeneous equations
\item Equations reducible to the previous case by linear transformations
\item Exact equations
\item Bernoulli equations
\end{itemize}

The above are already implemented. Further 1st order cases are not:
\begin{itemize}
\item Riccati equations using Schmidt's methods and other special cases
\item Hypotheses on the integrating factor following Char (SYMSAC 81)
or Shtokhamer, Glinos and Caviness.
\item Higher degree cases
\end{itemize}
\item Linear equations of higher order
\begin{itemize}
\item Constant coefficients case for driving terms solvable by
variation of parameters using the integrator
(Choice of method is discussed in the source of module lccode).
\end{itemize}
The above is already implemented. Further higher order methods are not:
\begin{itemize}
\item More complex driving terms via Laplace transforms (?)
\item  Variable coefficients: Watanabe (EUROSAM 84) methods
including Kovacic's algorithm as extended by Singer
\item  Factorization of operators as in Schwarz's ISSAC-89 paper or
Berkovich's 1990 book
\item  Other methods based on Galois theory (see Ulmer's preprints
from Karlsruhe, 1989, 1990 and Singer's 1989 review) or
other ways of hunting Liouvillian solutions (see Singer's
review in J. Symb. Comp., 1990).
\end{itemize}
\item Non-linear equations of order 2 and higher
\begin{itemize}
\item Lie algebra of point symmetries e.g. using Wolf's CRACK now available
in REDUCE
\item  Other special ansatze (see Wolf. op. cit), in particular
contact transformations for 2nd order cases
\end{itemize}
\item Possibly (?) exploitation of Cartan's methods for equivalence of
differential equations.
\end{itemize}
\end{document}

Added r34.1/doc/oper.tex version [4b082b74e9].





















































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
\hoffset -.5cm
\documentstyle[11pt]{report}
\parindent 0pt
\parskip 6pt
\pagestyle{empty}
\setlength{\topsep}{0.5\baselineskip}  % above and below environments
\setlength{\itemsep}{\topsep}
\setlength{\abovedisplayskip}{\topsep}  % for "long" equations
\setlength{\belowdisplayskip}{\topsep}

\renewcommand{\arraystretch}{1.3}
\renewcommand{\thechapter}{\arabic{chapter}}
\renewcommand{\thesection}{\arabic{section}.}
\renewcommand{\thesubsection}{\arabic{subsection}.}
\newcommand{\REDUCE}{REDUCE}

% The following are version dependent.

\newcommand{\system}{Sun Microsystems SPARC systems and Sun 4}
\newcommand{\programsize}{2.5}      % megabytes
\newcommand{\virtualsize}{128}      % megabytes
\newcommand{\timingmachine}{Sun 4/260}
\newcommand{\machinefactors}{SparcStation 1+&0.9
                          \\ SparcStation 2 &0.7
                          \\ SparcServer    &0.9
                          \\ Sun 4/110      &1.1
                          \\ Sun 4/65       &1.0}
\newcommand{\cartridgecommand}{tar xbf 126 /dev/rst0}
\newcommand{\tapespace}{8.8}        % megabytes
\newcommand{\createtime}{11}        % seconds
\newcommand{\executablespace}{2.5}  % megabytes
\newcommand{\testtime}{5.5}         % seconds
\newcommand{\floatingpointdigits}{12}

\begin{document}
\vspace*{1cm}
\begin{center}
{\LARGE {\bf REDUCE} User's Guide  for the } \vspace*{2mm} \\
{\LARGE {\system} Workstations} \\
\vspace*{.5cm}
{\LARGE Version 3.4} \\[0.3cm]
{\large by} \\[0.3cm]
{\Large Anthony C. Hearn}\\
{\large RAND} \\
{\large Santa Monica, CA 90407-2138 USA} \\[0.3cm]
{\large and} \\[0.3cm]
{\Large Winfried Neun}\\
{\large ZIB} \\
{\large 1000 Berlin 31, FRG} \\[0.3cm]
{\large July 1991}\\[0.5cm]
\vfill

{\bf Abstract}
\end{center}
This document describes operating procedures for running {\REDUCE}
specific to the {\system} workstations.
\begin{center}
{ZIB  Publication M 2.010.04} \\
\vspace*{1cm}
Copyright \copyright 1991 by RAND and ZIB.  All rights reserved.
\end{center}

Registered  system holders may reproduce all or any part of  this
publication  for  internal  purposes,   provided  that the source
of the material is clearly acknowledged, and the copyright notice
is retained.

\newpage
\tableofcontents
\thispagestyle{empty}

\newpage
\setcounter{page}{1}
\pagestyle{plain}

\section{Preliminary}
This document describes operating procedures for running {\REDUCE}
specific to the {\system} workstations.  It supplements the {\REDUCE}
User's Manual, describing features, extensions and limitations specific to
this implementation of {\REDUCE}.

This manual assumes that {\tt csh} is used as the command shell.  If a
different shell is used, please change commands or filenames accordingly.

The files that form the {\REDUCE} system are stored under the {\REDUCE}
root directory, identified here as ``\$reduce''.  To execute {\REDUCE}
first check that the {\REDUCE} binary directory, identified here as
{\tt reduce.bindir} is included in your search path.  If not, the path
definition in your .login or .cshrc file should be modified accordingly,
e.g.:
\begin{verbatim}
        set path=( <reduce.bindir> $path)
\end{verbatim}
Alternatively, for calling {\REDUCE} without a search path reference, you
can put an entry in the .login or .cshrc file to define an alias for
calling {\REDUCE} directly, e.g.:
\begin{verbatim}
        alias reduce <reduce.bindir>/reduce
\end{verbatim}
In order to access the {\REDUCE} directories most easily, you should also
include the statement (csh dependent)
\begin{verbatim}
        setenv reduce <REDUCE root directory>
\end{verbatim}

Directories of interest to the general user include \$reduce/doc,
containing relevant documents and \$reduce/xmpl, containing various
examples of the use of {\REDUCE}.  The more serious user may also be
interested in the {\REDUCE} sources stored in the directory \$reduce/src. \\

To run {\REDUCE}, you enter (in lower case only)
\begin{verbatim}
        reduce
\end{verbatim}
or, if you like a simple protocol of your session written into a file,
\begin{verbatim}
        reduce | tee <file>
\end{verbatim}
after which {\REDUCE} will respond with a banner line and then prompt for
the first line of input:
\begin{verbatim}
        REDUCE 3.4, 15-Jul-91 ...
        1:
\end{verbatim}

You can now begin entering commands.  Alternatively you can enter the full
pathname:
\begin{verbatim}
        <reduce.bindir>/reduce
\end{verbatim}

\section{{\REDUCE} Documentation}
{\REDUCE} documents are kept in the directory \$reduce/doc .  These
include descriptions of all user contributed packages and the following:

\begin{center}
\begin{tabular}{rl}
reduce.tex & {\REDUCE} User's Manual in \LaTeX\ format \\
install.tex & Installation instructions in \LaTeX\ format \\
oper.tex & System specific operation notes in \LaTeX\ format \\
sl.doc & Standard LISP Report in plain text format.
% bugs33.doc &  Known bugs and problems in REDUCE 3.3.
\end{tabular}
\end{center}

\section{An Introduction to {\REDUCE}}
New users of {\REDUCE} are advised to process the seven {\REDUCE} Lessons,
which are available as \$reduce/xmpl/less$\langle$i$\rangle$.  For
example, to run Lesson 1, you would say:
\begin{verbatim}
        in "$reduce/xmpl/less1";
\end{verbatim}
A number of example files are also contained in the \$reduce/xmpl
directory.  These show how many of the facilities available in {\REDUCE}
are used.

\section{Resource Requirement}
The distributed version of {\REDUCE} requires approximately
{\executablespace} megabytes for storage of the executable binary file.
At run time, it takes its default execution size from the
underlying PSL system.
This size can be changed with the \verb|set_heap_size| command 
(see chapter 7). 
This implementation will allocate up to {\virtualsize} megabytes
dynamically, if the operating system supplies a sufficiently large swap
space on disks.

\section{File Handling}
The file names that appear in {\tt in}, {\tt out} and {\tt shut}
statements follow normal UNIX conventions.  If the name contains uppercase
or special characters (e.g., \verb| $ ~ . /|)
it must be enclosed in double quotes
(``FileName").  Whereas, if an
identifier is used as a filename all characters are
interpreted as lower case.
Filenames containing patterns \verb| ~user, ~/ or $var| are expanded , whereas
patterns including \verb| * , ? , {...} or [...]| are not expanded.


If you execute the statement (csh dependent)
\begin{verbatim}
        source $reduce/util/reduce-names
\end{verbatim}
(preferably in your .login or .cshrc file), {\REDUCE} sub-directories such
as \$reduce/xmpl can then be referenced using symbolic names.  These are
formed by prefixing \$r to the sub-directory names.  Thus less1 can also
be input by the statement
\begin{verbatim}
        in "$rxmpl/less1";
\end{verbatim}

\section{Internal Parameters}

\subsection{Object Sizes}
The maximum string and identifier lengths are limited only by the
underlying PSL base.  The current implementation allows several thousand
characters in both identifiers and strings.  However, we recommend that
such names be limited to 24 characters or less for compatibility with
other versions of {\REDUCE}.

In the default precision, floating point numbers are printed in
fixed-point notation rounded to {\floatingpointdigits} digits.

Arbitrary precision integer and real arithmetic are supported.

\subsection{Special Characters and Interrupts}
Lower case input is permitted, but converted to upper case unless the
switch {\tt raise} is off.

The end-of-file character is $\langle$control$\rangle$D.

A terminal interrupt (often $\langle$del$\rangle$ or
$\langle$control$\rangle$C) causes the current calculation to halt.  The
user is then prompted whether to continue the evaluation.  If not,
{\REDUCE} prompts for the next command.  In some cases the continuation
prompt may be omitted and {\REDUCE} immediately prompts for the next
command.

$\langle$escape$\rangle$ is used to terminate strings in the {\REDUCE}
interactive editor.

\subsection{Miscellaneous}
There is no link currently to an external editor.

The internal ordering on alphabetic characters is from A through Z
followed by a through z.

Times (as reported by {\tt on time; } or {\tt showtime;}) are given in
milliseconds, and measure execution time and garbage collection
time separately.  They do not include operating system overhead 
(e.g., swapping time).

To exit {\REDUCE} use {\tt bye;} .  Alternatively, if
you want to continue the {\REDUCE}
session later use {\tt <control>Z}.  To restart, one says
{\tt fg}, or another valid UNIX command for this purpose.  Use the UNIX
{\tt kill} command to remove the job.

\section{Customizing the {\REDUCE} Environment}

\subsection{Size of Working Space} Depending on the complexity
of your application, the amount of storage
used by {\REDUCE} for storing and manipulating your data will vary
considerably. You may get an idea of the storage requirements however by
turning on the switch {\tt gc}:
\begin{verbatim}
        on gc;
\end{verbatim}
You will then get messages like:
\begin{verbatim}
 *** Garbage collection starting
 *** GC 2: 15-Jul-91 16:12:53 (~ 1836 ms cpu time, gc : 28 %)
 *** time 289 ms, 50167 occupied, 51876 recovered, 949833 free
\end{verbatim}
at various points in your calculation.
From these statistics you can see the amount of storage used, the
free memory, and the percentage of cpu time spent on
memory management (garbage collection). If the percentage is high, more
than 20\% say, it is recommended that you increase memory size.
This can be done by the command:
\begin{verbatim}
        set_heap_size nnnnnnn;
\end{verbatim}
where nnnnnnn is the size in machine words of the dynamic storage.
The default will be (in most cases) 1000000 words. The present memory size
is returned by:
\begin{verbatim}
        set_heap_size nil;
\end{verbatim}

\subsection{Initial Commands} When {\REDUCE} is initialized,
a .reducerc file, if present, will be read
from the user's home directory.  This file can contain any {\REDUCE} or
PSL commands needed for customizing the {\REDUCE} environment.  Typically
these are load commands to load specific user modules or the inclusion
of local user directories through the LOADDIRECTORIES facilities.  See the
PSL manual for more information on this feature.

The commands in the .reducerc file must be in Standard Lisp syntax.  To
display {\REDUCE} commands in Standard Lisp syntax, the {\REDUCE} {\tt on
defn} feature can be used.  The script \$reduce/util/mkslfile is available
for converting an entire file to Standard Lisp syntax.  For further
details, the Standard Lisp Report should be consulted.

\section{Communicating with UNIX}

There are two different ways for a {\REDUCE} user to communicate with the
UNIX operating system:
It is possible to issue a UNIX command and return to
{\REDUCE} at its completion by means of the command {\tt system}. 
Alternatively, some UNIX functions are built into the REDUCE executable
directly such that the user can influence the present task and interpret
the system's return value.

The argument to {\tt system} is a string which is then passed as a UNIX
command to your default shell.  For example,
\begin{verbatim}
        system "vi foo/bah";
\end{verbatim}
will edit the file foo/bah using the "vi" editor, and
\begin{verbatim}
        system "lpr foo/bah";
\end{verbatim}
will print the same file. If you want to change for example your current
working directory the command:
\begin{verbatim}
        system "cd /tmp";
\end{verbatim}
is not of much use, since the {\tt cd} command is run in a UNIX child's
environment and not in the Reduce task environment.  In this case the
command
\begin{verbatim}
        cd "/tmp";
\end{verbatim}
will produce the desired effect. More internally available functions
are provided, including {\tt pwd}, {\tt getenv} and {\tt setenv}.
The latter work as described in the UNIX
``man" pages, i.e., they expect parameters as strings, e.g.
\begin{center}
\begin{tabular}{l@{\rm\quad returns }l}
\tt pwd();                   & \tt "/tmp/"   \\
\tt setenv ("hugo","otto");  & \tt NIL  \rm and then \\
\tt getenv "hugo";           & \tt "otto"
\end{tabular}
\end{center}

\section{Implementation Dependent Error Messages}
A number of error messages from the underlying PSL system may be seen from
time to time.  These include:

\paragraph{Floating point exception.} Probably means a division by zero
has been attempted or a floating-point overflow has happend.

\paragraph{Heap space exhausted.} Your problem is too large in its present
form for the available workspace; either change your problem formulation
or ask your site consultant to build a bigger system for you.

\paragraph{Non-numeric argument in arithmetic.} This means that a Lisp
arithmetic routine has been called with an invalid argument.

\paragraph{Segmentation violation.} This indicates an illegal memory
reference.  It can arise from applying the Lisp function {\tt car} to an
atom in compiled code.

\paragraph{Bus error.} This indicates an illegal memory reference.  It
can arise from applying the Lisp function {\tt car} to an atom in compiled
code.

\paragraph{Binding stack overflow, restarting...} This can arise from 
the evaluation of
very complicated expressions. You can increase the binding stack by the
\verb|set_bndstk_size| command.  For example, to set this to 100000, use:
\begin{verbatim}
        set_bndstk_size 100000;
\end{verbatim}
\section{Further Help}
For further help with {\REDUCE}, please contact:
\begin{center}
$\langle$list your site consultant here$\rangle$
\end{center}

\end{document}

Added r34.1/doc/orthovec.bib version [0560bdcb53].





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
@ARTICLE{Eastwood:87,
 AUTHOR = "James W. Eastwood",
 TITLE = "Orthovec:  A {REDUCE} Program for {3-D} Vector Analysis
in Orthogonal Curvilinear Coordinates",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1987, VOLUME = 47, NUMBER = 1, PAGES = "139-147", MONTH = "October"}

@ARTICLE{Eastwood:91,
 AUTHOR = "James W. Eastwood",
 TITLE = "{ORTHOVEC:} version 2 of the {REDUCE} program for {3-D} vector
analysis in orthogonal curvilinear coordinates",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1991, VOLUME = 64, NUMBER = 1, PAGES = "121-122", MONTH = "April"}

@BOOK{Speigel:59,
  AUTHOR = "M . Speigel",
  TITLE = "Vector Analysis",
  PUBLISHER = "Scheum Publishing Co.", YEAR = 1959}

Added r34.1/doc/orthovec.tex version [e04d92936c].























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
\documentstyle[11pt,reduce]{article}
\title{ORTHOVEC: Version 2 of the REDUCE program
for 3-D vector analysis in orthogonal curvilinear coordinates}
\date{}
\author{James W.~Eastwood \\ AEA Technology \\ Culham Laboratory \\
Abingdon \\ Oxon OX14 3DB \\[0.1in]
Email: eastwood\#jim\%nersc.mfenet@ccc.nersc.gov \\[0.1in] June 1990}
\begin{document}
\maketitle
\index{ORTHOVEC package}

The revised version of ORTHOVEC is a collection of REDUCE 3.4 procedures and
operations which provide a simple to use environment for the manipulation of
scalars and vectors.  Operations include addition, subtraction, dot and cross
products, division, modulus, div, grad, curl, laplacian, differentiation,
integration, ${\bf a \cdot \nabla}$ and Taylor expansion.  Version 2 is
summarized in \cite{Eastwood:91}.  It differs from the original (\cite
{Eastwood:87}) in revised notation and extended capabilities.

%\begin{center}
%{\Large{\bf New Version Summary}}
%\end{center}
%\begin{tabular}{ll}
%\underline{Title of program}:&ORTHOVEC\\[2ex]
%\underline{Catalogue number}:&AAXY\\[2ex]
%\underline{Program obtainable from}: &CPC Program Library,\\
%&Queen's University of Belfast, N.~Ireland\\[2ex]
%\underline{Reference to original program}: &CPC 47 (1987) 139-147\\[2ex]
%\underline{Operating system}:&UNIX, MS-DOS + ARM-OS\\[2ex]
%\underline{Programming Language used}: &REDUCE 3.4\\[2ex]
%\underline{High speed storage required}: &As for 
%the underlying PSL/REDUCE \\
%&system, typically $>$ 1 Megabyte\\[2ex]
%\underline{No. of lines in combined programs and test deck}:&600 \\[2ex]
%\underline{Keywords}: & Computer Algebra, Vector Analysis,\\
%& series Expansion,  Plasma Physics, \\
%&Hydrodynamics, Electromagnetics.\\[2ex]
%\underline{Author of original program}: &James W. EASTWOOD\\[2ex]
%\underline{Nature of Physical Problem}: 
%&There is a wide range using vector\\
%& calculus in orthogonal curvilinear coordinates\\
%& and vector integration, differentiation\\
%& and series expansion.\\[2ex]
%\underline{Method of Solution}: & computer aided algebra using\\
%&standard orthogonal curvilinear coordinates\\
%&for differential and integral operators.\\[2ex]
%\underline{Typical running time}: 
%& This is strongly problem dependent:\\
%&the test examples given took respectively\\
%& 10,19 and 48 seconds on a SUN 4/310,\\
%&SUN 4/110 and ACORN Springboard. \\[2ex]
%\underline{Unusual Features of the Program}: 
%&The REDUCE procedures use\\
%&LISP vectors \cite{r2}
%to provide a compact\\
%&mathematical notation similar\\
%& to that normally found in vector\\
%& analysis textbooks.\\
%\end{tabular}

\section{Introduction}
The revised version of ORTHOVEC\cite{Eastwood:91} is, like the
original\cite{Eastwood:87}, a collection of REDUCE procedures and
operators designed to simplify the machine aided manipulation of vectors
and vector expansions frequently met in many areas of applied mathematics.
The revisions have been introduced for two reasons: firstly, to add extra
capabilities missing from the original and secondly, to tidy up input and
output to make the package easier to use.
\newpage
The changes from Version 1 include:

\begin{enumerate}
\item merging of scalar and vector unary and binary operators, $+, - , *, /
$
\item extensions of the definitions of division and exponentiation 
to vectors
\item new vector dependency procedures
\item application of L'H\^opital's rule in limits and Taylor expansions
\item a new component selector operator
\item algebraic mode output of LISP vector components
\end{enumerate}

The LISP vector primitives are again used to store vectors, although 
with the introduction of LIST types in algebraic mode in REDUCE
3.4, the implementation may have been more simply achieved 
using lists to store vector components.

The philosophy used in Version 2 follows that used in the original:
namely, algebraic mode is used wherever possible.  The view is taken
that some computational inefficiencies are acceptable if it allows
coding to be intelligible to (and thence adaptable by) users other
than LISP experts familiar with the internal workings of REDUCE.

Procedures and operators in ORTHOVEC fall into the five classes: 
initialisation, input-output, algebraic operations, differential
operations and integral operations.  Definitions are given in 
the following sections, and
a summary of the procedure names and their meanings are give in Table 1.
The final section discusses test examples.

\section{Initialisation}\label{vstart}
\ttindex{VSTART}
The procedure VSTART initialises ORTHOVEC.  It may be
called after ORTHOVEC has been INputted (or LOADed if a fast load
version has been made) to reset coordinates.  VSTART provides a
menu of standard coordinate systems:-


\begin{enumerate}
\index{cartesian coordinates}
\item cartesian $(x, y, z) = $ {\tt (x, y, z)}
\index{cylindrical coordinates}
\item cylindrical $(r, \theta, z) = $ {\tt (r, th, z)}
\index{spherical coordinates}
\item spherical $(r, \theta, \phi) = $ {\tt (r, th, ph) }
\item general $( u_1, u_2, u_3 ) = $ {\tt (u1, u2, u3) }
\item others
\end{enumerate}

which the user selects by number.  Selecting options (1)-(4)
automatically sets up the coordinates and scale factors.  Selection
option (5) shows the user how to select another coordinate system.  If
VSTART is not called, then the default cartesian coordinates are used.
ORTHOVEC may be re-initialised to a new coordinate system at any time
during a given REDUCE session by typing
\begin{verbatim}
VSTART $.
\end{verbatim}

\section{Input-Output}

ORTHOVEC assumes all quantities are either scalars or 3 component
vectors.  To define a vector $a$ with components $(c_1, c_2, c_3)$ use
the procedure SVEC as follows \ttindex{SVEC}
\begin{verbatim}
a := svec(c1, c2, c3);
\end{verbatim}

The standard REDUCE output for vectors when using the terminator ``$;$''
is to list the three components inside square brackets
$[\cdots]$, with each component in prefix form.  A replacement for the
standard REDUCE procedure MAPRIN is included in
the package to change the 
output of LISP vector components to algebraic notation.  The procedure
\ttindex{VOUT} VOUT (which returns the value of its argument)
can be used to give labelled output of components 
in algebraic form: e.g.,
\begin{verbatim}
b := svec (sin(x)**2, y**2, z)$
vout(b)$
\end{verbatim}

The operator {\tt \_} can be used to select a particular 
component (1, 2 or 3) for output e.g.
\begin{verbatim}
b_1 ;
\end{verbatim}

\section{Algebraic Operations}

Six infix operators, sum, difference, quotient, times, exponentiation
and cross product, and four prefix
operators, plus, minus, reciprocal
and  modulus are defined in ORTHOVEC.  These operators can take suitable
combinations of scalar and vector arguments,
and in the case of scalar arguments reduce to the usual definitions of
$ +, -, *, /, $ etc.

The operators are represented by symbols 
\index{+ ! 3-D vector} \index{- ! 3-D vector} \index{/ ! 3-D vector}
\index{* ! 3-D vector} \index{* ! 3-D vector} \index{"\^{} ! 3-D vector}
\index{$><$ ! 3-D vector}
\begin{verbatim}  
+, -, /, *, ^, ><
\end{verbatim}

\index{$><$ ! diphthong} The composite {\tt ><} is an
attempt to represent the cross product symbol 
$\times$ in ASCII characters.
If we let ${\bf v}$ be a vector and $s$ be a scalar, then
valid combinations of arguments of the 
procedures and operators and the type of the result 
are as summarised below.  The notation used is\\
{\em result :=procedure(left argument, right argument) } or\\
{\em result :=(left operand) operator (right operand) } . \\

\newpage
\underline{Vector Addition} \\
\ttindex{VECTORPLUS} \ttindex{VECTORADD} \index{vector ! addition}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORPLUS({\bf v})  &{\rm or}& {\bf v} &:=&  +  {\bf v} \\
     s  &:=& VECTORPLUS(s)  &{\rm or} &      s  &:=&  +       s  \\
{\bf v} &:=& VECTORADD({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=&  
{\bf v} +  {\bf v} \\
     s  &:=& VECTORADD(s,s)  &{\rm or }&      s  &:=&  s + s \\
\end{tabular} \\

\underline{Vector Subtraction} \\
\ttindex{VECTORMINUS} \ttindex{VECTORDIFFERENCE} \index{vector ! subtraction}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORMINUS({\bf v})  &{\rm or}&
 {\bf v} &:=&  +  {\bf v} \\
 s  &:=& VECTORMINUS(s)  &{\rm or} &      s  &:=&  +       s  \\
{\bf v} &:=& VECTORDIFFERENCE({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=&
  {\bf v} +  {\bf v} \\
 s  &:=& VECTORDIFFERENCE(s,s)  &{\rm or }&      s  &:=&  s + s \\
\end{tabular} \\

\underline{Vector Division}\\
\ttindex{VECTORRECIP} \ttindex{VECTORQUOTIENT} \index{vector ! division}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORRECIP({\bf v})  &{\rm or}& {\bf v} &:=&  /  
{\bf v} \\
 s  &:=& VECTORRECIP(s)  &{\rm or} &      s  &:=&  /       s  \\
{\bf v} &:=& VECTORQUOTIENT({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=&  
{\bf v} /  {\bf v} \\
{\bf v} &:=& VECTORQUOTIENT({\bf v},    s  )  &{\rm or }& {\bf v} &:=&  
{\bf v} /     s    \\
{\bf v} &:=& VECTORQUOTIENT(   s   ,{\bf v})  &{\rm or }& {\bf v} &:=&  
   s    /  {\bf v} \\
     s  &:=& VECTORQUOTIENT(s,s)  &{\rm or }&      s  &:=&  s / s       
       \\
\end{tabular} \\

\underline{Vector Multiplication}\\ 
\ttindex{VECTORTIMES} \index{vector ! multiplication}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORTIMES(   s   ,{\bf v})  &{\rm or }& {\bf v} &:=&     
s    *  {\bf v} \\
{\bf v} &:=& VECTORTIMES({\bf v},   s   )  &{\rm or }& {\bf v} &:=& {\bf
 v}  *     s    \\
   s    &:=& VECTORTIMES({\bf v},{\bf v})  &{\rm or }&    s    &:=& {\bf
 v}  *  {\bf v} \\
   s    &:=& VECTORTIMES(   s   ,   s   )  &{\rm or }&    s    &:=&     
s    *     s    \\
\end{tabular} \\
 
\underline{Vector Cross Product} \\
\ttindex{VECTORCROSS} \index{cross product} \index{vector ! cross product}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORCROSS({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=& {\bf
 v} $\times$   {\bf v} \\
\end{tabular} \\
 
\underline{Vector Exponentiation}\\
\ttindex{VECTOREXPT} \index{vector ! exponentiation}
\begin{tabular}{rclcrcl}
   s    &:=& VECTOREXPT ({\bf v},   s   )  &{\rm or }&    s    &:=& {\bf
 v}  \^{} s   \\
   s    &:=& VECTOREXPT (   s   ,   s   )  &{\rm or }&    s    &:=&    s
     \^{} s   \\
\end{tabular} \\

\underline{Vector Modulus}\\
\ttindex{VMOD} \index{vector ! modulus}
\begin{tabular}{rcl}
   s    &:=& VMOD (s)\\
   s    &:=& VMOD ({\bf v}) \\
\end{tabular} \\

All other combinations of operands for these operators lead to error 
messages being issued.  The first two instances of vector
multiplication are scalar multiplication of vectors, the third is the
\index{vector ! dot product} \index{vector ! inner product}
\index{inner product} \index{dot product}
product of two scalars and the last is the inner (dot) product.  The
prefix operators  {\tt +, -, /} can take either scalar or vector
arguments and return results of the same type as their arguments. 
VMOD returns a scalar.

In compound expressions, parenthesis may be used to specify the order of 
combination.  If parentheses are omitted the ordering of the
operators, in increasing order of precedence is
\begin{verbatim}
+ | - | dotgrad | * | >< | ^ | _
\end{verbatim}
and these are placed in the precedence list defined in REDUCE
after $<$.
The differential operator DOTGRAD is defined in the \index{DOTGRAD operator}
following section, and the component selector {\tt \_} was introduced in
section 3.

Vector divisions are defined as follows:  If ${\bf a}$ and ${\bf b}$ are
vectors and $c$ is a scalar, then
\begin{eqnarray*}
{\bf a} /  {\bf b} & = &  \frac{{\bf a} \cdot {\bf b}}{  \mid {\bf b} 
\mid^2}\\
c / {\bf a}   & = &  \frac{c {\bf a}  }{ \mid {\bf a} \mid^2}
\end{eqnarray*}

Both scalar multiplication and dot products are given by the same symbol, 
braces are advisable to ensure the correct
precedences in expressions such as $({\bf a} \cdot {\bf b}) 
({\bf c} \cdot {\bf d})$.

Vector exponentiation is defined as the power of the modulus:\\
${\bf a}^n \equiv  {\rm VMOD}(a)^n =   \mid {\bf a} \mid^n$

\section{Differential Operations}
Differential operators provided are div, grad, curl, delsq, and dotgrad.
\index{div operator} \index{grad operator} \index{curl operator}
\index{delsq operator} \index{dotgrad operator}
All but the last of these are prefix operators having a single
vector or scalar argument as appropriate.  Valid combinations of 
operator and argument, and the type of the result are shown in table~\ref{vvecttable}.


\begin{table}
\begin{center}
\begin{tabular}{rcl}
s & := & div ({\bf v})  \\
{\bf v} & := & grad(s) \\
{\bf v} & := & curl({\bf v})  \\
{\bf v} & := & delsq({\bf v}) \\
 s  & := & delsq(s) \\
{\bf v} & := & {\bf v}  dotgrad {\bf v}  \\
 s & := & {\bf v}  dotgrad  s 
\end{tabular}
\end{center}
\caption{ORTHOVEC valid combinations of operator and argument}\label{vvecttable}
\end{table}

All other combinations of operator and argument type cause error
messages to be issued.  The differential operators have their usual
meanings~\cite{Speigel:59}.  The coordinate system used by these operators is
set by invoking  VSTART (cf. Sec.~\ref{vstart}).  The names {\tt h1}, 
{\tt h2}  and {\tt h3 } are
reserved for the scale factors, and {\tt u1}, {\tt u2} and {\tt u3} are 
used for the coordinates.

A vector extension, VDF, of the REDUCE procedure DF allows the 
differentiation of a vector (scalar) with respect to a scalar to be
performed.  Allowed forms are \ttindex{VDF}
VDF({\bf v}, s)  $\rightarrow$  {\bf v}   and
VDF(s, s)  $\rightarrow$   s , 
where, for example\\
\begin{eqnarray*}
{\tt vdf( B,x)} \equiv \frac{\partial {\bf B}}{\partial x}
\end{eqnarray*}

The standard REDUCE procedures DEPEND and NODEPEND have been redefined
to allow dependences of vectors to be compactly
defined.  For example \index{DEPEND statement} \index{NODEPEND statement}
\begin{verbatim}
a := svec(a1,a2,a3)$;
depend a,x,y;
\end{verbatim}
causes all three components {\tt a1},{\tt a2} and {\tt a3} of {\tt a} 
to be treated as functions of {\tt x} and {\tt y}.
Individual component dependences can still be defined if desired.
\begin{verbatim}
depend a3,z;
\end{verbatim}

The procedure VTAYLOR gives truncated Taylor series expansions of scalar
or vector functions:- \ttindex{VTAYLOR}
\begin{verbatim}
vtaylor(vex,vx,vpt,vorder);
\end{verbatim}
returns the series expansion of the expression 
VEX  with respect to variable VX \ttindex{VORDER}
about point VPT  to order VORDER.  Valid
combinations of argument types are shown in table~\ref{ORTHOVEC:validexp}. \\

\begin{table}
\begin{center}
\begin{tabular}{cccc}
VEX & VX & VPT &  VORDER \\[2ex]
{\bf v} & {\bf v} &  {\bf v} &  {\bf v}\\
{\bf v} &  {\bf v} & {\bf v} & s\\
{\bf v} & s & s & s \\
s & {\bf v} &  {\bf v} & {\bf v}   \\
s & {\bf v} & {\bf v} & s\\
s & s & s & s\\
\end{tabular}
\end{center}
\caption{ORTHOVEC valid combination of argument types.}\label{ORTHOVEC:validexp}
\end{table}

Any other combinations cause error messages to be issued.  Elements of
VORDER must be non-negative integers, otherwise error messages are
issued.  If scalar VORDER is given for a vector expansion, expansions
in each component are truncated at the same order, VORDER.

The new version of Taylor expansion applies \index{L'H\^opital's rule}
L'H\^opital's rule in evaluating coefficients, so handle cases such as
$\sin(x) / (x) $ , etc.  which the original version of ORTHOVEC could
not. The procedure used for this is LIMIT, \ttindex{LIMIT} which can
be used directly to find the limit of a scalar function {\tt ex} of
variable {\tt x} at point {\tt pt}:-

\begin{verbatim}
ans := limit(ex,x,pt);
\end{verbatim}

\section{Integral Operations}
Definite and indefinite vector, volume and scalar line integration
procedures are included in ORTHOVEC.  They are defined as follows:
\ttindex{VINT} \ttindex{DVINT}
\ttindex{VOLINT} \ttindex{DVOLINT} \ttindex{LINEINT} \ttindex{DLINEINT}
\begin{eqnarray*}
{\rm VINT} ({\bf v},x) & = & \int {\bf v}(x)dx\\
%
{\rm DVINT} ({\bf v},x, a, b) & = & \int^b_a {\bf v} (x) dx\\
%
{\rm VOLINT} ({\bf v}) & = & \int {\bf v} h_1 h_2 h_3 du_1 du_2 du_3\\
%
{\rm DVOLINT}({\bf v},{\bf l},{\bf u},n) & = & \int^{\bf u}_{\bf l}
{\bf v} h_1 h_2 h_3 du_1 du_2 du_3\\
%
{\rm LINEINT} ({\bf v, \omega}, t) & = & \int {\bf v} \cdot {\bf dr}
\equiv \int v_i h_i \frac{\partial \omega_i}{\partial t} dt\\
%
{\rm DLINEINT} ({\bf v, \omega} t, a, b) & = & \int^b_a v_i h_i
\frac{\partial \omega_i}{\partial t} dt\\
\end{eqnarray*}

In the vector and volume integrals, ${\bf v}$ are vector or scalar,
$a, b,x$ and $n$ are scalar.  Vectors ${\bf l}$ and ${\bf u}$ contain
expressions for lower and upper bounds to the integrals.  The integer
index $n$ defines the order in which the integrals over $u_1, u_2$ and
$u_3$ are performed in order to allow for functional dependencies in
the integral bounds:

\begin{center} 
\begin{tabular}{ll}
n & order\\ 1 & $u_1~u_2~u_3$\\
%
2 & $u_3~u_1~u_2$\\
%
3 & $u_2~u_3~u_1$\\
%
4 & $u_1~u_3~u_2$\\
%
5 & $u_2~u_1~u_3$\\ otherwise & $u_3~u_2~u_1$\\
\end{tabular}
\end{center}


The vector ${\bf \omega}$ in the line integral's arguments contain
explicit paramterisation of the coordinates $u_1, u_2, u_3$ of the
line ${\bf u}(t)$ along which the integral is taken.

\begin{table}
\begin{center}
\begin{tabular}{|l c l|} \hline 
\multicolumn{1}{|c}{Procedures} & & \multicolumn{1}{c|}{Description} \\ \hline
VSTART & & select coordinate
system \\ & & \\ SVEC & & set up a vector \\ VOUT & & output a vector
\\ VECTORCOMPONENT & \_ & extract a vector component (1-3) \\ & & \\
VECTORADD & + & add two vectors or scalars \\ 
VECTORPLUS & + & unary vector or scalar plus\\ 
VECTORMINUS & - & unary vector or scalar minus\\ 
VECTORDIFFERENCE & - & subtract two vectors or scalars \\ 
VECTORQUOTIENT & / & vector divided by scalar \\ 
VECTORRECIP & / & unary vector or scalar division \\ & & \ \ \ (reciprocal)\\ 
VECTORTIMES & * & multiply vector or scalar by \\ & & \ \ \ vector/scalar \\ 
VECTORCROSS & $><$ & cross product of two vectors \\ 
VECTOREXPT & \^{} & exponentiate vector modulus or scalar \\
VMOD & & length of vector or scalar \\ \hline
\end{tabular}
\end{center}
\caption{Procedures names and operators used in ORTHOVEC (part 1)}
\end{table}

\begin{table}
\begin{center}
\begin{tabular}{|l l|} \hline 
\multicolumn{1}{|c}{Procedures} & \multicolumn{1}{c|}{Description} \\ \hline 
DIV & divergence of vector \\ 
GRAD & gradient of scalar \\ 
CURL & curl of vector \\ 
DELSQ & laplacian of scalar or vector \\ 
DOTGRAD & (vector).grad(scalar or vector) \\ &  \\ 
VTAYLOR & vector or scalar Taylor series of vector or scalar \\ 
VPTAYLOR & vector or scalar Taylor series of scalar \\ 
TAYLOR & scalar Taylor series of scalar \\
LIMIT & limit of quotient using L'H\^opital's rule \\ &  \\
VINT & vector integral \\ 
DVINT & definite vector integral \\ 
VOLINT & volume integral \\ 
DVOLINT & definite volume integral \\ 
LINEINT & line integral \\ 
DLINEINT & definite line integral \\  & \\
MAPRIN & vector extension of REDUCE MAPRIN \\
DEPEND & vector extension of REDUCE DEPEND \\
NODEPEND & vector extension of REDUCE NODEPEND \\ \hline 
\end{tabular}
\end{center}
\caption{Procedures names and operators used in ORTHOVEC (part 2)}
\end{table}


\section{Test Cases}

To use the REDUCE source version of ORTHOVEC, initiate a REDUCE
session and then IN the file {\em orthovec.red} containing ORTHOVEC.
However, it is recommended that for efficiency a compiled fast loading
version be made and LOADed when required (see Sec.~18 of the REDUCE
manual).  If coordinate dependent differential and integral operators
other than cartesian are needed, then VSTART must be used to reset
coordinates and scale factors.

Six  simple examples are given in the Test Run Output file 
{\em orthovectest.log} to illustrate the working of ORTHOVEC.  
The input lines were taken from the file
{\em orthovectest.red} (the Test Run Input), but could 
equally well be typed in at the Terminal.

\example\index{ORTHOVEC package ! example}

Show that
\begin{eqnarray*}
({\bf a}  \times {\bf b}) \cdot ({\bf c} \times {\bf d}) - ({\bf a} 
\cdot {\bf c})({\bf b} \cdot {\bf d})
 + ({\bf a} \cdot {\bf d})({\bf b} \cdot {\bf c}) \equiv 0
\end{eqnarray*}
 
\example\index{ORTHOVEC package ! example}\label{ORTHOVEC:eqm}

Write the equation of motion
\begin{eqnarray*}
\frac{\partial {\bf v}}{\partial t} + {\bf v} \cdot {\bf \nabla v} 
+ {\bf \nabla} p - curl ({\bf B}) \times {\bf B}
\end{eqnarray*}
in cylindrical coordinates.

\example\index{ORTHOVEC package ! example}\label{ORTHOVEC:taylor}

Taylor expand
\begin{itemize}
\item $\sin(x) \cos(y) +e^z$
about the point $(0,0,0)$ to third order in $x$, fourth order in $y$ and
fifth order in $z$.

\item $\sin(x)/x$ about $x$ to fifth order.

\item ${\bf v}$ about ${\bf x}=(x,y,z)$ to fifth order, where
${\bf v} = (x/ \sin(x),(e^y-1)/y,(1+z)^{10})$.
\end{itemize}

\example\index{ORTHOVEC package ! example}

Obtain the second component of the equation of motion in
example~\ref{ORTHOVEC:eqm}, and the first component of the final
vector Taylor series in example~\ref{ORTHOVEC:taylor}.

\example\index{ORTHOVEC package ! example}

Evaluate the line integral 
\begin{eqnarray*}
\int^{{\bf r}_2}_{{\bf r}_1} {\bf A} \cdot d{\bf r}
\end{eqnarray*}
from point ${\bf r}_1 = (1,1,1)$ to point
${\bf r}_2 = (2,4,8)$ along the path $(x,y,z) = (s, s^2, s^3)$ where\\
\begin{eqnarray*}
{\bf A} = (3x^2 + 5y) {\bf i} - 12xy{\bf j} + 2xyz^2{\bf k}
\end{eqnarray*}
and $({\bf i, j, k})$ are unit vectors in the ($x,y,z$) directions.

\example\index{ORTHOVEC package ! example}

Find the volume $V$ common to the intersecting cylinders $x^2 + y^2 
= r^2$ and $x^2 + z^2 = r^2$ i.e. evaluate
\begin{eqnarray*}
V = 8 \int^r_0 dx \int^{ub}_0 dy \int^{ub}_0 dz
\end{eqnarray*}
where $ub = \overline{\sqrt { r^2 - x^2}}$
\bibliography{orthovec}
\bibliographystyle{plain}
\end{document}

Added r34.1/doc/reduce.sty version [cde0bdb40e].





































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%         The REDUCE Style option File --- LaTeX version.              %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% The document should start with:
%   \documentstyle[11pt,reduce,makeidx]{...}
%
% This style adds the following commands:
%    \COMPATNOTE{...}           For compatibility notes.
%    \f{...}                    Sets function name is \tt.
%    \k{...}                    Sets BNF keyword bold.
%    \REDUCE                    REDUCE when needed as a word.
%    \RLISP                     RLISP when needed as a word.
%    \s{...}                    Sets BNF sentential form \em in <...>
%    \meta                      An alternative for BNF italics in <...>
%    \ttindex{...}              Puts index entry in \tt font.
%
%
%
% Basic religion about REDUCE documentation. No paragraph indentation,
% bigger skip between lines, ragged bottom, and not as much vertical
% space.
%% RmS: setup of size dependent parameters. 11pt is assumed, so let's force it.

\typeout{Document style option `reduce' -- released 5 Nov 1991.}

%  ****************************************
%  *               FONTS                  *
%  ****************************************
%
 
\lineskip 1pt            % \lineskip is 1pt for all font sizes.
\normallineskip 1pt
\def\baselinestretch{1}
 
% Each size-changing command \SIZE executes the command
%        \@setsize\SIZE{BASELINESKIP}\FONTSIZE\@FONTSIZE
% where:
%   BASELINESKIP = Normal value of \baselineskip for that size. (Actual 
%                  value will be \baselinestretch * BASELINESKIP.)
%
%  \FONTSIZE     = Name of font-size command.  The currently available
%                  (preloaded) font sizes are: \vpt (5pt), \vipt (6pt),
%                  \viipt (etc.), \viiipt, \ixpt, \xpt, \xipt, \xiipt,
%                  \xivpt, \xviipt, \xxpt, \xxvpt.
%  \@FONTSIZE    = The same as the font-size command except with an
%                  '@' in front---e.g., if \FONTSIZE = \xivpt then
%                  \@FONTSIZE = \@xivpt.
%
% For reasons of efficiency that needn't concern the designer,
% the document style defines \@normalsize instead of \normalsize.  This
% is done only for \normalsize, not for any other size-changing
% commands.
 
\def\@normalsize{\@setsize\normalsize{13.6pt}\xipt\@xipt
\abovedisplayskip .5\baselineskip
\belowdisplayskip \abovedisplayskip
\abovedisplayshortskip  \z@ plus3\p@   
\belowdisplayshortskip  6.5\p@ plus3.5\p@ minus3\p@
\let\@listi\@listI}   % Setting of \@listi added 9 Jun 87
 
\def\small{\@setsize\small{12pt}\xpt\@xpt
\abovedisplayskip .5\baselineskip
\belowdisplayskip \abovedisplayskip
\abovedisplayshortskip  \z@ plus3\p@   
\belowdisplayshortskip  6\p@ plus3\p@ minus3\p@
\def\@listi{\leftmargin\leftmargini %% Added 22 Dec 87
\topsep \z@\parsep 3\p@ plus2\p@ minus\p@
\itemsep .5\baselineskip}}
 
\def\footnotesize{\@setsize\footnotesize{11pt}\ixpt\@ixpt
\abovedisplayskip .5\baselineskip
\belowdisplayskip \abovedisplayskip
\abovedisplayshortskip \z@ plus\p@
\belowdisplayshortskip 4\p@ plus2\p@ minus2\p@
\def\@listi{\leftmargin\leftmargini %% Added 22 Dec 87
\topsep \z@ \parsep 2\p@ plus\p@ minus\p@
\itemsep .5\baselineskip}}
 
\def\scriptsize{\@setsize\scriptsize{9.5pt}\viiipt\@viiipt}
\def\tiny{\@setsize\tiny{7pt}\vipt\@vipt}
\def\large{\@setsize\large{14pt}\xiipt\@xiipt}
\def\Large{\@setsize\Large{18pt}\xivpt\@xivpt}
\def\LARGE{\@setsize\LARGE{22pt}\xviipt\@xviipt}
\def\huge{\@setsize\huge{25pt}\xxpt\@xxpt}
\def\Huge{\@setsize\Huge{30pt}\xxvpt\@xxvpt}
 
\normalsize  % Choose the normalsize font.
 

%  ****************************************
%  *            PAGE LAYOUT               *
%  ****************************************
%
% All margin dimensions measured from a point one inch from top and side
% of page.  
 
% SIDE MARGINS:
\if@twoside               % Values for two-sided printing:
   \oddsidemargin 36pt    %   Left margin on odd-numbered pages.
   \evensidemargin 74pt   %   Left margin on even-numbered pages.
   \marginparwidth 100pt  %   Width of marginal notes.
\else                     % Values for one-sided printing:
   \oddsidemargin 54pt    %   Note that \oddsidemargin = \evensidemargin
   \evensidemargin 54pt
   \marginparwidth 83pt 
\fi
\marginparsep 10pt        % Horizontal space between outer margin and 
                          % marginal note
 
 
% VERTICAL SPACING:        
                         % Top of page:
\topmargin 27pt          %    Nominal distance from top of page to top
                         %    of box containing running head.
\headheight 12pt         %    Height of box containing running head.
\headsep 25pt            %    Space between running head and text.
% \topskip = 10pt        %    '\baselineskip' for first line of page.
                         % Bottom of page:
\footskip 30pt           %    Distance from baseline of box containing
                         %    foot to baseline of last line of text.
 
% DIMENSION OF TEXT:
% 24 Jun 86: changed to explicitly compute \textheight to avoid
% roundoff.  The value of the multiplier was calculated as the floor of
% the old \textheight minus \topskip, divided by \baselineskip for
% \normalsize.  The old value of \textheight was 530.4pt.
% \textheight is the height of text (including footnotes and figures, 
% excluding running head and foot).
 
\textheight = 38\baselineskip
\advance\textheight by \topskip
\textwidth 360pt         % Width of text line.
                         % For two-column mode: 
\columnsep 10pt          %    Space between columns 
\columnseprule 0pt       %    Width of rule between columns.
 
% A \raggedbottom command causes 'ragged bottom' pages: pages set to
% natural height instead of being stretched to exactly \textheight.
 
% FOOTNOTES:
 
\footnotesep 7.7pt    % Height of strut placed at the beginning of every
                      % footnote = height of normal \footnotesize strut,
                      % so no extra space between footnotes.
 
\skip\footins 10pt plus 4pt minus 2pt  % Space between last line of text
                                       % and  top of first footnote.
 
% FLOATS: (a float is something like a figure or table)
%
%  FOR FLOATS ON A TEXT PAGE:
%
%    ONE-COLUMN MODE OR SINGLE-COLUMN FLOATS IN TWO-COLUMN MODE:
\floatsep 12pt plus 2pt minus 2pt        % Space between adjacent floats
                                         % moved to top or bottom of
                                         % text page.
\textfloatsep 20pt plus 2pt minus 4pt    % Space between main text and
                                         % floats at top or bottom of
                                         % page.
\intextsep 12pt plus 2pt minus 2pt       % Space between in-text figures
                                         % and text.
\@maxsep 20pt                            % The maximum of \floatsep, 
                                         % \textfloatsep and \intextsep
                                         % (minus the stretch and
                                         % shrink).
%    TWO-COLUMN FLOATS IN TWO-COLUMN MODE:
\dblfloatsep 12pt plus 2pt minus 2pt     % Same as \floatsep for
                                         % double-column figures in
                                         % two-column mode.
\dbltextfloatsep 20pt plus 2pt minus 4pt % \textfloatsep for
                                         % double-column floats.
\@dblmaxsep 20pt                         % The maximum of \dblfloatsep
                                         % and \dbltexfloatsep.
 
%  FOR FLOATS ON A SEPARATE FLOAT PAGE OR COLUMN:
%    ONE-COLUMN MODE OR SINGLE-COLUMN FLOATS IN TWO-COLUMN MODE:
\@fptop 0pt plus 1fil    % Stretch at top of float page/column. (Must
                         % be 0pt plus ...)
\@fpsep 8pt plus 2fil    % Space between floats on float page/column.
\@fpbot 0pt plus 1fil    % Stretch at bottom of float page/column. (Must
                         % be 0pt plus ... )
 
%   DOUBLE-COLUMN FLOATS IN TWO-COLUMN MODE.
\@dblfptop 0pt plus 1fil % Stretch at top of float page. (Must be 0pt
                         % plus ...)
\@dblfpsep 8pt plus 2fil % Space between floats on float page.
\@dblfpbot 0pt plus 1fil % Stretch at bottom of float page. (Must be 
                         % 0pt plus ... )
% MARGINAL NOTES:
%
\marginparpush 5pt       % Minimum vertical separation between two
                         % marginal notes.
 

%  ****************************************
%  *           PARAGRAPHING               *
%  ****************************************
%
\parskip 6pt plus 1pt     %% RmS   % Extra vertical space between
                                   % paragraphs.
\parindent 0pt            %% RmS   % Width of paragraph indentation.
\topsep 0pt               %% RmS   % Extra vertical space, in addition
                                   % to \parskip, added above and below
                                   % list and paragraphing environments.
\partopsep 0pt            %% RmS   % Extra vertical space, in addition
                                   % to \parskip and \topsep, added when
                                   % user leaves blank line before
                                   % environment.
\itemsep \topsep          %% RmS   % Extra vertical space, in addition
                                   % to \parskip, added between list
                                   % items.
% See \@listI for values of \topsep and \itemsep
 
% The following page-breaking penalties are defined
 
\@lowpenalty   51      % Produced by \nopagebreak[1] or \nolinebreak[1]
\@medpenalty  151      % Produced by \nopagebreak[2] or \nolinebreak[2]
\@highpenalty 301      % Produced by \nopagebreak[3] or \nolinebreak[3]
 
\@beginparpenalty -\@lowpenalty    % Before a list or paragraph
                                   % environment.
\@endparpenalty   -\@lowpenalty    % After a list or paragraph
                                   % environment.
\@itempenalty     -\@lowpenalty    % Between list items.
 
% \clubpenalty         % 'Club line'  at bottom of page.
% \widowpenalty        % 'Widow line' at top of page.
% \displaywidowpenalty % Math display widow line.
% \predisplaypenalty   % Breaking before a math display.
% \postdisplaypenalty  % Breaking after a math display.
% \interlinepenalty    % Breaking at a line within a paragraph.
% \brokenpenalty       % Breaking after a hyphenated line.
 

%    ****************************************
%    *             SECTIONS                 *
%    ****************************************
%
 
% \@startsection {NAME}{LEVEL}{INDENT}{BEFORESKIP}{AFTERSKIP}{STYLE} 
%            optional * [ALTHEADING]{HEADING}
%    Generic command to start a section.  
%    NAME       : e.g., 'subsection'
%    LEVEL      : a number, denoting depth of section -- i.e.,
%                 section=1, subsection = 2, etc.  A section number will
%                 be printed if and only if LEVEL < or = the value of
%                 the secnumdepth counter.
%    INDENT     : Indentation of heading from left margin
%    BEFORESKIP : Absolute value = skip to leave above the heading.  
%                 If negative, then paragraph indent of text following 
%                 heading is suppressed.
%    AFTERSKIP  : if positive, then skip to leave below heading,
%                       else - skip to leave to right of run-in heading.
%    STYLE      : commands to set style
%  If '*' missing, then increments the counter.  If it is present, then
%  there should be no [ALTHEADING] argument.  A sectioning command
%  is normally defined to \@startsection + its first six arguments.
 
\def\section{\@startsection {section}{1}{\z@}{-3.5ex plus-1ex minus
    -.2ex}{2.3ex plus.2ex}{\reset@font\Large\bf}}
\def\subsection{\@startsection{subsection}{2}{\z@}{-3.25ex plus-1ex
     minus-.2ex}{1.5ex plus.2ex}{\reset@font\large\bf}}
\def\subsubsection{\@startsection{subsubsection}{3}{\z@}{-3.25ex plus
     -1ex minus-.2ex}{1.5ex plus.2ex}{\reset@font\normalsize\bf}}
\def\paragraph{\@startsection
     {paragraph}{4}{\z@}{3.25ex plus1ex minus.2ex}{-1em}{\reset@font
     \normalsize\bf}}
\def\subparagraph{\@startsection
     {subparagraph}{4}{\parindent}{3.25ex plus1ex minus
     .2ex}{-1em}{\reset@font\normalsize\bf}}
 
 
% Default initializations of \...mark commands.  (See below for their
% use in defining page styles.
%
 
% \def\sectionmark#1{}           % Preloaded definitions
% \def\subsectionmark#1{}
% \def\subsubsectionmark#1{}
% \def\paragraphmark#1{}
% \def\subparagraphmark#1{}
 
% The value of the counter secnumdepth gives the depth of the
% highest-level sectioning command that is to produce section numbers.
%
 
\setcounter{secnumdepth}{3}
 
% APPENDIX
%
% The \appendix command must do the following:
%    -- reset the section and subsection counters to zero
%    -- redefine the section counter to produce appendix numbers
%    -- redefine the \section command if appendix titles and headings
%       are to look different from section titles and headings.
 
\def\appendix{\par
  \setcounter{section}{0}
  \setcounter{subsection}{0}
  \def\thesection{\Alph{section}}}
 

%    ****************************************
%    *                LISTS                 *
%    ****************************************
%
 
% The following commands are used to set the default values for the list
% environment's parameters. See the LaTeX manual for an explanation of
% the meanings of the parameters.  Defaults for the list environment are
% set as follows.  First, \rightmargin, \listparindent and \itemindent
% are set to 0pt.  Then, for a Kth level list, the command \@listK is
% called, where 'K' denotes 'i', 'ii', ... , 'vi'.  (I.e., \@listiii is
% called for a third-level list.)  By convention, \@listK should set
% \leftmargin to \leftmarginK.
%
 
\leftmargini 2.5em
\leftmarginii 2.2em     % > \labelsep + width of '(m)'
\leftmarginiii 1.87em   % > \labelsep + width of 'vii.'
\leftmarginiv 1.7em     % > \labelsep + width of 'M.'
\leftmarginv 1em
\leftmarginvi 1em
 
\leftmargin\leftmargini
\labelsep .5em
\labelwidth\leftmargini\advance\labelwidth-\labelsep
%\parsep 4.5pt plus 2pt minus 1pt  %(Removed 9 Jun 87)
 
% \@listI defines top level and \@listi values of
% \leftmargin, \topsep, \parsep, and \itemsep
% (Added 9 Jun 87)
\def\@listI{\leftmargin\leftmargini \parsep 4.5\p@ plus2\p@ minus\p@
\topsep \z@ \itemsep \topsep}
 
\let\@listi\@listI
\@listi 
 
\def\@listii{\leftmargin\leftmarginii
   \labelwidth\leftmarginii\advance\labelwidth-\labelsep
   \topsep \z@ \itemsep \topsep
   \parsep 2\p@ plus\p@ minus\p@}
 
\def\@listiii{\leftmargin\leftmarginiii
    \labelwidth\leftmarginiii\advance\labelwidth-\labelsep
    \topsep \z@ \itemsep \topsep
    \parsep \z@ \partopsep\z@}
 
\def\@listiv{\leftmargin\leftmarginiv
     \labelwidth\leftmarginiv\advance\labelwidth-\labelsep}
 




%% RmS: which at the same time makes the vertical space in lists (verbatim...)
%% too large if not other precautions are taken.
\setlength{\parindent}{0pt}
\setlength{\parskip}{6pt}
\raggedbottom


% Various boxes.
\newlength{\reduceboxwidth}
\setlength{\reduceboxwidth}{4in}

\newlength{\redboxwidth}
\setlength{\redboxwidth}{3.5in}

\newlength{\rboxwidth}
\setlength{\rboxwidth}{2.6in}

% These are here in case the name changes or we someday want a special
% font.
\newcommand{\REDUCE}{REDUCE}
\newcommand{\RLISP}{RLISP}

% This is useful for putting function names in \tt format in the index.
\newcommand{\ttindex}[1]{\index{#1@{\tt #1}}}

% Use this when you are speaking about problems across systems.
\newcommand{\COMPATNOTE}{{\em Compatibility Note:\ }}

\pagestyle{headings}

%% For BNF notation.

% \s{...} is a sentential form in descriptions. Enclosed \em text in <...>
\newcommand{\s}[1] {$<${\em #1}$>$}

% \meta{...} is an alternative sentential form in descriptions using \it.
\newcommand{\meta}[1]{\mbox{$\langle$\it#1\/$\rangle$}}

% \k{...} is a keyword. Just do in bold for the moment.
\newcommand{\k}[1] {{\bf #1}}

% \f is a function name. Just do this as tt.
\newcommand{\f}[1] {{\tt #1}}

% An example macro for numbering and indenting examples.
\newcounter{examplectr}
\newcommand{\example}{\refstepcounter{examplectr}
\noindent{\bf Example \theexamplectr}}

% The following are currently only used in the GENTRAN document.  However,
% there's no objection to using them elsewhere.

\begingroup
  \catcode `|=0
  \catcode `[= 1
  \catcode`]=2
  \catcode `\{=12
  \catcode `\}=12
  \catcode`\\=12
  |gdef|@xframedverbatim#1\end{framedverbatim}[#1|end[framedverbatim]]
  |gdef|@sxframedverbatim#1\end{framedverbatim*}[#1|end[framedverbatim*]]
|endgroup

\newdimen\@mcdheight 

\def\@sframedverbatim{\obeyspaces\@framedverbatim}

\def\@mcdrule{\@mcdheight=\baselineskip\advance\@mcdheight by-2pt
\setbox0=\hbox{\vrule height\@mcdheight depth 2pt width 1pt}%
\ht0=\@mcdheight\dp0=0pt\wd0=1pt\box0} 

\def\@mcdendrule{\@mcdheight=\baselineskip%
\setbox0=\hbox{\vrule height\@mcdheight depth 2pt width 1pt}%
\ht0=\@mcdheight\dp0=0pt\wd0=1pt\box0} 

\def\@framedverbatim{\trivlist \item[]
\parskip \z@
\hrule \@height \p@ \@depth \z@ \@width\textwidth
\everypar{\global \@minipagefalse \global \@newlistfalse \if@inlabel
\global \@inlabelfalse \hskip -\parindent \box \@labels \penalty \z@ \fi
\hbox to6\p@{\rlap{\@mcdrule}\hskip\textwidth\llap{\@mcdrule}\hss}}%
\if@minipage\else\vskip\parskip\fi 
\leftskip\@totalleftmargin\rightskip\z@
\parindent\z@\parfillskip\@flushglue\parskip\z@
\@tempswafalse \def\par{\if@tempswa\hbox{}\fi\@tempswatrue\@@par
\penalty\interlinepenalty}%   % fix \samepage bug   
\obeylines \tt \catcode``=13 \@noligs \let\do\@makeother \dospecials}
 
\def\framedverbatim{\@framedverbatim \frenchspacing\@vobeyspaces
                    \@xframedverbatim}

\def\endframedverbatim{\nointerlineskip
{\everypar{}\baselineskip 4\p@\vbox to4\p@{\par\noindent\hbox
      to6pt{\rlap{\@mcdendrule}\hskip\textwidth\llap{\@mcdendrule}\hss}}%
\vskip\p@\hrule \@height \p@ \@depth \z@ \@width\textwidth}\endtrivlist}

\@namedef{framedverbatim*}{\@framedverbatim\@sxframedverbatim}

\expandafter\let\csname endframedverbatim*\endcsname =\endtrivlist

% Will print out a heading in bold, and then indent the following text.
\def\indented{\list{}{
 \itemindent\listparindent 
 \rightmargin\leftmargin}\item[]} 
\let\endindented=\endlist
\newenvironment{describe}[1]{\par{\bf #1}\begin{indented}}{\end{indented}}

\@ifundefined{reset@font}{\let\reset@font\@empty}{}

\endinput

Added r34.1/doc/reduce.tex version [e6e5bf492b].





































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
6503
6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
6612
6613
6614
6615
6616
6617
6618
6619
6620
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
6666
6667
6668
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
6687
6688
6689
6690
6691
6692
6693
6694
6695
6696
6697
6698
6699
6700
6701
6702
6703
6704
6705
6706
6707
6708
6709
6710
6711
6712
6713
6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
6729
6730
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744
6745
6746
6747
6748
6749
6750
6751
6752
6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
6807
6808
6809
6810
6811
6812
6813
6814
6815
6816
6817
6818
6819
6820
6821
6822
6823
6824
6825
6826
6827
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
6858
6859
6860
6861
6862
6863
6864
6865
6866
6867
6868
6869
6870
6871
6872
6873
6874
6875
6876
6877
6878
6879
6880
6881
6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
6901
6902
6903
6904
6905
6906
6907
6908
6909
6910
6911
6912
6913
6914
6915
6916
6917
6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945
6946
% The REDUCE User's Manual --- LaTeX version.
% To create this manual, the following steps are recommended:
% latex reduce
% makeindex reduce
% latex reduce
% latex reduce     --- this is probably not necessary.

\documentstyle[11pt,makeidx]{book}

\parindent 0pt

\parskip 6pt

\raggedbottom

\newlength{\reduceboxwidth}
\setlength{\reduceboxwidth}{4in}

\newlength{\redboxwidth}
\setlength{\redboxwidth}{3.5in}

\newlength{\rboxwidth}
\setlength{\rboxwidth}{2.6in}

\newcommand{\REDUCE}{REDUCE}
\newcommand{\RLISP}{RLISP}
\newcommand{\ttindex}[1]{\index{#1@{\tt #1}}}
\newcommand{\COMPATNOTE}{{\em Compatibility Note:\ }}

% Close up default vertical spacings:
\setlength{\topsep}{0.5\baselineskip}  % above and below environments
\setlength{\itemsep}{\topsep}
\setlength{\abovedisplayskip}{\topsep}  % for "long" equations
\setlength{\belowdisplayskip}{\topsep}

\pagestyle{headings}

\makeindex

\begin{document}
\pagestyle{empty}
\begin{titlepage}
\vspace*{\fill}
\begin{center}

{\Huge\bf {\REDUCE}} \\[0.2cm]
{\LARGE\bf User's Manual\vspace{0.4cm} \\
  Version 3.4}

\vspace{0.5in}\large\bf

Anthony C.\ Hearn \\
RAND \\
Santa Monica, CA 90407-2138

\vspace{0.1in}

\bf Email: reduce@rand.org

\vspace{0.5in}

\large\bf July 1991

\vspace*{2.5in}

\bf RAND Publication CP78 (Rev. 7/91)
\end{center}
\end{titlepage}

\newpage
\vspace*{3.0in}
\noindent Copyright \copyright 1991 RAND.  All rights reserved. \\

\noindent Registered system holders may reproduce all or any part of this
publication for internal purposes, provided that the source of the
material is clearly acknowledged, and the copyright notice is retained.

\pagestyle{headings}
\setcounter{page}{0}
\tableofcontents

\chapter*{Abstract}

\addcontentsline{toc}{chapter}{Abstract}

This document provides the user with a description of the algebraic
programming system {\REDUCE}.  The capabilities of this system include:
\begin{enumerate}
\item expansion and ordering of polynomials and rational functions,
\item substitutions and pattern matching in a wide variety of forms,
\item automatic and user controlled simplification of expressions,
\item calculations with symbolic matrices,
\item arbitrary precision integer and real arithmetic,
\item facilities for defining new functions and extending program syntax,
\item analytic differentiation and integration,
\item factorization of polynomials,
\item facilities for the solution of a variety of algebraic equations,
\item facilities for the output of expressions in a variety of formats,
\item facilities for generating numerical programs from symbolic input,
\item Dirac matrix calculations of interest to high energy physicists.
\end{enumerate}

\chapter*{Acknowledgment}

The production of this version of the manual has been the result of the
contributions of a large number of individuals who have taken the time and
effort to suggest improvements to previous versions, and to draft new
sections.  Particular thanks are due to Gerry Rayna, who provided a draft
rewrite of most of the first half of the manual.  Other people who have
made significant contributions have included John Fitch, Martin Griss,
Stan Kameny, Jed Marti, Herbert Melenk, Don Morrison, Arthur Norman,
Eberhard Schr\"ufer and Larry Seward.  Finally, Richard Hitt produced a {\TeX}
version of the {\REDUCE} 3.3 manual, which has been a useful guide for the
production of the {\LaTeX} version of this manual.

\chapter{Introductory Information}

\index{Introduction}{\REDUCE} is a system for carrying out algebraic
operations accurately, no matter how complicated the expressions become.
It can manipulate polynomials in a variety of forms, both expanding and
factoring them, and extract various parts of them as required.  {\REDUCE} can
also do differentiation and integration, but we shall only show trivial
examples of this in this introduction.  Other topics which are not
considered include the use of arrays, the definition of procedures and
operators, the specific routines for high energy physics calculations, the
use of files to eliminate repetitious typing and for saving results, and
the editing of the input text.

Also not considered in any detail in this introduction are the many options
that are available for varying computational procedures, output forms,
number systems used, and so on.

{\REDUCE} is designed to be an interactive system, so that the user can input
an algebraic expression and see its value before moving on to the next
calculation.  For those systems that do not support interactive use, or
for those calculations, especially long ones, for which a standard script
can be defined, {\REDUCE} can also be used in batch mode. In this case,
a sequence of commands can be given to {\REDUCE} and results obtained
without any user interaction during the computation.

In this introduction, we shall limit ourselves to the interactive use of
{\REDUCE}, since this illustrates most completely the capabilities of the
system. When {\REDUCE} is called, it begins by printing a banner message
like:
\begin{verbatim}
     REDUCE 3.4, 15-Jul-91 ...
\end{verbatim}
where the version number and the system release date will change from time
to time. It then prompts the user for input by:
\begin{verbatim}
     1:
\end{verbatim}
You can now type a {\REDUCE} statement, terminated by a semicolon to indicate
the end of the expression, for example:
\begin{verbatim}
     (x+y+z)^2;
\end{verbatim}
This expression would normally be followed by another character (a RETURN
on an ASCII keyboard) to ``wake up" the system, which would then input the
expression, evaluate it, and return the result:
\begin{verbatim}
       2                    2            2
      X  + 2*X*Y + 2*X*Z + Y  + 2*Y*Z + Z
\end{verbatim}
Let us review this simple example to learn a little more about the way that
{\REDUCE} works. First, we note that {\REDUCE} deals with variables, and
constants like other computer languages, but that in evaluating the former,
a variable can stand for itself. Expression evaluation normally follows
the rules of high school algebra, so the only surprise in the above example
might be that the expression was expanded. {\REDUCE} normally expands
expressions where possible, collecting like terms and ordering the
variables in a specific manner. However, expansion, ordering of variables,
format of output and so on is under control of the user, and various
declarations are available to manipulate these.

Another characteristic of the above example is the use of lower case on
input and upper case on output.  In fact, input may be in either mode, but
lower case is usually converted to upper case by the system, although some
versions produce output in lower case by default.  This distinction is
reflected in this manual in that all expressions intended for input will
be shown in lower case and output in upper case.  However, for stylistic
reasons, we represent all single identifiers in the text in upper case.

Finally, the numerical prompt can be used to reference the result in a
later computation.

As a further illustration of the system features, the user should try:
\begin{verbatim}
     for i:= 1:40 product i;
\end{verbatim}
The result in this case is the value of 40!,
\begin{verbatim}
     815915283247897734345611269596115894272000000000
\end{verbatim}
You can also get the same result by saying
\begin{verbatim}
     factorial 40;
\end{verbatim}
Since we want exact results in algebraic calculations, it is essential that
integer arithmetic be performed to arbitrary precision, as in the above
example. Furthermore, the {\tt FOR} statement in the above is illustrative of a
whole range of combining forms which {\REDUCE} supports for the convenience of
the user.

Among the many options in {\REDUCE} is the use of other number systems, such
as multiple precision floating point with any specified number of digits --
of use if roundoff in, say, the $100^{th}$ digit is all that can be tolerated.

In many cases, it is necessary to use the results of one calculation in
succeeding calculations. One way to do this is via an assignment for a
variable, such as
\begin{verbatim}
     u := (x+y+z)^2;
\end{verbatim}
If we now use {\tt U} in later calculations, the value of the right-hand
side of the above will be used.

The results of a given calculation are also saved in the variable
{\tt WS} \ttindex{WS} (for WorkSpace), so this can be used in the next
calculation for further processing.

For example, the expression
\begin{verbatim}
     df(ws,x);
\end{verbatim}
following the previous evaluation will calculate the derivative of
{\tt (x+y+z)\^{ }2} with respect to {\tt X}. Alternatively,
\begin{verbatim}
     int(ws,y);
\end{verbatim}
would calculate the integral of the same expression with respect to y.

{\REDUCE} is also capable of handling symbolic matrices. For example,
\begin{verbatim}
     matrix m(2,2);
\end{verbatim}
declares m to be a two by two matrix, and
\begin{verbatim}
     m := mat((a,b),(c,d));
\end{verbatim}
gives its elements values.  Expressions which include {\tt M} and make
algebraic sense may now be evaluated, such as {\tt 1/m} to give the
inverse, {\tt 2*m - u*m\^{ }2} to give us another matrix and {\tt det(m)} to
give us the determinant of {\tt M}.

{\REDUCE} has a wide range of substitution capabilities. The system knows
about elementary functions, but does not automatically invoke many of their
well-known properties. For example, products of trigonometrical functions
are not converted automatically into multiple angle expressions, but if the
user wants this, he can say, for example:
\begin{verbatim}
     (sin(a+b)+cos(a+b))*(sin(a-b)-cos(a-b))
         where cos(~x)*cos(~y) = (cos(x+y)+cos(x-y))/2,
               cos(~x)*sin(~y) = (sin(x+y)-sin(x-y))/2,
               sin(~x)*sin(~y) = (cos(x-y)-cos(x+y))/2;
\end{verbatim}
where the tilde in front of the variables {\tt X} and {\tt Y} indicates
that the rules apply for all values of those variables.
The result of this calculation is
\begin{verbatim}
        -(COS(2*A) + SIN(2*B))
\end{verbatim}
Another very commonly used capability of the system, and an illustration
of one of the many output modes of {\REDUCE}, is the ability to output
results in a FORTRAN compatible form.  Such results can then be used in a
FORTRAN based numerical calculation.  This is particularly useful as a way
of generating algebraic formulas to be used as the basis of extensive
numerical calculations.

For example, the statements
\begin{verbatim}
     on fort;
     df(log(x)*(sin(x)+cos(x))/sqrt(x),x,2);
\end{verbatim}
will result in the output
\begin{verbatim}
      ANS=(-4.*LOG(X)*COS(X)*X**2-4.*LOG(X)*COS(X)*X+3.*LOG(X)*
     . COS(X)-4.*LOG(X)*SIN(X)*X**2+4.*LOG(X)*SIN(X)*X+3.*LOG(X)
     . *SIN(X)+8.*COS(X)*X-8.*COS(X)-8.*SIN(X)*X-8.*SIN(X))/(4.*
     . SQRT(X)*X**2)
\end{verbatim}
These algebraic manipulations illustrate the algebraic mode of {\REDUCE}.
{\REDUCE} is based on Standard Lisp. A symbolic mode is also available for
executing Lisp statements. These statements follow the syntax of Lisp,
e.g.
\begin{verbatim}
  symbolic car '(a);
\end{verbatim}
Communication between the two modes is possible.

With this simple introduction, you are now in a position to study the
material in the full {\REDUCE} manual in order to learn just how extensive
the range of facilities really is.  If further tutorial material is
desired, the seven {\REDUCE} Interactive Lessons by David R. Stoutemyer are
recommended.  These are normally distributed with the system.

\chapter{Structure of Programs}

A {\REDUCE} program\index{Program structure} consists of a set of
functional commands which are evaluated sequentially by the computer.
These commands are built up from declarations, statements and expressions.
Such entities are composed of sequences of numbers, variables, operators,
strings, reserved words and delimiters (such as commas and parentheses),
which in turn are sequences of basic characters.

\section{The {\REDUCE} Standard Character Set}

\index{Character set}The basic characters which are used to build
{\REDUCE} symbols are the following:
\begin{enumerate}
\item The 26 upper case letters {\tt A} through {\tt Z}
\item The 10 decimal digits {\tt 0} through {\tt 9}
\item The special characters \_\_ ! " \$ \% ' ( ) * + , - . / : ; $<$ $>$
      = \{ \} $<$blank$>$
\end{enumerate}
Programs composed from this standard set of characters will run in any
available {\REDUCE} system.  Most implementations permit lower case on
input.  With the exception of strings and characters preceded by an
exclamation mark\index{Exclamation mark} (q.v.), such lower case
characters will be converted internally into upper case.  If you do not
wish this conversion to occur, the command {\tt off raise;} \ttindex{RAISE}
achieves this.  However, now case {\em is} distinguished internally, so
that {\tt df} is not the same as {\tt DF} (the derivative operator).
Several implementations also allow some special characters to represent
operators in the system.  The operating instructions for a particular
implementation should be consulted on these points.  For generality, we
shall limit ourselves to the standard character set in this exposition.

\section{Numbers}

\index{Number}There are several different types of numbers available in
\REDUCE.  Integers consist of a signed or unsigned sequence of decimal
digits written without a decimal point, for example:
\begin{verbatim}
        -2, 5396, +32
\end{verbatim}
In principle, there is no practical limit on the number of digits
permitted as exact arithmetic is used in most implementations. (You should
however check the specific instructions for your particular system
implementation to make sure that this is true.) For example, if you ask
for the value of $2^{2000}$ you get it
displayed as a number of 603 decimal digits, taking up nine lines of
output on an interactive display.  It should be borne in mind of course
that computations with such long numbers can be quite slow.

Numbers that aren't integers are usually represented as the quotient of
two integers, in lowest terms: that is, as rational numbers.

In essentially all versions of {\REDUCE} it is also possible (but not always
desirable!) to ask {\REDUCE} to work with floating point approximations to
numbers again, to any precision. Such numbers are called {\em real}.
\index{Real}  They can be input in two ways:
\begin{enumerate}
\item as a signed or unsigned sequence of any number of decimal digits
      with an embedded or trailing decimal point.
\item as in 1. followed by a decimal exponent which is written as the
      letter {\tt E} followed by a signed or unsigned integer.
\end{enumerate}
e.g. {\tt 32. +32.0 0.32E2} and {\tt 320.E-1} are all representations of
32.

{\it CAUTION:}  The unsigned part of any number\index{Number} may {\em not}
begin with a decimal point, as this causes confusion with the {\tt CONS} (.)
operator in symbolic mode (q.v.), i.e., NOT ALLOWED: {\tt .5  -.23  +.12};
use {\tt 0.5 -0.23 +0.12} instead.

\section{Identifiers}

Identifiers\index{Identifier} in {\REDUCE} consist of one or more
alphanumeric characters (i.e. upper case alphabetic letters or decimal
digits) the first of which must be alphabetic.  The maximum number of
characters allowed is implementation dependent, although twenty-four is
permitted in most implementations.  In addition, the underscore character
(\_) is considered a letter. For example,
\begin{verbatim}
        a az p1 q23p  a_very_long_variable
\end{verbatim}
are all identifiers.

A sequence of alphanumeric characters in which the first is a digit is
interpreted as a product.  For example, {\tt 2ab3c} is interpreted as
{\tt 2*ab3c}.  There is one exception to this:  If the first letter after a
digit is {\tt E}, the system will try to interpret that part of the
sequence as a real number\index{Real}, which may fail in some cases.  For
example, {\tt 2E12} is the real number $2.0*10^{12}$, {\tt 2e3c} is
2000.0*C, and {\tt 2ebc} gives an error.

Special characters, such as $-$, *, and blank, may be used in identifiers
too, even as the first character, but each must be preceded by an
exclamation mark in input.  For example:
\begin{verbatim}
        light!-years    d!*!*n         good! morning
        !$sign          !5goldrings
\end{verbatim}
{\it CAUTION:} Many system identifiers have such special characters in their
names (especially * and =). If the user accidentally picks the name of one
of them for his own purposes it may have catastrophic consequences for his
{\REDUCE} run.  Users are therefore advised to avoid such names.

Identifiers are used as variables, labels and to name arrays, operators
and procedures.

\subsection*{Restrictions}

The reserved words listed in another section may not be used as
identifiers.  No spaces may appear within an identifier, and an identifier
may not extend over a line of text. (Hyphenation of an identifier, by
using a reserved character as a hyphen before an end-of-line character is
possible in some versions of {\REDUCE}).

\section{Variables}

Every variable\index{Variable} is named by an identifier, and is given a
specific type.  The type is of no concern to the ordinary user.  Most
variables are allowed to have the default type, called {\em scalar}.
These can receive, as values, the representation of any ordinary algebraic
expression.  In the absence of such a value, they stand for themselves.

\subsection*{Reserved Variables}

Several variables\index{Reserved variable} in {\REDUCE} have particular
properties which should not be changed by the user.  These variables are
as follows: \\

\begin{tabular}{l r}
{\tt E} & \parbox[t]{\reduceboxwidth}{Intended to represent the base of
the natural logarithms.  LOG(E), if it occurs in an expression, is
automatically replaced by 1.  If {\tt ROUNDED} (q.v.) \ttindex{ROUNDED} is
on, E is replaced by the value of E to the current degree of floating point
precision\index{Numerical precision}.} \\ \\

{\tt I} & \parbox[t]{\reduceboxwidth}{Intended to represent the square
root of $-1$. {\tt i\^{ }2} is replaced by -1, and appropriately for higher
powers of {\tt I}. (This applies only to the symbol {\tt I} used on the top
level, not as a formal parameter in a procedure, a local variable, nor in
the context {\tt for i:= ...} .).} \\ \\

{\tt INFINITY} & \parbox[t]{\reduceboxwidth}{Intended to represent $\infty$
 \ttindex{INFINITY}
in limit and power series calculations for example.  Note however that the
current system does {\em not} do proper arithmetic on $\infty$.  For example,
{\tt infinity + infinity} is {\tt 2*infinity}.} \\ \\

{\tt NIL} & \parbox[t]{\reduceboxwidth}{In {\REDUCE} (algebraic mode only)
taken as a synonym for zero.  Therefore NIL cannot be used as a variable.} \\
\\

{\tt PI} & \parbox[t]{\reduceboxwidth}{Intended to represent the circular
constant.  With ROUNDED on,
it is replaced by the value of $\pi$ to the current
degree of floating point precision.} \\ \\

{\tt T} & \parbox[t]{\reduceboxwidth}{Should not be used as a formal
parameter or local variable in procedures, since conflict arises with the
symbolic mode meaning of T as {\em true}.} \\ \\
\end{tabular}

Using these reserved variables\index{Reserved variable} inappropriately
will lead to an error.

There are also internal variables used by {\REDUCE} that have similar
restrictions. These usually have an asterisk in their names, so it is
unlikely a casual user would use one. An example of such a variable is
{\tt K!*} used in the asymptotic command package.

Certain words are reserved in {\REDUCE}. They may only be used in the manner
intended. A list of these is given in the section ``Reserved Identifiers".
There are, of course, an impossibly large number of such names to keep in
mind. The reader may therefore want to make himself a copy of the list,
deleting the names he doesn't think he is likely to use by mistake.

\section{Strings}

Strings\index{String} are used in {\tt WRITE} statements (q.v.), in other
output statements (such as error messages), and to name files.  A string
consists of any number of characters enclosed in double quotes.  For example:
\begin{verbatim}
             "A String".
\end{verbatim}
Lower case characters within a string are not converted to upper case.

The string {\tt ""} represents the empty string.  A double quote may be
included in a string by preceding it by another double quote.  Thus
{\tt "a""b"} is the string {\tt a"b}, and {\tt """"} is the string {\tt "}.

\section{Comments}

Text can be included in program\index{Program} listings for the
convenience of human readers, in such a way that {\REDUCE} pays no
attention to it.  There are two ways to do this:

\begin{enumerate}
\item Everything from the word {\tt COMMENT}\ttindex{COMMENT} to the next
statement terminator (q.v.), normally ; or \$, is ignored.  Such comments
can be placed anywhere a blank could properly appear. (Note that {\tt END}
and $>>$ are {\em not} treated as {\tt COMMENT} delimiters!)

\item Everything from the symbol {\tt \%}\index{Percent sign} to the end
of the line on which it appears is ignored.  Such comments can be placed
as the last part of any line.  Statement terminators have no special
meaning in such comments.  Remember to put a semicolon before the {\tt \%}
if the earlier part of the line is intended to be so terminated.  Remember
also to begin each line of a multi-line {\tt \%} comment with a {\tt \%}
sign.
\end{enumerate}

\section{Operators}

Operators\index{Operator} in {\REDUCE} are specified by name and type.
There are two types, infix\index{Infix operator} and prefix.
\index{Prefix operator}  Operators can be purely abstract, just symbols
with no properties; they can have values assigned (using {\tt :=} or
simple {\tt LET} declarations) for specific arguments; they can have
properties declared for some collection of arguments (using more general
{\tt LET} declarations); or they can be fully defined (usually by a
procedure declaration).

Infix operators\index{Infix operator} have a definite precedence with
respect to one another, and normally occur between their arguments.
For example:
\begin{quote}
\begin{tabbing}
{\tt a + b - c} \hspace{1.5in} \= (spaces optional) \\
{\tt x<y and y=z} \> (spaces required where shown)
\end{tabbing}
\end{quote}
Spaces can be freely inserted between operators and variables or operators
and operators. They are required only where operator names are spelled out
with letters (such as the {\tt AND} in the example) and must be unambiguously
separated from another such or from a variable (like {\tt Y}). Wherever one
space can be used, so can any larger number.

Prefix operators occur to the left of their arguments, which are written as
a list enclosed in parentheses and separated by commas, as with normal
mathematical functions, e.g.,
\begin{verbatim}
        cos(u)
        df(x^2,x)
        q(v+w)
\end{verbatim}
Unmatched parentheses, incorrect groupings of infix operators
\index{Infix operator} and the like, naturally lead to syntax errors.  The
parentheses can be omitted (replaced by a space following the
operator\index{Operator} name) if the operator is unary and the argument
is a single symbol or begins with a prefix operator name:

\begin{quote}
\begin{tabbing}
{\tt cos y} \hspace{1.75in} \= means cos(y) \\
{\tt cos (-y)} \> -- parentheses necessary \\
{\tt log cos y} \>   means log(cos(y)) \\
{\tt log cos (a+b)} \> means log(cos(a+b))
\end{tabbing}
\end{quote}
but
\begin{quote}
\begin{tabbing}
{\tt cos a*b} \hspace{1.6in} \= means (cos a)*b \\
{\tt cos -y}  \> is erroneous (treated as a variable \\
\> ``cos" minus the variable y)
\end{tabbing}
\end{quote}
A unary prefix operator\index{Prefix operator} has a precedence
\index{Operator precedence} higher than any infix operator, including
unary infix operators. \index{Infix operator}
In other words, {\REDUCE} will always interpret {\tt cos~y + 3} as
{\tt (cos~y) + 3} rather than as {\tt cos(y + 3)}.

Infix operators may also be used in a prefix format on input, e.g.,
{\tt +(a,b,c)}.  On output, however, such expressions will always be
printed in infix form (i.e., {\tt a + b + c} for this example).

A number of prefix operators are built into the system with predefined
properties. Users may also add new operators and define their rules for
simplification. The built in operators are described in another section.

\subsection*{Built-In Infix Operators}

The following infix operators\index{Infix operator} are built into the
system.  They are all defined internally as procedures.
\begin{verbatim}
<infix operator>::= where|:=|or|and|not|member|memq|=|neq|eq|
                    >=|>|<=|<|+|-|*|/|^|**|.
\end{verbatim}
These operators may be further divided into the following subclasses:
\begin{verbatim}
   <assignment operator>   ::= :=
   <logical operator>      ::= or|and|not|member|memq
   <relational operator>   ::= =|neq|eq|>=|>|<=|<
   <substitution operator> ::= where
   <arithmetic operator>   ::= +|-|*|/|^|**
   <construction operator> ::= .
\end{verbatim}
{\tt MEMBER}, {\tt MEMQ} and {\tt EQ} are not used in the algebraic mode of
{\REDUCE}.  They are explained in the section on symbolic mode (q.v.).
{\tt WHERE} is described in the section on substitutions.

For compatibility with the intermediate language used by {\REDUCE}, each
special character infix operator\index{Infix operator} has an alternative
alphanumeric identifier associated with it.  These identifiers may be used
interchangeably with the corresponding special character names on input.
This correspondence is as follows:
\begin{quote}
\begin{tabbing}
{\tt :=      setq} \hspace{0.5in} \= (the assignment operator) \\
{\tt =       equal} \\
{\tt >=      geq} \\
{\tt >       greaterp} \\
{\tt <=      leq} \\
{\tt <       lessp} \\
{\tt +       plus} \\
{\tt -       difference} \> (if unary, {\tt minus}) \\
{\tt *       times} \\
{\tt /       quotient} \> (if unary, {\tt recip}) \\
{\tt \^{ } or ** expt} \> (raising to a power) \\
{\tt .       cons}
\end{tabbing}
\end{quote}
Note: {\tt NEQ} is used to mean {\em not equal}.  There is no special
symbol provided for it.

The above operators\index{Operator} are binary, except {\tt NOT} which is
unary and {\tt +} and {\tt *} which are nary (i.e., taking an arbitrary
number of arguments).  In addition, {\tt -} and {\tt /} may be used as
unary operators, e.g., /2 means the same as 1/2.  Any other operator is
parsed as a binary operator using a left association rule.  Thus {\tt
a/b/c} is interpreted as {\tt (a/b)/c}.  There are two exceptions to this
rule: {\tt :=} and {\tt .} are right associative.  Example: {\tt a:=b:=c}
is interpreted as {\tt a:=(b:=c)}.  Unlike ALGOL and PASCAL, {\tt \^{ }} is
left associative.

The operators\index{Operator} {\tt $<$}, {\tt $<$=}, {\tt $>$}, {\tt $>$=}
can only be used for making comparisons between numbers.  No meaning is
currently assigned to this kind of comparison between general expressions.

Parentheses may be used to specify the order of combination.  If
parentheses are omitted then this order is by the ordering of the
precedence list\index{Operator precedence} defined by the right-hand side
of the BNF definition of {\tt <infix operator>}\index{Infix operator}
above, from lowest to highest.  In other words, {\tt :=} has the lowest
precedence, and {\tt .} (the dot operator) the highest.

\chapter{Expressions}

{\REDUCE} expressions\index{Expression} may be of several types and consist
of sequences of numbers, variables, operators, left and right parentheses
and commas.  The most common types are as follows:

\section{Scalar Expressions}

\index{Scalar}Using the arithmetic operations {\tt + - * / \^{ }}
(power) and parentheses, scalar expressions are composed from numbers,
ordinary ``scalar" variables (identifiers), array names with subscripts,
operator or procedure names with arguments and statement expressions.

{\it Examples:}
\begin{verbatim}
        x
        x^3 - 2*y/(2*z^2 - df(x,z))
        (p^2 + m^2)^(1/2)*log (y/m)
        a(5) + b(i,q)
\end{verbatim}
The symbol ** may be used as an alternative to the caret symbol
(\verb+^+) for forming powers.  The particular system instructions should
be consulted to determine if this is not supported.

Statement expressions (q.v.), usually in parentheses, can also form part of
a scalar\index{Scalar} expression, as in the example
\begin{verbatim}
        w + (c:=x+y) + z .
\end{verbatim}
When the algebraic value of an expression is needed, {\REDUCE} determines it,
starting with the algebraic values of the parts, roughly as follows:

Variables and operator symbols with an argument list have the algebraic
values they were last assigned, or if never assigned stand for themselves.
However, array elements have the algebraic values they were last assigned,
or, if never assigned, are taken to be 0.

Procedures are evaluated with the values of their actual parameters.

In evaluating expressions, the standard rules of algebra are applied.
Unfortunately, this algebraic evaluation of an expression is not as
unambiguous as is numerical evaluation. This process is generally referred
to as ``simplification"\index{Simplification} in the sense that the
evaluation usually but not always produces a simplified form for the
expression.

There are many options available to the user for carrying out such
simplification\index{Simplification}.  If the user doesn't specify any
method, the default method is used.  The default evaluation of an
expression involves expansion of the expression and collection of like
terms, ordering of the terms, evaluation of derivatives and other
functions and substitution for any expressions which have values assigned
or declared (see assignments and {\tt LET} statements).  In many cases,
this is all that the user needs.

The declarations by which the user can exercise some control over the way
in which the evaluation is performed are explained in other sections.  For
example, if a real (floating point) number is encountered during
evaluation, the system will normally convert it into a ratio of two
integers.  If the user wants to use real arithmetic, he can effect this by
the command {\tt on rounded;}. \ttindex{ROUNDED} Other modes for
coefficient arithmetic are described elsewhere.

If an illegal action occurs during evaluation (such as division by zero)
or functions are called with the wrong number of arguments, and so on, an
appropriate error message is generated.
% A list of such error messages is given in an appendix.

\section{Integer Expressions}

\index{Integer}These are expressions which, because of the values of the
constants and variables in them, evaluate to whole numbers.

{\it Examples:}
\begin{verbatim}
        2,      37 * 999,       (x + 3)^2 - x^2 - 6*x
\end{verbatim}
are obviously integer expressions.
\begin{verbatim}
        j + k - 2 * j^2
\end{verbatim}
is an integer expression when {\tt J} and {\tt K} have values that are
integers, or if not integers are such that ``the variables and fractions
cancel out", as in
\begin{verbatim}
        k - 7/3 - j + 2/3 + 2*j^2.
\end{verbatim}

\section{Boolean Expressions}
\label{sec-boolean}
A boolean expression\index{Boolean} returns a truth value.  In the
algebraic mode of {\REDUCE}, boolean expressions have the syntactical form:
\begin{verbatim}
        <expression> <relational operator> <expression>
\end{verbatim}
or
\begin{verbatim}
        <boolean operator> (<arguments>)
\end{verbatim}
or
\begin{verbatim}
        <boolean expression> <logical operator>
        <boolean expression>.
\end{verbatim}
Parentheses can also be used to control the precedence of expressions.

In addition to the logical and relational operators defined earlier as
infix operators, the following boolean operators are also defined: \\ \\
\ttindex{EVENP}\ttindex{FIXP}\ttindex{FREEOF}\ttindex{NUMBERP}
\ttindex{ORDP}\ttindex{PRIMEP}
\begin{tabular}{l r}
{\tt EVENP(U)} & \parbox[t]{\redboxwidth}{determines if the number {\tt U} is
even or not;} \\ \\

{\tt FIXP(U)} & \parbox[t]{\redboxwidth}{determines if the expression {\tt U}
is integer or not;} \\ \\

{\tt FREEOF(U,V)} & \parbox[t]{\redboxwidth}{determines if the expression
{\tt U} does not contain the kernel (q.v.) {\tt V} anywhere in its
structure;} \\ \\

{\tt NUMBERP(U)} & \parbox[t]{\redboxwidth}{determines if {\tt U} is a number
or not;} \\ \\

{\tt ORDP(U,V)} & \parbox[t]{\redboxwidth}{determines if {\tt U} is ordered
ahead of {\tt V} by some canonical ordering (based on the expression structure
and an internal ordering of identifiers);} \\ \\

{\tt PRIMEP(U)} & \parbox[t]{\redboxwidth}{true if {\tt U} is a prime
object.} \\ \\
\end{tabular}

{\it Examples:}
\begin{verbatim}
        j<1
        x>0  or  x=-2
        numberp x
        fixp x and evenp x
        numberp x and x neq 0
\end{verbatim}
Boolean expressions can only appear directly within {\tt IF}, {\tt FOR},
{\tt WHILE}, and {\tt UNTIL} statements, as described in other sections.
Such expression cannot be used in place of ordinary algebraic expressions,
or assigned to a variable.

NB:  For those familiar with symbolic mode (q.v.), the meaning of some of
these operators is different in that mode.  For example, {\tt NUMBERP} is
true only for integers and reals in symbolic mode.

When two or more boolean expressions are combined with {\tt AND}, they are
evaluated one by one until a {\em false} expression is found. The rest are
not evaluated. Thus
\begin{verbatim}
        numberp x and numberp y and x>y
\end{verbatim}
does not attempt to make the {\tt x>y} comparison unless {\tt X} and {\tt Y}
are both verified to be numbers.

Similarly, evaluation of a sequence of boolean expressions connected by
{\tt OR} stops as soon as a {\em true} expression is found.

NB:  In a boolean expression, and in a place where a boolean expression is
expected, the algebraic value 0 is interpreted as {\em false}, while all
other algebraic values are converted to {\em true}.  So in algebraic mode
a procedure can be written for direct usage in boolean expressions,
returning say 1 or 0 as its value as in

\begin{verbatim}
        procedure polynomialp(u,x);
           if den(u)=1 and deg(u,x)>=1 then 1 else 0;
\end{verbatim}

One can then use this in a boolean construct, such as
\begin{verbatim}
        if polynomialp(q,z) and not polynomialp(q,y) then ...
\end{verbatim}

In addition, any procedure that does not have a defined return value
(for example, a block (q.v.) without a {\tt RETURN} statement in it)
has the boolean value {\em false}. 

\section{Equations}

Equations\index{Equation} are a particular type of expression with the syntax

\begin{verbatim}
        <expression> = <expression>.
\end{verbatim}

In addition to their role as boolean expressions, they can also be used as
arguments to several operators (e.g., {\tt SOLVE} (q.v.)), and can be
returned as values.

Under normal circumstances, the right-hand-side of the equation is evaluated
but not the left-hand-side.  If both sides are to be evaluated, the switch
{\tt EVALLHSEQP} \ttindex{EVALLHSEQP} should be turned on.

To facilitate the handling of equations, two selectors, {\tt LHS}
\ttindex{LHS} and {\tt RHS} \ttindex{RHS}, which return the left- and
right-hand sides of a equation\index{Equation} respectively, are provided.
For example,
\begin{verbatim}
        lhs(a+b=c) -> a+b
and
        rhs(a+b=c) -> c.
\end{verbatim}

\section{Proper Statements as Expressions}

Several kinds of proper statements\index{Proper statement} (q.v.) deliver
an algebraic or numeric result of some kind, which can in turn be used as
an expression or part of an expression.  For example, an assignment
statement itself has a value, namely the value assigned.  So
\begin{verbatim}
        2 * (x := a+b)
\end{verbatim}
is equal to {\tt 2*(a+b)}, as well as having the ``side-effect"\index{Side
effect} of assigning the value {\tt a+b} to {\tt X}.  In context,
\begin{verbatim}
        y := 2 * (x := a+b);
\end{verbatim}
sets {\tt X} to {\tt a+b} and {\tt Y} to {\tt 2*(a+b)}.

The sections on the various proper statement\index{Proper statement} types
indicate which of these statements are also useful as expressions.

\chapter{Lists}

A list\index{List} is an object consisting of a sequence of other objects
(including lists themselves), separated by commas and surrounded by
braces.  Examples of lists are:
\begin{verbatim}
        {a,b,c}

        {1,a-b,c=d}

        {{a},{{b,c},d},e}.
\end{verbatim}

\section{Operations on Lists}\index{List operation}

Several operators in the system return their results as lists, and a user
can create new lists using braces and commas.  To facilitate the use of
such lists, a number of operators are also available for manipulating
them. {\tt PART(<list>,n)}\ttindex{PART} for example will return the
$n^{th}$ element of a list. {\tt LENGTH}\ttindex{LENGTH} will return the
length of a list.  Several operators are also defined uniquely for lists.
For those familiar with them, these operators in fact mirror the
operations defined for Lisp lists.  These operators are as follows:

\subsection{FIRST}

This operator\ttindex{FIRST} returns the first member of a list.  An error
occurs if the argument is not a list, or the list is empty.

\subsection{SECOND}

{\tt SECOND} \ttindex{SECOND} returns the second member of a list.  An error
occurs if the argument is not a list or has no second element.

\subsection{THIRD}

This operator\ttindex{THIRD} returns the third member of a list.  An error
occurs if the argument is not a list or has no third element.

\subsection{REST}

{\tt REST} \ttindex{REST} returns its argument with the first element
removed.  An error occurs if the argument is not a list, or is empty.

\subsection{ $.$ (Cons) Operator}

This operator\ttindex{. (CONS)} adds (``conses") an expression to the
front of a list.  For example:
\begin{verbatim}
        a . {b,c}     ->   {a,b,c}.
\end{verbatim}

\subsection{APPEND}

This operator\ttindex{APPEND} appends its first argument to its second to
form a new list.
{\it Examples:}
\begin{verbatim}
        append({a,b},{c,d})     ->     {a,b,c,d}
        append({{a,b}},{c,d})   ->     {{a,b},c,d}.
\end{verbatim}

\subsection{REVERSE}

The operator {\tt REVERSE}\ttindex{REVERSE} returns its argument with the
elements in the reverse order.  It only applies to the top level list, not
any lower level lists that may occur.  Examples are:\index{List operation}
\begin{verbatim}
        reverse({a,b,c})        ->     {c,b,a}
        reverse({{a,b,c},d})    ->     {d,{a,b,c}}.
\end{verbatim}

\subsection{List Arguments of Other Operators}

If an operator other than those specifically defined for lists is given a
single argument that is a list, then the result of this operation will be
a list in which that operator is applied to each element of the list.  For
example, the result of evaluating {\tt log\{a,b,c\}} is the expression
{\tt \{LOG(A),LOG(B),LOG(C)\}}.

There are two ways to inhibit this operator distribution.  Firstly, the
switch {\tt LISTARGS}, \ttindex{LISTARGS} if on, will globally inhibit
such distribution.  Secondly, one can inhibit this distribution for a
specific operator by the declaration {\tt LISTARGP}.\ttindex{LISTARGP} For
example, with the declaration {\tt listargp log}, {\tt log\{a,b,c\}} would
evaluate to {\tt LOG(\{A,B,C\})}.

If an operator has more than one argument, no such distribution occurs.

\chapter{Statements}

A statement\index{Statement} is any combination of reserved words and
expressions, and has the syntax \index{Proper statement}
\begin{verbatim}
        <statement> ::= <expression>|<proper statement>
\end{verbatim}
A {\REDUCE} program consists of a series of commands which are statements
followed by a terminator:\index{Terminator}\index{Semicolon}
\index{Dollar sign}
\begin{verbatim}
        <terminator> ::= ;|$
\end{verbatim}
The division of the program into lines is arbitrary. Several statements
can be on one line, or one statement can be freely broken onto several
lines. If the program is run interactively, statements ending with ; or \$
are not processed until an end-of-line character is encountered. This
character can vary from system to system, but is normally the RETURN key on
an ASCII terminal. Specific systems may also use additional keys as
statement terminators.

If a statement is a proper statement\index{Proper statement}, the
appropriate action takes place.

Depending on the nature of the proper statement some result or response may
or may not be printed out, and the response may or may not depend on the
terminator used.

If a statement is an expression, it is evaluated. If the terminator is a
semicolon, the result is printed. If the terminator is a dollar sign, the
result is not printed. Because it is not usually possible to know in
advance how large an expression will be, no explicit format statements are
offered to the user. However, a variety of output declarations are
available so that the output can be produced in different forms. These
output declarations are explained in Section~\ref{sec-output}.

The following sub-sections describe the types of proper statements
\index{Proper statement} in {\REDUCE}.

\section{Assignment Statements}

These statements\index{Assignment} have the syntax
\begin{verbatim}
    <assignment statement> ::= <expression> := <expression>
\end{verbatim}
The {\tt <expression>} on the left side is normally the name of a variable, an
operator symbol with its list of arguments filled in, or an array name with
the proper number of integer subscript values within the array bounds. For
example:
\begin{quote}
\begin{tabbing}
{\tt a1 := b + c} \\
{\tt h(l,m) := x-2*y} \hspace{1in} \= (where {\tt h} is an operator) \\
{\tt k(3,5) := x-2*y} \> (where {\tt k} is a 2-dim. array)
\end{tabbing}
\end{quote}
More general assignments\index{Assignment} such as {\tt a+b := c} are also
allowed.  The effect of these is explained in the section ``Substitutions
for General Expressions".

An assignment statement causes the expression on the right-hand-side to be
evaluated.  If the left-hand-side is a variable, the value of the
right-hand-side is assigned to that unevaluated variable.  If the
left-hand-side is an operator or array expression, the arguments of that
operator or array are evaluated, but no other simplification done.  The
evaluated right-hand-side is then assigned to the resulting expression.
For example, if {\tt A} is a single-dimensional array, {\tt a(1+1) := b}
assigns the value {\tt B} to the array element {\tt a(2)}.

If a semicolon is used as the terminator when an assignment
\index{Assignment} is issued as a command (i.e. not as a part of a group
statement or procedure or other similar construct), the left-hand side
symbol of the assignment statement is printed out, followed by a ``{\tt :=}",
followed by the value of the expression on the right.

It is also possible to write a multiple assignment statement:
\index{Multiple assignment statement}
\begin{verbatim}
    <expression> := ... := <expression> := <expression>
\end{verbatim}
In this form, each {\tt <expression>} but the last is set to the value of
the last {\tt <expression>}.  If a semicolon is used as a terminator, each
expression except the last is printed followed by a ``{\tt :=}" ending
with the value of the last expression.


\subsection{Set Statement}

In some cases, it is desirable to perform an assignment in which {\em both}
the left- and right-hand sides of an assignment\index{Assignment} are
evaluated.  In this case, the {\tt SET}\ttindex{SET} statement can be used
with the syntax:

\begin{verbatim}
        SET(<expression>,<expression>);
\end{verbatim}
For example, the statements
\begin{verbatim}
        j := 23;
        set(mkid(a,j),x);
\end{verbatim}
assigns the value {\tt X} to {\tt A23}.

\section{Group Statements}

The group statement\index{Group statement} is a construct used where
{\REDUCE} expects a single statement, but a series of actions needs to be
performed.  It is formed by enclosing one or more statements (of any kind)
between the symbols {\tt $<<$} and {\tt $>>$}, separated by semicolons or
dollar signs -- it doesn't matter which.  The statements are executed one
after another.

Examples will be given in the sections on {\tt IF}\ttindex{IF} and other
types of statements in which the {\tt $<<$} \ldots {\tt $>>$} construct is
useful.

If the last statement in the enclosed group has a value, then that is also
the value of the group statement.  Care must be taken not to have a
semicolon or dollar sign after the last grouped statement, if the value of
the group is relevant: such an extra terminator causes the group to have
the value NIL or zero.

\section{Conditional Statements}

The conditional statement\index{Conditional statement} has the following
syntax:

\begin{verbatim}
 <conditional statement> ::=
    IF <boolean expression> THEN <statement> [ELSE <statement>]
\end{verbatim}

The boolean expression is evaluated. If the result is {\em true}, the first
{\tt <statement>} is executed.  If it is {\em false}, the second is.

{\it Examples:}
\begin{verbatim}
        if x=5 then a:=b+c else d:=e+f

        if x=5 and numberp y
           then <<ff:=q1; a:=b+c>>
           else <<ff:=q2; d:=e+f>>
\end{verbatim}
Note the use of the group statement\index{Group statement}.
\\
Conditional statements associate to the right; i.e.,\ttindex{IF}
\begin{verbatim}
        IF <a> THEN <b> ELSE IF <c> THEN <d> ELSE <e>
\end{verbatim}
is equivalent to:
\begin{verbatim}
        IF <a> THEN <b> ELSE (IF <c> THEN <d> ELSE <e>)
\end{verbatim}
In addition, the construction
\begin{verbatim}
        IF <a> THEN IF <b> THEN <c> ELSE <d>
\end{verbatim}
parses as
\begin{verbatim}
        IF <a> THEN (IF <b> THEN <c> ELSE <d>).
\end{verbatim}
If the value of the conditional statement\index{Conditional
statement} is of primary interest, it is often called a conditional
expression instead.  Its value is the value of whichever statement was
executed. (If the executed statement has no value, the conditional
expression has no value or the value 0, depending on how it is used.)

{\it Examples:}
\begin{verbatim}
        a:=if x<5 then 123 else 456;
        b:=u + v^(if numberp z then 10*z  else 1) + w;
\end{verbatim}
If the value is of no concern, the {\tt ELSE} clause may be omitted if no
action is required in the {\em false} case.
\begin{verbatim}
        if x=5 then a:=b+c;
\end{verbatim}
Note:  As explained in Section~\ref{sec-boolean},a
if a scalar or numeric expression is used in place of
the boolean expression -- for example, a variable is written there -- the
{\em true} alternative is followed unless the expression has the value 0.

\section{FOR Statements}

The {\tt FOR} statement is used to define a variety of program
loops\index{Loop}.  Its general syntax is as follows:\ttindex{UNTIL}
\ttindex{DO} \ttindex{PRODUCT} \ttindex{SUM} \ttindex{COLLECT} \ttindex{JOIN}
\begin{verbatim}
                    {STEP <number> UNTIL}
    {<var>:=<number>{                   }<number>}
FOR {               {         :         }        }<action><exprn>
    {                                            }
    { EACH <var> IN <list>                       }
\end{verbatim}
where
\begin{verbatim}
        <action> ::= do|product|sum|collect|join.
\end{verbatim}
The assignment\index{Assignment} form of the {\tt FOR} statement defines an
iteration over the indicated numerical range.  If expressions that do not
evaluate to numbers are used in the designated places, an error will
result.

The {\tt FOR EACH} \ttindex{FOR EACH} form of the {\tt FOR} statement is
designed to iterate down a list.  Again, an error will occur if a list is
not used.

The action {\tt DO} \ttindex{DO} means that {\tt <exprn>} is simply
evaluated and no value kept; the statement returning 0 in this case (or no
value at the top level). {\tt COLLECT} means that the results of
evaluating {\tt <exprn>} each time are linked together to make a list,
and {\tt JOIN} means that the values of {\tt <exprn>} are themselves
lists that are joined to make one list (similar to {\tt CONC} in Lisp).
Finally, {\tt PRODUCT} \ttindex{PRODUCT} and {\tt SUM} \ttindex{SUM}
form the respective combined value out of the values of {\tt <exprn>}.

In all cases, {\tt <exprn>} is evaluated algebraically within the
scope of the current value of {\tt <var>}.  If {\tt <action>} is
{\tt DO}\ttindex{DO}, then nothing else happens.  In other cases, {\tt
<action>} is a binary operator that causes a result to be built up and
returned by {\tt FOR}.  In those cases, the loop\index{Loop} is
initialized to a default value ({\tt 0} for {\tt SUM}, \ttindex{SUM} {\tt
1} for {\tt PRODUCT}, \ttindex{PRODUCT} and an empty list for the other
actions).  The test for the end condition is made before any action is
taken.  As in Pascal, if the variable is out of range in the assignment
case, or the {\tt <list>} is empty in the {\tt FOR EACH}\ttindex{FOR EACH}
case, {\tt <exprn>} is not evaluated at all.

{\it Examples:}
\begin{enumerate}
\item If {\tt A}, {\tt B} have been declared to be arrays, the following
stores $5^{2}$ through $10^{2}$ in {\tt A(5)} through {\tt A(10)}, and at
the same time stores the cubes in the {\tt B} array:
\begin{verbatim}
   for i := 5 step 1 until 10 do <<a(i):=i^2; b(i):=i^3>>
\end{verbatim}
\item As a convenience, the common construction
\begin{verbatim}
        STEP 1 UNTIL
\end{verbatim}
may be abbreviated to a colon. Thus, instead of the above we could write:
\begin{verbatim}
        for i := 5:10 do <<a(i):=i^2; b(i):=i^3>>
\end{verbatim}
\item The following sets {\tt C} to the sum of the squares of 1,3,5,7,9;
and {\tt D} to the expression {\tt x*(x+1)*(x+2)*(x+3)*(x+4):}
\begin{verbatim}
        c := for j:=1 step 2 until 9 sum j^2;
        d := for k:=0 step 1 until 4 product (x+k);
\end{verbatim}
\item The following forms a list of the squares of the elements of the list
{\tt \{a,b,c\}:}\ttindex{FOR EACH}
\begin{verbatim}
        for each x in {a,b,c} collect x^2;
\end{verbatim}
\item The following forms a list of the listed squares of the elements of the
list {\tt \{a,b,c\}} (i.e., {\tt \{\{A\^{ }2\},\{B\^{ }2\},\{C\^{ }2\}\}):}
\begin{verbatim}
        for each x in {a,b,c} collect {x^2};
\end{verbatim}
\item The following also forms a list of the squares of the elements of
the list {\tt \{a,b,c\},} since the {\tt JOIN} operation joins the
individual lists into one list:\ttindex{FOR EACH}
\begin{verbatim}
        for each x in {a,b,c} join {x^2};
\end{verbatim}
\end{enumerate}
The control variable used in the {\tt FOR} statement is actually a new
variable, not related to the variable of the same name outside the {\tt
FOR} statement.  In other words, executing a statement {\tt for i:=} \ldots
doesn't change the system's assumption that $i^{2} = -1$.
Furthermore, in algebraic mode, the value of the control variable is
substituted in {\tt <exprn>} only if it occurs explicitly in that
expression.  It will not replace a variable of the same name in the value
of that expression.  For example:
\begin{verbatim}
        b := a; for a := 1:2 do write b;
\end{verbatim}
prints {\tt A} twice, not 1 followed by 2.

\section{WHILE \ldots DO}

The\ttindex{WHILE} {\tt FOR \ldots DO} \ttindex{DO} feature allows easy
coding of a repeated operation in which the number of repetitions is known
in advance.  If the criterion for repetition is more complicated, {\tt
WHILE \ldots DO} can often be used.  Its syntax is:
\begin{verbatim}
        WHILE <boolean expression> DO <statement>
\end{verbatim}
The {\tt WHILE \ldots  DO} controls the single statement following {\tt DO}.
If several statements are to be repeated, as is almost always the case,
they must be grouped using the $<<$ \ldots $>>$ or {\tt BEGIN \ldots END}
as in the example below.

The {\tt WHILE} condition is tested each time {\em before} the action
following the {\tt DO} is attempted.  If the condition is false to begin
with, the action is not performed at all.  Make sure that what is to be
tested has an appropriate value initially.

{\it Example:}

Suppose we want to add up a series of terms, generated one by one, until
we reach a term which is less than 1/1000 in value.  For our simple
example, let us suppose the first term equals 1 and each term is obtained
from the one before by taking one third of it and adding one third its
square. We would write:
\begin{verbatim}
        ex:=0; term:=1;
        while num(term - 1/1000) >= 0  do
                <<ex := ex+term; term:=(term + term^2)/3>>;
        ex;
\end{verbatim}
As long as {\tt TERM} is greater than or equal to ({\tt >=}) 1/1000 it will
be added to {\tt EX} and the next {\tt TERM} calculated.  As soo\ as {\tt
TERM} becomes less than 1/1000 the {\tt WHILE} test fails and the {\tt
TERM} will not be added.


\section{REPEAT \ldots UNTIL}

\ttindex{REPEAT} {\tt REPEAT \ldots  UNTIL} is very similar in purpose to
{\tt WHILE \ldots DO}.  Its syntax is:
\begin{verbatim}
        REPEAT <statement> UNTIL <boolean expression>
\end{verbatim}
(PASCAL users note: Only a single statement -- usually a group statement
-- is allowed between the {\tt REPEAT} and the {\tt UNTIL.)} \\

There are two essential differences:
\begin{enumerate}
\item The test is performed {\em after} the controlled statement (or group of
statements) is executed, so the controlled statement is always executed at
least once.

\item The test is a test for when to stop rather than when to continue, so its
``polarity" is the opposite of that in {\tt WHILE \ldots DO.}
\end{enumerate}

As an example, we rewrite the example from the {\tt WHILE \ldots DO} section:
\begin{verbatim}
        ex:=0; term:=1;
        repeat <<ex := ex+term; term := (term + term^2)/3>>
           until num(term - 1/1000) < 0;
        ex;
\end{verbatim}
In this case, the answer will be the same as before, because in neither
case is a term added to {\tt EX} which is less than 1/1000.

\section{Compound Statements}

\index{Compound statement}Often the desired process can best (or only) be
described as a series of steps to be carried out one after the other.  In
many cases, this can be achieved by use of the group statement\index{Group
statement} (q.v.).  However, each step often provides some intermediate
result, until at the end we have the final result wanted.  Alternatively,
iterations on the steps are needed that are not possible with constructs
such as {\tt WHILE} \ttindex{WHILE} or {\tt REPEAT} \ttindex{REPEAT}
statements (q.v.).  In such cases the steps of the process must be
enclosed between the words {\tt BEGIN} and {\tt END}\ttindex{BEGIN \ldots
END} forming what is technically called a {\em block}\index{Block} or
{\em compound} statement.  Such a compound statement can in fact be used
wherever a group statement appears.  The converse is not true: {\tt BEGIN
\ldots END} can be used in ways that {\tt $<<$} \ldots {\tt $>>$} cannot.

If intermediate results must be formed, local variables must be provided
in which to store them. {\em Local} means that their values are deleted as
soon as the block's operations are complete, and there is no conflict with
variables outside the block that happen to have the same name.  Local
variables are created by a {\tt SCALAR}\ttindex{SCALAR} declaration
immediately after the {\tt BEGIN}:
\begin{verbatim}
     scalar a,b,c,z;
\end{verbatim}
If more convenient, several {\tt SCALAR} declarations can be given one after
another:
\begin{verbatim}
     scalar a,b,c;
     scalar z;
\end{verbatim}
In place of {\tt SCALAR} one can also use the declarations
{\tt INTEGER}\ttindex{INTEGER} or {\tt REAL}\ttindex{REAL}.  In the present
version of {\REDUCE} variables declared {\tt INTEGER} are expected to have
only integer values, and are initialized to 0. {\tt REAL}
variables on the other hand are currently treated as algebraic mode {\tt
SCALAR}s.

{\it CAUTION:} {\tt INTEGER}, {\tt REAL} and {\tt SCALAR} declarations can
only be given immediately after a {\tt BEGIN}.  An error will result if
they are used after other statements in a block (including {\tt ARRAY} and
{\tt OPERATOR} declarations, which are global in scope), or outside the
top-most block (e.g., at the top level).  All variables declared {\tt
SCALAR} are automatically initialized to zero in algebraic mode ({\tt NIL}
in symbolic mode).

Any symbols not declared as local variables in a block refer to the
variables of the same name in the current calling environment. In
particular, if they are not so declared at a higher level (e.g., in a
surrounding block or as parameters in a calling procedure), their values can
be permanently changed.

Following the {\tt SCALAR}\ttindex{SCALAR} declaration(s), if any, write the
statements to be executed, one after the other, separated by delimiters
(e.g., {\tt ;} or {\tt \$}) (it doesn't matter which).  However, from a
stylistic point of view, {\tt ;} is preferred.

The last statement in the body, just before {\tt END}, need not have a
terminator (since the {\tt BEGIN \ldots END} are in a sense brackets
confining the block statements).  The last statement must also be the
command {\tt RETURN} \ttindex{RETURN} followed by the variable or
expression whose value is to be the value returned by the procedure.  If
the {\tt RETURN} is omitted (or nothing is written after the word
{\tt RETURN}) the procedure will have no value or the value zero, depending
on how it is used (and {\tt NIL} in symbolic mode).  Remember to put a
terminator after the {\tt END}.

{\it Example:}

Given a previously assigned integer value for {\tt N}, the following block
will compute the Legendre polynomial of degree {\tt N} in the variable
{\tt X}:
\begin{verbatim}
        begin scalar seed,deriv,top,fact;
           seed:=1/(y^2 - 2*x*y +1)^(1/2);
           deriv:=df(seed,y,n);
           top:=sub(y=0,deriv);
           fact:=for i:=1:n product i;
           return top/fact
        end;
\end{verbatim}

\subsection{Compound Statements with GO TO}

It is possible to have more complicated structures inside the {\tt BEGIN
\ldots END} \ttindex{BEGIN \ldots END} brackets than indicated in the
previous example.  That the individual lines of the program need not be
assignment \index{Assignment} statements, but could be almost any other
kind of statement or command, needs no explanation.  For example,
conditional statements, and {\tt WHILE} \ttindex{WHILE} and {\tt REPEAT}
\ttindex{REPEAT} constructions, have an obvious role in defining more
intricate blocks.

If these structured constructs don't suffice, it is possible to use labels
\index{Label} and {\tt GO} {\tt TO}s\ttindex{GO TO} within a compound
statement \index{Compound statement}, and also to use
{\tt RETURN} \ttindex{RETURN} in places within the block other than just before
the {\tt END}.  The following subsections discuss these matters in detail.
For many readers the following example, presenting one possible definition
of a process to calculate the factorial of {\tt N} for preassigned {\tt N}
will suffice:

{\it Example:}
\begin{verbatim}
        begin scalar m;
            m:=1;
         l: if n=0 then return m;
            m:=m*n;
            n:=n-1;
            go to l
        end;
\end{verbatim}

\subsection{Labels and GO TO Statements}

\index{Label} \ttindex{GO TO}Within a {\tt BEGIN \ldots END} compound
statement it is possible to label statements, and transfer to them out of
sequence using {\tt GO} {\tt TO} statements.  Only statements on the top
level inside compound statements can be labeled, not ones inside
subsidiary constructions like {\tt $<<$} \ldots {\tt $>>$}, {\tt IF} \ldots
{\tt THEN} \ldots , {\tt WHILE} \ldots {\tt DO} \ldots , etc.

Labels and {\tt GO TO} statements have the syntax:
\begin{verbatim}
        <go to statement> ::= GO TO <label> | GOTO <label>
        <label> ::= <identifier>
        <labeled statement> ::= <label>:<statement>
\end{verbatim}
Note that statement names cannot be used as labels.

While {\tt GO TO} is an unconditional transfer, it is frequently used
in conditional statements such as
\begin{verbatim}
        if x>5 then go to abcd;
\end{verbatim}
giving the effect of a conditional transfer.

Transfers using {\tt GO TO}s can only occur within the block in which the
{\tt GO TO} is used.  In other words, you cannot transfer from an inner
block to an outer block using a {\tt GO TO}.  However, if a group statement
occurs within a compound statement, it is possible to jump out of that group
statement to a point within the compound statement using a {\tt GO TO}.

\subsection{RETURN Statements}

The value corresponding to a {\tt BEGIN \ldots END} compound statement,
\ttindex{BEGIN \ldots END} such as a procedure body, is normally 0 ({\tt
NIL} in symbolic mode).  By executing a {\tt RETURN}\ttindex{RETURN}
statement in the compound statement a different value can be returned.
After a {\tt RETURN} statement is executed no further statements within
the compound statement are.

{\tt Examples:}
\begin{verbatim}
        return x+y;
        return m;
        return;
\end{verbatim}
Note that parentheses are not required around the {\tt x+y}, although they
are permitted.  The last example is equivalent to {\tt return 0} or {\tt
return nil}, depending on whether the block is used as part of an
expression or not.

Since {\tt RETURN} \ttindex{RETURN} actually moves up only one
block\index{Block} level, in a sense the casual user is not expected to
understand, we tabulate some cautions concerning its use.
\begin{enumerate}
\item {\tt RETURN} can be used on the top level inside the compound
statement, i.e. as one of the statements bracketed together by the {\tt
BEGIN \ldots END}\ttindex{BEGIN \ldots END}

\item {\tt RETURN} can be used within a top level {\tt $<<$} \ldots {\tt
$>>$} construction within the compound statement.  In this case, the {\tt
RETURN} transfers control out of both the group statement and the compound
statement.

\item {\tt RETURN} can be used within an {\tt IF} \ldots {\tt THEN} \ldots
{\tt ELSE} \ldots on the top level within the compound statement.
\end{enumerate}
NOTE:  At present, there is no construct provided to permit early
termination of a {\tt FOR} \ttindex{FOR}, {\tt WHILE} \ttindex{WHILE},
or {\tt REPEAT} \ttindex{REPEAT} statement.  In particular, the use of
{\tt RETURN} in such cases results in a syntax error.  For example,
\begin{verbatim}
        begin scalar y;
           y := for i:=0:99 do if a(i)=x then return b(i);
           ...
\end{verbatim}
will lead to an error.

\chapter{Commands and Declarations}

A command\index{Command} is an order to the system to do something.  Some
commands cause visible results (such as calling for input or output);
others, usually called declarations\index{Declaration}, set options,
define properties of variables, or define procedures.  Commands are
formally defined as a statement followed by a terminator
\begin{verbatim}
        <command> ::= <statement> <terminator>
        <terminator> ::= ;|$
\end{verbatim}
Some {\REDUCE} commands and declarations are described in the following
sub-sections.

\section{Array Declarations}

Array\ttindex{ARRAY} declarations in {\REDUCE} are similar to FORTRAN
dimension statements.  For example:
\begin{verbatim}
        array a(10),b(2,3,4);
\end{verbatim}
Array indices each range from 0 to the value declared. An element of an
array is referred to in standard FORTRAN notation, e.g. {\tt A(2)}.

We can also use an expression for defining an array bound, provided the
value of the expression is a positive integer. For example, if {\tt X} has the
value 10 and {\tt Y} the value 7 then
{\tt array c(5*x+y)} is the same as {\tt array c(57)}.

If an array is referenced by an index outside its range, an error occurs.
If the array is to be one-dimensional, and the bound a number or a variable
(not a more general expression) the parentheses may be omitted:
\begin{verbatim}
        array a 10, c 57;
\end{verbatim}
The operator {\tt LENGTH} \ttindex{LENGTH} (q.v.) applied to an array name
returns a list of its dimensions.

All array elements are initialized to 0 at declaration time. In other words,
an array element has an {\em instant evaluation}\index{Instant evaluation}
property and cannot stand for itself.  If this is required, then an
operator (q.v.) should be used instead.

Array declarations can appear anywhere in a program. Once a symbol is
declared to name an array, it can not also be used as a variable, or to
name an operator or a procedure. It can however be re-declared to be an
array, and its size may be changed at that time. An array name can also
continue to be used as a parameter in a procedure, or a local variable in
a compound statement, although this use is not recommended, since it can
lead to user confusion over the type of the variable.

Arrays once declared are global in scope, and so can then be referenced
anywhere in the program. In other words, unlike arrays in most other
languages, a declaration within a block (or a procedure) does not limit
the scope of the array to that block, nor does the array go away on
exiting the block (use {\tt CLEAR} instead for this purpose).

\section{Mode Handling Declarations}\index{Mode}

The {\tt ON} \ttindex{ON} and {\tt OFF} \ttindex{OFF} declarations are
available to the user for controlling various system options.  Each option
is represented by a ``switch"\index{Switch} name. {\tt ON} and {\tt OFF}
take a list of switch names as argument and turn them on and off
respectively, e.g.,
\begin{verbatim}
       on time;
\end{verbatim}
causes the system to print a message after each command giving the elapsed
CPU time since the last command, or since {\tt TIME} \ttindex{TIME} was
last turned off, or the session began.  Another useful switch with
interactive use is {\tt DEMO}, which causes the system to pause after each
command in a file until a RETURN is typed on the terminal.  This
enables a user to set up a demonstration file and step through it command
by command.

As with most declarations, arguments to {\tt ON} and {\tt OFF} may be
strung together separated by commas.  For example,
\begin{verbatim}
        off time,demo;
\end{verbatim}
will turn off both the time messages and the demonstration switch.

We note here that while most {\tt ON} and {\tt OFF} commands are obeyed
almost instantaneously, some trigger time-consuming actions such as
reading in necessary modules from secondary storage.

A diagnostic message is printed if {\tt ON} \ttindex{ON} or {\tt OFF}
\ttindex{OFF} are used with a switch that is not known to the system.  For
example, if you misspell {\tt DEMO} and type
\begin{verbatim}
     on demq;
\end{verbatim}
you will get the message\index{Switch}
\begin{verbatim}
        ***** DEMQ not defined as switch.
\end{verbatim}

\section{END}

The identifier {\tt END} \ttindex{END} has three separate uses.

1) Its use in a {\tt BEGIN \ldots END} bracket has been discussed in
connection with compound statements (q.v.).

2) Files to be read using {\tt IN} should end with an extra {\tt END};
command.  The reason for this is explained in the section on the {\tt IN}
command (q.v.).  This use of {\tt END} does not allow an immediately
preceding {\tt END} (such as the {\tt END} of a procedure definition), so
we advise using {\tt ;END;} there.

3) A command {\tt END}; entered at the top level transfers control to the
Lisp system\index{Lisp} which is the host of the {\REDUCE} system.  All
files opened by {\tt IN} or {\tt OUT} statements are closed in the
process.  {\tt END;} does not stop {\REDUCE}.  Those familiar with Lisp can
experiment with typing identifiers and ({\tt <function name> <argument
list>}) lists to see the value returned by Lisp. (No terminators, other
than the RETURN key, should be used.) The data structures created during
the {\REDUCE} run are accessible.

You remain in this Lisp mode until you explicitly re-enter {\REDUCE} by
saying {\tt (BEGIN)} at the Lisp top level.  In most systems, a Lisp error
also returns you to {\REDUCE} (exceptions are noted in the operating
instructions for your particular {\REDUCE} implementation).  In either
case, you will return to {\REDUCE} in the same mode, algebraic or
symbolic, that you were in before the {\tt END};.  If you are in
Lisp mode\index{Lisp mode} by mistake -- which is usually the case,
the result of typing more {\tt END}s\ttindex{END} than {\tt BEGIN}s --
type {\tt (BEGIN)} in parentheses and hit the RETURN key.

\section{BYE Command}\ttindex{BYE}

The command {\tt BYE}; stops the execution of {\REDUCE}, closes all open
output files, and returns you to the computer system monitor program.
Where the implementation permits it, your {\REDUCE} session is destroyed.
If you wish to return later to that session, use {\tt QUIT}; instead.

\section{QUIT Command}\ttindex{QUIT}

The command {\tt QUIT}; stops the execution of {\REDUCE} and returns you to
the computer system monitor program.  Where the implementation permits it,
your {\REDUCE} session is retained so that you can use it again later.
Please refer to the system-specific user guide to see if this option is
available in your system.  If you do not wish to reenter the {\REDUCE}
session, use {\tt BYE}; instead.


\section{SHOWTIME Command}\ttindex{SHOWTIME}

{\tt SHOWTIME}; prints the elapsed time since the last call of this
command or, on its first call, since the current {\REDUCE} session began.
The time is normally given in milliseconds and gives the time as measured
by a system clock.  The operations covered by this measure are system
dependent.

\section{DEFINE Command}

The command {\tt DEFINE} \ttindex{DEFINE} allows a user to supply a new name for
any identifier or replace it by any well-formed expression.  Its argument
is a list of expressions of the form
\begin{verbatim}
        <identifier> = <number>|<identifier>|<operator>|
                        <reserved word>|<expression>
\end{verbatim}

{\it Example:}
\begin{verbatim}
        define be==,x=y+z;
\end{verbatim}
means that {\tt BE} will be interpreted as an equal sign, and {\tt X}
as the expression {\tt y+z} from then on.  This renaming is done at parse
time, and therefore takes precedence over any other replacement declared
for the same identifier.  It stays in effect until the end of the
{\REDUCE} run.

The identifiers {\tt ALGEBRAIC} and {\tt SYMBOLIC} have properties which
prevent {\tt DEFINE} \ttindex{DEFINE} from being used on them.  To define
{\tt ALG} to be a synonym for {\tt ALGEBRAIC}, the more complicated
construction
\begin{verbatim}
        put('alg,'newnam,'algebraic);
\end{verbatim}
must be used.

\chapter{Built-in Prefix Operators}
In the following subsections are descriptions of the most useful prefix
\index{Prefix}
operators built into {\REDUCE} that are not defined in other sections (such
as substitution operators). Some are fully defined internally as
procedures; others are more nearly abstract operators, with only some of
their properties known to the system.

In many cases, an operator is described by a prototypical header line as
follows. Each formal parameter is given a name and followed by its allowed
type. The names of classes referred to in the definition are printed in
lower case, and parameter names in upper case. If a parameter type is not
commonly used, it may be a specific set enclosed in brackets {\tt \{} \ldots
{\tt \}}.
Operators which accept formal parameter lists of arbitrary length have the
parameter and type class enclosed in square brackets indicating that zero
or more occurrences of that argument are permitted. Optional parameters
and their type classes are enclosed in angle brackets.

\section{Numerical Operators}\index{Numerical operator}
{\REDUCE} includes a number of functions that are analogs of those found
in most numerical systems.  With numerical arguments, such functions
return the expected result.  However, they may also be called with
non-numeric arguments.  In such cases, except where noted, the system
attempts to simplify the expression as far as it can.  In such cases, a
residual expression involving the original operator usually remains.
These operators are as follows:

\subsection{ABS}
{\tt ABS} \ttindex{ABS} returns the absolute value
of its single argument, if that argument has a numerical value.
A non-numeric argument is returned as an absolute value, with an overall
numeric coefficient taken outside the absolute value operator. For example:
\begin{verbatim}
        abs(-3/4)     ->  3/4
        abs(2a)       ->  2*ABS(A)
        abs(i)        ->  1
        abs(-x)       ->  ABS(X)
\end{verbatim}

\subsection{CEILING} \ttindex{CEILING}
This operator returns the ceiling (i.e., the least integer greater than
the given argument) if its single argument has a numerical value.  A
non-numeric argument is returned as an expression in the original
operator.  For example:

\begin{verbatim}
        ceiling(-5/4) ->  -1
        ceiling(-a)   ->  CEILING(-A)
\end{verbatim}

\subsection{CONJ} \ttindex{CONJ}
This returns the complex conjugate
of an expression, if that argument has an numerical value.  A
non-numeric argument is returned as an expression in the original
operator.  For example:
\begin{verbatim}
        conj(1+i)     -> 1-I
        conj(a+i*b)   -> REPART(A) - REPART(B)*I - IMPART(A)*I
                         - IMPART(B)
\end{verbatim}

\subsection{FACTORIAL} \ttindex{FACTORIAL}

If the single argument of {\tt FACTORIAL} evaluates to a non-negative
integer, its factorial is returned.  Otherwise an expression involving
{\tt FACTORIAL} is returned. For example:
\begin{verbatim}
        factorial(5)  ->  120
        factorial(a)  ->  FACTORIAL(A)
\end{verbatim}

\subsection{FIX} \ttindex{FIX}
This operator returns the fixed value (i.e., the integer part of
the given argument) if its single argument has a numerical value.  A
non-numeric argument is returned as an expression in the original
operator.  For example:

\begin{verbatim}
        fix(-5/4)   ->  -1
        fix(a)      ->  FIX(A)
\end{verbatim}

\subsection{FLOOR} \ttindex{FLOOR}
This operator returns the floor (i.e., the greatest integer less than
the given argument) if its single argument has a numerical value.  A
non-numeric argument is returned as an expression in the original
operator.  For example:

\begin{verbatim}
        floor(-5/4)   ->  -2
        floor(a)      ->  FLOOR(A)
\end{verbatim}

\subsection{IMPART} \ttindex{IMPART}
This operator returns the imaginary part of an expression, if that argument
has an numerical value.  A non-numeric argument is returned as an expression
in the original operator.  For example:
\begin{verbatim}
        impart(1+i)   -> 1
        impart(a+i*b) -> REPART(B) + IMPART(A)
\end{verbatim}

\subsection{MAX/MIN}

{\tt MAX} and {\tt MIN} \ttindex{MAX} \ttindex{MIN} can take an arbitrary
number of expressions as their arguments.  If all arguments evaluate to
numerical values, the maximum or minimum of the argument list is returned.
If any argument is non-numeric, an appropriately reduced expression is
returned.  For example:
\begin{verbatim}
        max(2,-3,4,5) ->  5
        min(2,-2)     ->  -2.
        max(a,2,3)    ->  MAX(A,3)
        min(x)        ->  X
\end{verbatim}
{\tt MAX} or {\tt MIN} of an empty list returns 0.

\subsection{NEXTPRIME} \ttindex{NEXTPRIME}

{\tt NEXTPRIME} returns the next prime greater than its integer argument.
A type error occurs in this case if the value of the argument is not an
integer. For example:
\begin{verbatim}
        nextprime(5)   ->  7
        nextprime(-2)  ->  2
        nextprime(-7)  -> -5
\end{verbatim}
whereas {\tt nextprime(a)} gives a type error.

\subsection{REPART} \ttindex{REPART}
This returns the real part of an expression, if that argument has an
numerical value.  A non-numeric argument is returned as an expression in the
original operator.  For example:
\begin{verbatim}
        repart(1+i)   -> 1
        repart(a+i*b) -> REPART(A) - IMPART(B)
\end{verbatim}

\subsection{ROUND} \ttindex{ROUND}
This operator returns the rounded value (i.e, the nearest integer) of its
single argument if that argument has a numerical value.  A non-numeric
argument is returned as an expression in the original operator.  For
example:
\begin{verbatim}
        round(-5/4)   ->  -1
        round(a)      ->  ROUND(A)
\end{verbatim}

\section{Mathematical Functions}

{\REDUCE} knows that the following represent mathematical functions
\index{Mathematical function} that can
take arbitrary scalar expressions as their single argument:
\begin{verbatim}
        ACOS ACOSD ACOSH ACOT ACOTD ACOTH ACSC ACSCD ACSCH
        ASEC ASECD ASECH ASIN ASIND ASINH ATAN ATAND ATANH
        ATAN2 ATAN2D CBRT COS COSD COSH COT COTD COTH CSC
        CSCD CSCH DILOG EXP EXPINT HYPOT LN LOG LOGB LOG10
        SEC SECD SECH SIN SIND SINH SQRT TAN TAND TANH
\end{verbatim}
\ttindex{ACOS} \ttindex{ACOSD} \ttindex{ACOSH} \ttindex{ACOT} \ttindex{ACOTD}
\ttindex{ACOTH} \ttindex{ACSC} \ttindex{ACSCD} \ttindex{ACSCH} \ttindex{ASEC}
\ttindex{ASECD} \ttindex{ASECH} \ttindex{ASIN} \ttindex{ASIND}
\ttindex{ASINH} \ttindex{ATAN} \ttindex{ATAND} \ttindex{ATANH}
\ttindex{ATAN2} \ttindex{ATAN2D} \ttindex{CBRT} \ttindex{COS} \ttindex{COSD}
\ttindex{COSH} \ttindex{COT} \ttindex{COTD} \ttindex{COTH} \ttindex{CSC}
\ttindex{CSCD} \ttindex{CSCH} \ttindex{DILOG} \ttindex{EXP} \ttindex{EXPINT}
\ttindex{HYPOT} \ttindex{LN} \ttindex{LOG} \ttindex{LOGB} \ttindex{LOG10}
\ttindex{SEC} \ttindex{SECD} \ttindex{SECH} \ttindex{SIN} \ttindex{SIND}
\ttindex{SINH} \ttindex{SQRT} \ttindex{TAN} \ttindex{TAND} \ttindex{TANH}
where {\tt LOG} is the natural logarithm (and equivalent to {\tt LN}),
and {\tt LOGB} has two arguments of which the second is the logarithmic base.

However, {\REDUCE} only knows the most elementary identities and properties
of these functions (except in {\tt on rounded} mode (q.v.)).  For example:
\begin{verbatim}
      cos(-x) = cos(x)              sin(-x) = - sin (x)
      cos(n*pi) = (-1)^n            sin(n*pi) = 0
      log(e)  = 1                   e^(i*pi/2) = i
      log(1)  = 0                   e^(i*pi) = -1
      log(e^x) = x                  e^(3*i*pi/2) = -i
\end{verbatim}

The derivatives of these functions are also known to the system.

% With the default system switch settings, the argument of a square root is
% first simplified, and any divisors of the expression that are perfect
% squares taken outside the square root argument. The remaining expression
% is left under the square root. However, if the switch {\tt REDUCED}
% \ttindex{REDUCED} is on,
% multiplicative factors in the argument of the square root are also
% separated, becoming individual square roots. Thus with {\tt REDUCED} off,
% the expression
% \begin{verbatim}
%         sqrt(-8*a^2*b)
% \end{verbatim}
% would become
% \begin{verbatim}
%         2*a*sqrt(-2*b) ,
% \end{verbatim}
% whereas with {\tt REDUCED} on, it would become
% \begin{verbatim}
%         2*a*i*sqrt(2)*sqrt(b) .
% \end{verbatim}
% The switch {\tt REDUCED} \ttindex{REDUCED} also applies to other rational
% powers in addition to square roots.

% Note that such simplifications can cause trouble if {\tt A} is eventually
% given a value which is a negative number.  If it is important that the
% positive property of the square root always be preserved, the switch
% {\tt PRECISE} \ttindex{PRECISE} can be set on.  This causes any
% non-numerical factors taken out of surds to be represented by their
% absolute value form.
% With both {\tt REDUCED} and {\tt PRECISE} on then, the above example would
% become
% \begin{verbatim}
%         2*i*abs(a)*sqrt(2)*sqrt(b) .
% \end{verbatim}
The user can add further rules for the reduction of expressions involving
these operators by using the {\tt LET} \ttindex{LET} command (q.v.).

The square root function can be input using the name {\tt SQRT}, or the
power operation {\tt \^{ }(1/2)}.  On output, unsimplified square roots
are normally represented by the operator {\tt SQRT} rather than a
fractional power.

The statement that {\REDUCE} knows very little about these functions
applies only in the mathematically exact {\tt off rounded} mode.  If
{\tt ROUNDED} \ttindex{ROUNDED} is on, any of the functions
\begin{verbatim}
        ACOS ACOSD ACOSH ACOT ACOTD ACOTH ACSC ACSCD ACSCH
        ASEC ASECD ASECH ASIN ASIND ASINH ATAN ATAND ATANH
        ATAN2 ATAN2D CBRT COS COSD COSH COT COTD COTH CSC
        CSCD CSCH EXP HYPOT LN LOG LOGB LOG10 SEC SECD SECH
        SIN SIND SINH SQRT TAN TAND TANH

\end{verbatim}
\ttindex{ACOS} \ttindex{ACOSD} \ttindex{ACOSH} \ttindex{ACOT} \ttindex{ACOTD}
\ttindex{ACOTH} \ttindex{ACSC} \ttindex{ACSCD} \ttindex{ACSCH} \ttindex{ASEC}
\ttindex{ASECD} \ttindex{ASECH} \ttindex{ASIN} \ttindex{ASIND}
\ttindex{ASINH} \ttindex{ATAN} \ttindex{ATAND} \ttindex{ATANH}
\ttindex{ATAN2} \ttindex{ATAN2D} \ttindex{CBRT} \ttindex{COS} \ttindex{COSD}
\ttindex{COSH} \ttindex{COT} \ttindex{COTD} \ttindex{COTH} \ttindex{CSC}
\ttindex{CSCD} \ttindex{CSCH} \ttindex{EXP} \ttindex{HYPOT} \ttindex{LN}
\ttindex{LOG} \ttindex{LOGB} \ttindex{LOG10} \ttindex{SEC} \ttindex{SECD}
\ttindex{SECH} \ttindex{SIN} \ttindex{SIND} \ttindex{SINH} \ttindex{SQRT}
\ttindex{TAN} \ttindex{TAND} \ttindex{TANH}
when given a numeric argument has its value calculated to the current
degree of floating point precision.  In addition, real (non-integer
valued) powers of numbers will also be evaluated.

If the {\tt COMPLEX} switch is turned on in addition to {\tt ROUNDED},
these functions will also calculate a real or complex result, again to
the current degree of floating point precision,
if given complex arguments.  For example, with {\tt on rounded,complex;}
\begin{verbatim}
        2.3^(5.6i)   ->   -0.0480793490914 - 0.998843519372*I
        cos(2+3i)    ->   -4.18962569097 - 9.10922789376*I
\end{verbatim}

\section{DF Operator}
The operator {\tt DF} \ttindex{DF} is used to represent partial
differentiation \index{Differentiation} with respect
to one or more variables. It is used with the syntax:
\begin{verbatim}
     DF(EXPRN:algebraic[,VAR:kernel<,NUM:integer>]):algebraic.
\end{verbatim}
The first argument is the expression to be differentiated. The remaining
arguments specify the differentiation variables and the number of times
they are applied.

The number {\tt NUM} may be omitted if it is 1.  For example,
\begin{quote}
\begin{tabbing}
{\tt            df(y,x)} \hspace{1in} \= = $\partial y/\partial x$ \\
{\tt            df(y,x,2)} \> = $\partial^{2}y/\partial x^{2}$ \\
{\tt            df(y,x1,2,x2,x3,2)} \> = $\partial^{5}y/\partial x_{1}^{2} \
 \partial x_{2}\partial x_{3}^{2}.$
\end{tabbing}
\end{quote}
The evaluation of {\tt df(y,x)} proceeds as follows: first, the values of
{\tt Y} and {\tt X} are found.  Let us assume that {\tt X} has no assigned
value, so its value is {\tt X}.  Each term or other part of the value of
{\tt Y} which contains the variable {\tt X} is differentiated by the
standard rules.  If {\tt Z} is another variable, not {\tt X} itself, then
its derivative with respect to {\tt X} is taken to be 0, unless {\tt Z}
has previously been declared to {\tt DEPEND} (q.v.) on {\tt X}, in which
case the derivative is reported as the symbol {\tt df(z,x)}.


\subsection{Adding Differentiation Rules}

The {\tt LET} \ttindex{LET} statement (q.v.) can be used to introduce
rules for differentiation of user-defined operators.  Its general form is
\begin{verbatim}
        FOR ALL <var1>,...,<varn>
             LET DF(<operator><varlist>,<vari>)=<expression>
\end{verbatim}
where {\tt <varlist>} ::= ({\tt <var1>},\dots,{\tt <varn>}), and
{\tt <var1>},...,{\tt <varn>} are the dummy variable arguments of
{\tt <operator>}.

An analogous form applies to infix operators.

{\it Examples:}
\begin{verbatim}
        for all x let df(tan x,x)= 1 + tan(x)^2;
\end{verbatim}
(This is how the tan differentiation rule appears in the {\REDUCE}
source.)
\begin{verbatim}
        for all x,y let df(f(x,y),x)=2*f(x,y),
                        df(f(x,y),y)=x*f(x,y);
\end{verbatim}
Notice that all dummy arguments of the relevant operator must be declared
arbitrary by the {\tt FOR ALL} command, and that rules may be supplied for
operators with any number of arguments.  If no differentiation rule
appears for an argument in an operator, the differentiation routines will
return as result an expression in terms of {\tt DF} \ttindex{DF}.  For
example, if the rule for the differentiation with respect to the second
argument of {\tt F} is not supplied, the evaluation of {\tt df(f(x,z),z)}
would leave this expression unchanged. (No {\tt DEPEND} declaration (q.v.)
is needed here, since {\tt f(x,z)} obviously ``depends on" {\tt Z}.)

Once such a rule has been defined for a given operator, any future
differentiation\index{Differentiation} rules for that operator must be
defined with the same number of arguments for that operator, otherwise we
get the error message
\begin{verbatim}
        Incompatible DF rule argument length for <operator>
\end{verbatim}

\section{INT Operator}
{\tt INT} \ttindex{INT} is an operator in {\REDUCE} for indefinite
integration \index{Integration} \index{Indefinite integration} using a
combination of the Risch-Norman algorithm and pattern matching.  It is
used with the syntax:
\begin{verbatim}
   INT(EXPRN:algebraic,VAR:kernel):algebraic.
\end{verbatim}
This will return correctly the indefinite integral for expressions comprising
polynomials, log functions, exponential functions and tan and atan. The
arbitrary constant is not represented. If the integral cannot be done in
closed terms, it returns a formal integral for the answer in one of two ways:
\begin{enumerate}
\item It returns the input, {\tt INT(\ldots,\ldots)} unchanged.

\item It returns an expression involving {\tt INT}s of some
      other functions (sometimes more complicated than
      the original one, unfortunately).
\end{enumerate}
Rational functions can be integrated when the denominator is factorizable
by the program. In addition it will attempt to integrate expressions
involving error functions, dilogarithms and other trigonometric
expressions. In these cases it might not always succeed in finding the
solution, even if one exists.

{\it Examples:}
\begin{verbatim}
        int(log(x),x) ->  X*(LOG(X) - 1),
        int(e^x,x)    ->  E**X.
\end{verbatim}
The program checks that the variable supplied is a variable and gives an
error if it is not.


\subsection{Options}

The switch {\tt TRINT} when on will trace the operation of the algorithm. It
produces a great deal of output in a somewhat illegible form, and is not
of much interest to the general user. It is normally off.

If the switch {\tt FAILHARD} is on the algorithm will terminate with an
error if the integral cannot be done in closed terms, rather than return a
formal integration form. {\tt FAILHARD} is normally off.

The switch {\tt NOLNR} suppresses the use of the linear properties of
integration in cases when the integral cannot be found in closed terms.
It is normally off.

\subsection{Advanced Use}

If a function appears in the integrand which is not one of the functions
{\tt EXP, ERF, TAN, ATAN, LOG, DILOG} then the algorithm will make an attempt to
integrate the argument if it can, differentiate it and reach a known
function. However the answer cannot be guaranteed in this case. If a
function is known to be algebraically independent of this set it can be
flagged transcendental by
\begin{verbatim}
        flag('(trilog),'transcendental);
\end{verbatim}
in which case this function will be added to the permitted field
descriptors for a genuine decision procedure. If this is done the user is
responsible for the mathematical correctness of his actions.

The standard version does not deal with algebraic extensions. Thus
integration of expressions involving square roots and other like things
can lead to trouble. A contributed package that supports integration of
functions involving square roots is available, however. This is
distributed with most versions of {\REDUCE}.


\subsection{References}

        A. C. Norman \& P. M. A. Moore, ``Implementing the New Risch
                Algorithm", Proc. 4th International Symposium on Advanced
                Comp. Methods in Theor. Phys., CNRS, Marseilles, 1977.

        S. J. Harrington, ``A New Symbolic Integration System in Reduce",
                Comp. Journ. 22 (1979) 2.

        A. C. Norman \& J. H. Davenport, ``Symbolic Integration --- The Dust
                Settles?", Proc. EUROSAM 79, Lecture Notes in Computer
                Science 72, Springer-Verlag, Berlin Heidelberg New York
                (1979) 398-407.

%\subsection{Definite Integration} \index{Definite integration}
%
%If {\tt INT} is used with the syntax
%
%\begin{verbatim}
%   INT(EXPRN:algebraic,VAR:kernel,LOWER:algebraic,UPPER:algebraic):algebraic.
%\end{verbatim}
%
%The definite integral of {\tt EXPRN} with respect to {\tt VAR} is
%calculated between the limits {\tt LOWER} and {\tt UPPER}.  In the present
%system, this is calculated either by pattern matching, or by first finding
%the indefinite integral, and then substituting the limits into this.

\section{LENGTH Operator}
{\tt LENGTH} \ttindex{LENGTH} is a generic operator for finding the
length of various objects in the system.  The meaning depends on the type
of the object.  In particular, the length of an algebraic expression is
the number of additive top-level terms its expanded representation.

{\it Examples:}
\begin{verbatim}
        length(a+b)    ->  2
        length(2)      ->  1.
\end{verbatim}
Other objects that support a length operator include arrays, lists and
matrices. The explicit meaning in these cases is included in the description
of these objects.

\section{MKID Operator}\ttindex{MKID}
In many applications, it is useful to create a set of identifiers for
naming objects in a consistent manner. In most cases, it is sufficient to
create such names from two components. The operator {\tt MKID} is provided
for this purpose. Its syntax is:
\begin{verbatim}
MKID(U:id,V:id|non-negative integer):id
\end{verbatim}
for example
\begin{verbatim}
        mkid(a,3)      -> A3
        mkid(apple,s)  -> APPLES
\end{verbatim}
while {\tt mkid(a+b,2)} gives an error.

\section{PF Operator} \ttindex{PF}

{\tt PF(<exp>,<var>)} transforms the expression {\tt <exp>} into a list of
partial fractions with respect to the main variable, {\tt <var>}.  {\tt PF}
does a complete partial fraction decomposition, and as the algorithms used
are fairly unsophisticated (factorization and the extended Euclidean
algorithm), the code may be unacceptably slow in complicated cases.

{\it Example:}
Given {\tt 2/((x+1)\^{ }2*(x+2))} in the workspace,
{\tt pf(ws,x);} gives the result
\begin{verbatim}
            2      - 2         2
        {-------,-------,--------------} .
          X + 2   X + 1    2
                          X  + 2*X + 1
\end{verbatim}

If you want the denominators in factored form, use {\tt off exp;}.
Thus, with {\tt 2/((x+1)\^{ }2*(x+2))} in the workspace, the commands
{\tt off exp; pf(ws,x);} give the result
\begin{verbatim}
            2      - 2       2
        {-------,-------,----------} .
          X + 2   X + 1          2
                          (X + 1)
\end{verbatim}

To recombine the terms, {\tt FOR EACH \ldots SUM} can be used.  So with
the above list in the workspace, {\tt for each j in ws sum j;} returns the
result
\begin{verbatim}
             2
     ------------------
                     2
      (X + 2)*(X + 1)
\end{verbatim}

Alternatively, one can use the operations on lists to extract any desired
term.

\section{SOLVE Operator}\ttindex{SOLVE}
SOLVE is an operator for solving one or more simultaneous algebraic
equations. It is used with the syntax:
\begin{verbatim}
  SOLVE(EXPRN:algebraic[,VAR:kernel|,VARLIST:list of kernels])
         :integer.
\end{verbatim}
{\tt EXPRN} is of the form {\tt <expression>} or
\{ {\tt <expression1>},{\tt <expression2>}, \dots \}.  Each expression is an
algebraic equation, or is the difference of the two sides of the equation.
The second argument is either a kernel or a list of kernels representing
the unknowns in the system.  This argument may be omitted if the number of
distinct top-level kernels equals the number of unknowns, in which case
these kernels are presumed to be the unknowns.

Non-linear equations are solved using the Groebner basis package (q.v.).
\index{Groebner} Users should note that this can be quite a
time consuming process.

{\it Examples:}
\begin{verbatim}
            solve(log(sin(x+3))^5 = 8,x);
            solve(a*log(sin(x+3))^5 - b, sin(x+3));
            solve({a*x+y=3,y=-2},{x,y});
\end{verbatim}

{\tt SOLVE} returns a list of solutions.  If there is one unknown, each
solution is an equation for the unknown.  If a complete solution was
found, the unknown will appear by itself on the left-hand side of the
equation.  On the other hand, if the solve package could not find a
solution, the ``solution" will be an equation for the unknown.  If there
are several unknowns, each solution will be a list of equations for the
unknowns.  For example,
\begin{verbatim}
        solve(x^2=1,x);             ->  {X=-1,X=1}

        solve(x^7-x^6+x^2=1,x)      ->  {X**6+X+1=0,X=1}

        solve({x+3y=7,y-x=1},{x,y}) ->  {{X=1,Y=2}}.
\end{verbatim}
Solution multiplicities are stored in the global variable {\tt
MULTIPLICITIES!*} rather than the solution list.  The value of this
variable is a list of the multiplicities of the solutions for the last
call of {\tt SOLVE}.  \ttindex{SOLVE} For example,
\begin{verbatim}
        solve(x^2=2x-1,x); multiplicities!*;
\end{verbatim}
gives the results
\begin{verbatim}
        {X=1}

        {2}
\end{verbatim}

If you want the multiplicities explicitly displayed, the switch
{\tt MULTIPLICITIES} \ttindex{MULTIPLICITIES} can be turned on. For example
\begin{verbatim}
        on multiplicities; solve(x^2=2x-1,x);
\end{verbatim}
yields the result
\begin{verbatim}
        {X=1,X=1}
\end{verbatim}

For one equation, {\tt SOLVE} \ttindex{SOLVE} recursively uses
factorization and decomposition, together with the known inverses of
{\tt LOG}, {\tt SIN}, {\tt COS}, {\tt \^{ }}, {\tt ACOS}, {\tt ASIN}, and
linear, quadratic, cubic, quartic, or binomial factors.  For
simultaneous linear equations, the built-in matrix equation solvers are
used, {\tt SOLVE} merely providing a convenient form of input for small
or sparse systems.

\subsection{Options}

If {\tt SOLVESINGULAR} \ttindex{SOLVESINGULAR} is on (the default setting),
degenerate systems such as {\tt x+y=0,2x+2y=0} will be solved by
introducing appropriate arbitrary constants.
The consistent singular equation 0=0 or equations involving functions with
multiple inverses may introduce unique new indeterminant kernels
{\tt ARBCOMPLEX(j)}, {\tt ARBREAL(j)}, or {\tt ARBINT(j)}, ($j$=1,2,...),
representing arbitrary complex, real or integer numbers respectively.  To
automatically select the principal branches, do {\tt off allbranch;} .
\ttindex{ALLBRANCH}
To suppress solutions of consistent singular equations do
{\tt OFF SOLVESINGULAR}.

To incorporate additional inverse functions do, for example:
\begin{verbatim}
        put('sinh,'inverse,'asinh);
        put('asinh,'inverse,'sinh);
\end{verbatim}
together with any desired simplification rules such as
\begin{verbatim}
        for all x let sinh(asinh(x))=x, asinh(sinh(x))=x;
\end{verbatim}
For completeness, functions with non-unique inverses should be treated as
{\tt \^{ }}, {\tt SIN}, and {\tt COS} are in the {\tt SOLVE}
\ttindex{SOLVE} module source.

Arguments of {\tt ASIN} and {\tt ACOS} are not checked to insure that the
absolute value of the real part does not exceed 1; and arguments of
{\tt LOG} are not checked to insure that the absolute value of the imaginary
part does not exceed $\pi$; but checks (perhaps involving user response
for non-numerical arguments) could be introduced using
{\tt LET} \ttindex{LET} statements for these operators.

Users should also note that even though the solve package can find exact
solutions for cubics and quartics, the results in most cases are so
intractable that it is better to look for another method of solution.

\section{Linear Operators}\index{Linear operator}
An operator can be declared to be linear in its first argument over powers
of its second argument.  If an operator {\tt F} is so declared, {\tt F} of
any sum is broken up into sums of {\tt F}s, and any factors which are not
powers of the variable are taken outside.  This means that {\tt F} must
have (at least) two arguments.  In addition, the second argument must be
an identifier (or more generally a kernel), not an expression.

{\it Example:}

If {\tt F} were declared linear, then
\begin{verbatim}
                                5
        f(a*x^5+b*x+c,x) ->  F(X ,X)*A + F(X,X)*B + F(1,X)*C
\end{verbatim}
More precisely, not only will the variable and its powers remain within the
scope of the {\tt F} operator, but so will any variable and its powers which had
been declared to {\tt DEPEND} (q.v.) on the prescribed variable; and so would
any expression which contains that variable or a dependent variable on any
level, e.g. {\tt cos(sin(x))}.

To declare operators {\tt F} and {\tt G} to be linear operators,
use:\ttindex{LINEAR}
\begin{verbatim}
        linear f,g;
\end{verbatim}
The analysis is done of the first argument with respect to the second; any
other arguments are ignored. It uses the following rules of evaluation:
\begin{quote}
\begin{tabbing}
{\tt    f(0)      ->   0} \\
{\tt    f(-y,x)   ->  -F(Y,X)} \\
{\tt    f(y+z,x)  ->   F(Y,X)+F(Z,X)} \\
{\tt    f(y*z,x)  ->   Z*F(Y,X)} \hspace{0.5in}\= if Z does not depend on X \\
{\tt    f(y/z,x)  ->   F(Y,X)/Z} \> if Z does not depend on X
\end{tabbing}
\end{quote}
To summarize, {\tt Y} ``depends" on the indeterminate {\tt X} in the above
if either of the following hold:
\begin{enumerate}
\item {\tt Y} is an expression which contains {\tt X} at any level as a
      variable, e.g.: {\tt cos(sin(x))}

\item Any variable in the expression {\tt Y} has been declared dependent on
      {\tt X} by use of the declaration {\tt DEPEND} (q.v.).
\end{enumerate}
The use of such linear operators\index{Linear operator} can be seen in the
paper Fox, J.A. and A. C. Hearn, ``Analytic Computation of Some Integrals
in Fourth Order Quantum Electrodynamics" Journ. Comp. Phys. 14 (1974)
301-317, which contains a complete listing of a program for definite
integration\index{Integration} of some expressions which arise in fourth
order quantum electrodynamics.

\section{Non-Commuting Operators}\index{Non-commuting operator}
An operator can be declared to be non-commutative under multiplication by
the declaration {\tt NONCOM} \ttindex{NONCOM}.

{\it Example:}

After the declaration {\tt noncom u,v;}, the expressions {\tt
u(x)*u(y)-u(y)*u(x)} and {\tt u(x)*v(y)-v(y)*u(x)} will remain unchanged
on simplification, and in particular will not simplify to zero.

Note that it is the operator ({\tt U} and {\tt V} in the above example)
and not the variable that has the non-commutative property.

The {\tt LET} \ttindex{LET} statement may be used to introduce rules of
evaluation for such operators.  In particular, the boolean operator
{\tt ORDP}\ttindex{ORDP} is useful for introducing an ordering on such
expressions.

{\it Example:}

The rule
\begin{verbatim}
        for all x,y such that x neq y and ordp(x,y)
           let u(x)*u(y)= u(y)*u(x)+comm(x,y);
\end{verbatim}
would introduce the commutator of {\tt u(x)} and {\tt u(y)} for all
{\tt X} and {\tt Y}.  Note that since {\tt ordp(x,x)} is {\em true}, the
equality check is necessary in the degenerate case to avoid a circular
loop in the rule.

\section{Symmetric and Antisymmetric Operators}

An operator can be declared to be symmetric with respect to its arguments
by the declaration {\tt SYMMETRIC}. \ttindex{SYMMETRIC} For example
\begin{verbatim}
        symmetric u,v;
\end{verbatim}
means that any expression involving the top level operators {\tt U} or
{\tt V} will have its arguments reordered to conform to the internal order
used by {\REDUCE}.  The user can change this order for kernels by the
command {\tt KORDER} (q.v.).

For example, {\tt u(x,v(1,2))} would become {\tt u(v(2,1),x)}, since
numbers are ordered in decreasing order, and expressions are ordered in
decreasing order of complexity.

An operator can similarly be declared antisymmetric by the declaration
{\tt ANTISYMMETRIC}. \ttindex{ANTISYMMETRIC} For example,
\begin{verbatim}
        antisymmetric l,m;
\end{verbatim}
means that any expression involving the top level operators {\tt L} or
{\tt M} will have its arguments reordered to conform to the internal order
of the system, and the sign of the expression changed if there are an odd
number of argument interchanges necessary to bring about the new order.

For example, {\tt l(x,m(1,2))} would become {\tt -l(-m(2,1),x)} since one
interchange occurs with each operator.  An expression like {\tt l(x,x)}
would also be replaced by 0.

\section{Declaring New Prefix Operators}

The user may add new prefix\index{Prefix} operators to the system by
using the declaration {\tt OPERATOR}. For example:
\begin{verbatim}
        operator h,g1,arctan;
\end{verbatim}
adds the prefix operators {\tt H}, {\tt G1} and {\tt ARCTAN} to the system.

This allows symbols like {\tt h(w), h(x,y,z), g1(p+q), arctan(u/v)} to be
used in expressions, but no meaning or properties of the operator are
implied.  The same operator symbol can be used equally well as a 1-, 2-,
3-, etc.-place operator.

To give a meaning to an operator symbol, or express some of its
properties, {\tt LET} \ttindex{LET} statements can be used, or the operator
can be given a definition as a procedure (q.v.).

If the user forgets to declare an identifier as an operator, the system
will prompt the user to do so in interactive mode, or do it automatically
in non-interactive mode. A diagnostic message will also be printed if an
identifier is declared {\tt OPERATOR} more than once.

Operators once declared are global in scope, and so can then be referenced
anywhere in the program.  In other words, a declaration within a block (or
a procedure) does not limit the scope of the operator to that block, nor
does the operator go away on exiting the block (use {\tt CLEAR} instead
for this purpose).


\section{Declaring New Infix Operators}

Users can add new infix operators by using the declarations
{\tt INFIX} \ttindex{INFIX} and {\tt PRECEDENCE}. \ttindex{PRECEDENCE}
For example,
\begin{verbatim}
        infix mm;
        precedence mm,-;
\end{verbatim}
The declaration {\tt infix mm;} would allow one to use the symbol
{\tt MM} as an infix operator:
\begin{quote}
\hspace{0.2in} {\tt a mm b} \hspace{0.3in} instead of \hspace{0.3in}
{\tt mm(a,b)}.
\end{quote}

The declaration {\tt precedence mm,-;} says that {\tt MM} should be
inserted into the infix operator precedence list (q.v.) just {\em after}
the - operator.  This gives it higher precedence than - and lower
precedence than * .  Thus

\begin{quote}
\hspace{0.2in}{\tt a - b mm c - d}\hspace{.3in} means \hspace{.3in}
{\tt a - (b mm c) - d},
\end{quote}
while
\begin{quote}
\hspace{0.2in}{\tt   a * b mm c * d}\hspace{.3in} means \hspace{.3in}
{\tt (a * b) mm (c * d)}.
\end{quote}

Both infix and prefix\index{Prefix} operators have no transformation
properties unless {\tt LET} \ttindex{LET} statements or procedure
declarations are used to assign a meaning.

We should note here that infix operators so defined are always binary:
\begin{quote}
\hspace{0.2in}{\tt a mm b mm c}\hspace{.3in} means \hspace{.3in}
{\tt (a mm b) mm c}.
\end{quote}

\section{Creating or Removing Variable Dependency}

There are several facilities in {\REDUCE}, such as the differentiation
\index{Differentiation}
operator and the linear operator\index{Linear operator} facility, which
can utilize knowledge of the dependency between various variables, or
kernels (q.v.).  Such dependency may be expressed by the command {\tt
DEPEND}. \ttindex{DEPEND} This takes an arbitrary number of arguments and
sets up a dependency of the first argument on the remaining arguments.
For example,
\begin{verbatim}
        depend x,y,z;
\end{verbatim}
says that {\tt X} is dependent on both {\tt Y} and {\tt Z}.
\begin{verbatim}
        depend z,cos(x),y;
\end{verbatim}
says that {\tt Z} is dependent on {\tt COS(X)} and {\tt Y}.

Dependencies introduced by {\tt DEPEND} can be removed by {\tt NODEPEND}.
\ttindex{NODEPEND} The arguments of this are the same as for {\tt DEPEND}.
For example, given the above dependencies,
\begin{verbatim}
        nodepend z,cos(x);
\end{verbatim}
says that {\tt Z} is no longer dependent on {\tt COS(X)}, although it remains
dependent on {\tt Y}.

\chapter{Display and Structuring of Expressions}\index{Display}
\index{Structuring}
In this section, we consider a variety of commands and operators which
permit the user to obtain various parts of algebraic expressions and also
display their structure in a variety of forms. Also presented are some
additional concepts in the {\REDUCE} design that help the user gain a better
understanding of the structure of the system.

\section{Kernels}\index{Kernel}
{\REDUCE} is designed so that each operator in the system has an
evaluation (or simplification)\index{Simplification} function associated
with it which transforms the expression into an internal canonical form.
\index{Canonical form}  This form, which bears little resemblance to the
original expression, is described in detail in Hearn, A. C., ``{\REDUCE} 2:
A System and Language for Algebraic Manipulation," Proc. of the Second
Symposium on Symbolic and Algebraic Manipulation, ACM, New York (1971)
128-133.

The evaluation function may transform its arguments in one of two
alternative ways.  First, it may convert the expression into other
operators in the system, leaving no functions of the original operator for
further manipulation.  This is in a sense true of the evaluation functions
associated with the operators {\tt +}, {\tt *} and {\tt /} , for example,
because the canonical form\index{Canonical form} does not include these
operators explicitly.  It is also true of an operator such as the
determinant operator {\tt DET} \ttindex{DET} (q.v.) because the relevant
evaluation function calculates the appropriate determinant, and the
operator {\tt DET} no longer appears.  On the other hand, the evaluation
process may leave some residual functions of the relevant operator.  For
example, with the operator {\tt COS}, a residual expression like {\tt
COS(X)} may remain after evaluation unless a rule for the reduction of
cosines into exponentials, for example, were introduced.  These residual
functions of an operator are termed {\em kernels}\index{Kernel} and are
stored uniquely like variables.  Subsequently, the kernel is carried
through the calculation as a variable unless transformations are
introduced for the operator at a later stage.

In those cases where the evaluation process leaves an operator expression
with non-trivial arguments, the form of the argument can vary depending on
the state of the system at the point of evaluation.  Such arguments are
normally produced in expanded form with no terms factored or grouped in
any way.  For example, the expression {\tt cos(2*x+2*y)} will normally be
returned in the same form.  If the argument {\tt 2*x+2*y} were evaluated
at the top level, however, it would be printed as {\tt 2*(X+Y)}.  If it is
desirable to have the arguments themselves in a similar form, the switch
{\tt INTSTR} \ttindex{INTSTR} (for ``internal structure"), if on, will
cause this to happen.

In cases where the arguments of the kernel operators may be reordered, the
system puts them in a canonical order, based on an internal intrinsic
ordering of the variables. However, some commands allow arguments in the
form of kernels, and the user has no way of telling what internal order the
system will assign to these arguments. To resolve this difficulty, we
introduce the notion of a kernel form as an expression which transforms to
a kernel on evaluation.

Examples of kernel forms are:
\begin{verbatim}
        a
        cos(x*y)
        log(sin(x))
\end{verbatim}
whereas
\begin{verbatim}
        a*b
        (a+b)^4
\end{verbatim}
are not.

We see that kernel forms can usually be used as generalized variables, and
most algebraic properties associated with variables may also be associated
with kernels.

\section{The Expression Workspace}\index{Workspace}

Several mechanisms are available for saving and retrieving previously
evaluated expressions.  The simplest of these refers to the last algebraic
expression simplified.  When an assignment of an algebraic expression is
made, or an expression is evaluated at the top level, (i.e., not inside a
compound statement or procedure) the results of the evaluation are
automatically saved in a variable {\tt WS} which we shall refer to as the
workspace. (More precisely, the expression is assigned to the variable
{\tt WS} which is then available for further manipulation.)

{\it Example:}

If we evaluate the expression {\tt (x+y)\^{ }2} at the top level and next
wish to differentiate it with respect to {\tt Y}, we can simply say
\begin{verbatim}
        df(ws,y);
\end{verbatim}
to get the desired answer.

If the user wishes to assign the workspace to a variable or expression for
later use, the {\tt SAVEAS} \ttindex{SAVEAS} statement can be used.  It
has the syntax
\begin{verbatim}
        SAVEAS <expression>
\end{verbatim}
For example, after the differentiation in the last example, the workspace
holds the expression {\tt 2*x+2*y}.  If we wish to assign this to the
variable {\tt Z} we can now say
\begin{verbatim}
        saveas z;
\end{verbatim}
If the user wishes to save the expression in a form that allows him to use
some of its variables as arbitrary parameters, the {\tt FOR ALL} (q.v.)
command can be used.

{\it Example:}
\begin{verbatim}
        for all x saveas h(x);
\end{verbatim}

with the above expression would mean that {\tt h(z)} evaluates to {\tt
2*Y+2*Z}.

A further method for referencing more than the last expression is described
in the section on interactive use of {\REDUCE}.


\section{Output of Expressions}

A considerable degree of flexibility is available in {\REDUCE} in the
printing of expressions generated during calculations.  No explicit format
statements are supplied, as these are in most cases of little use in
algebraic calculations, where the size of output or its composition is not
generally known in advance.  Instead, {\REDUCE} provides a series of mode
options to the user which should enable him to produce his output in a
comprehensible and possibly pleasing form.

The most extreme option offered is to suppress the output entirely from
any top level evaluation.  This is accomplished by turning off the switch
{\tt OUTPUT} \ttindex{OUTPUT} which is normally on.  It is useful for
limiting output when loading large files or producing ``clean" output from
the prettyprint programs (q.v.).

In most circumstances, however, we wish to view the output, so we need to
know how to format it appropriately.  As we mentioned earlier, an
algebraic expression is normally printed in an expanded form, filling the
whole output line with terms.  Certain output declarations, \index{Output
declaration} however, can be used to affect this format.  To begin with,
we look at an operator for changing the length of the output line.

\subsection{LINELENGTH Operator}\ttindex{LINELENGTH}

This operator is used with the syntax
\begin{verbatim}
        LINELENGTH(NUM:integer):integer
\end{verbatim}
and sets the output line length to the integer {\tt NUM}. It returns the
previous output line length (so that it can be stored for later resetting
of the output line if needed).

\subsection{Output Declarations}

We now describe a number of switches and declarations which are available
for controlling output formats. It should be noted, however, that the
transformation of large expressions to produce these varied output formats
can take a lot of computing time and space. If a user wishes to speed up
the printing of the output in such cases, he can turn off the switch {\tt
PRI}. \ttindex{PRI} If this is done, then output is produced in one fixed
format, which basically reflects the internal form of the expression, and
none of the options below apply. {\tt PRI} is normally on.

With {\tt PRI} on, the output declarations\index{Output declaration}
and switches available are as follows:

\subsubsection{ORDER Declaration}

The declaration {\tt ORDER} \ttindex{ORDER} may be used to order variables
on output.  The syntax is:
\begin{verbatim}
        order v1,...vn;
\end{verbatim}
where the {\tt vi} are kernels (q.v.). Thus,
\begin{verbatim}
        order x,y,z;
\end{verbatim}
orders {\tt X} ahead of {\tt Y}, {\tt Y} ahead of {\tt Z} and all three
ahead of other variables not given an order. {\tt order nil;} resets the
output order to the system default.  The order of variables may be changed
by further calls of {\tt ORDER}, but then the reordered variables would
have an order lower than those in earlier {\tt ORDER} \ttindex{ORDER} calls.
Thus,
\begin{verbatim}
        order x,y,z;
        order y,x;
\end{verbatim}
would order {\tt Z} ahead of {\tt Y} and {\tt X}.  The default ordering is
implementation dependent, but is usually alphabetic.

\subsubsection{FACTOR Declaration}

This declaration takes a list of identifiers or kernels\index{Kernel}
(q.v.) as argument. {\tt FACTOR} is not a factoring command (use {\tt
FACTORIZE} or the {\tt FACTOR} switch (q.v.) for this purpose); rather it
is a separation command.  All terms involving fixed powers of the declared
expressions are printed as a product of the fixed powers and a sum of the
rest of the terms.

All expressions involving a given prefix operator may also be factored by
putting the operator name in the list of factored identifiers. For example:
\begin{verbatim}
        factor x,cos,sin(x);
\end{verbatim}
causes all powers of {\tt X} and {\tt SIN(X)} and all functions of
{\tt COS} to be factored.

The declaration {\tt remfac v1,...,vn;} \ttindex{REMFAC} removes the
factoring flag from the expressions {\tt v1} through {\tt vn}.

\subsection{Output Control Switches}
\label{sec-output}
In addition to these declarations, the form of the output can be modified
by switching various output control switches using the declarations
{\tt ON} and {\tt OFF}.  We shall illustrate the use of these switches by an
example, namely the printing of the expression
\begin{verbatim}
        x^2*(y^2+2*y)+x*(y^2+z)/(2*a) .
\end{verbatim}
The relevant switches are as follows:

\subsubsection{ALLFAC Switch}

This switch will cause the system to search the whole expression, or any
sub-expression enclosed in parentheses, for simple multiplicative factors
and print them outside the parentheses. Thus our expression with {\tt ALLFAC}
\ttindex{ALLFAC}
off will print as
\begin{verbatim}
            2  2        2          2
        (2*X *Y *A + 4*X *Y*A + X*Y  + X*Z)/(2*A)
\end{verbatim}
and with {\tt ALLFAC} on as
\begin{verbatim}
                2                2
        X*(2*X*Y *A + 4*X*Y*A + Y  + Z)/(2*A) .
\end{verbatim}
{\tt ALLFAC} is normally on, and is on in the following examples, except
where otherwise stated.

\subsubsection{DIV Switch}\ttindex{DIV}

This switch makes the system search the denominator of an expression for
simple factors which it divides into the numerator, so that rational
fractions and negative powers appear in the output. With {\tt DIV} on, our
expression would print as
\begin{verbatim}
              2                2  (-1)        (-1)
        X*(X*Y  + 2*X*Y + 1/2*Y *A     + 1/2*A    *Z) .
\end{verbatim}
{\tt DIV} is normally off.

\subsubsection{LIST Switch}\ttindex{LIST}

This switch causes the system to print each term in any sum on a separate
line. With {\tt LIST} on, our expression prints as
\begin{verbatim}
                2
        X*(2*X*Y *A

            + 4*X*Y*A

               2
            + Y

            + Z)/(2*A) .
\end{verbatim}
{\tt LIST} is normally off.

\subsubsection{NOSPLIT Switch}\ttindex{NOSPLIT}

Under normal circumstances, the printing routines try to break an expression
across lines at a natural point.  This is a fairly expensive process.  If
you are not overly concerned about where the end-of-line breaks come, you
can speed up the printing of expressions by turning off the switch
{\tt NOSPLIT}.  This switch is normally on.

\subsubsection{RAT Switch}\ttindex{RAT}

This switch is only useful with expressions in which variables are
factored with {\tt FACTOR}. With this mode, the overall denominator of the
expression is printed with each factored sub-expression. We assume a prior
declaration {\tt factor x;} in the following output. We first print the
expression with {\tt RAT off}:
\begin{verbatim}
            2                   2
        (2*X *Y*A*(Y + 2) + X*(Y  + Z))/(2*A) .
\end{verbatim}
With {\tt RAT} on the output becomes:
\begin{verbatim}
         2                 2
        X *Y*(Y + 2) + X*(Y  + Z)/(2*A) .
\end{verbatim}
{\tt RAT} is normally off.

Next, if we leave {\tt X} factored, and turn on both {\tt DIV} and
{\tt RAT}, the result becomes
\begin{verbatim}
         2                    (-1)   2
        X *Y*(Y + 2) + 1/2*X*A    *(Y  + Z) .
\end{verbatim}
Finally, with {\tt X} factored, {\tt RAT} on and {\tt ALLFAC} \ttindex{ALLFAC}
off we retrieve the original structure
\begin{verbatim}
         2   2              2
        X *(Y  + 2*Y) + X*(Y  + Z)/(2*A) .
\end{verbatim}

\subsubsection{RATPRI Switch}\ttindex{RATPRI}

If the numerator and denominator of an expression can each be printed in
one line, the output routines will print them in a two dimensional
notation, with numerator and denominator on separate lines and a line of
dashes in between. For example, {\tt (a+b)/2} will print as
\begin{verbatim}
        A + B
        -----
          2
\end{verbatim}
Turning this switch off causes such expressions to be output in a linear
form.

\subsubsection{REVPRI Switch}\ttindex{REVPRI}

The normal ordering of terms in output is from highest to lowest power.
In some situations (e.g., when a power series is output), the opposite
ordering is more convenient.  The switch {\tt REVPRI} if on causes such a
reverse ordering of terms.  For example, the expression
{\tt y*(x+1)\^{ }2+(y+3)\^{ }2} will normally print as
\begin{verbatim}
         2              2
        X *Y + 2*X*Y + Y  + 7*Y + 9
\end{verbatim}
whereas with {\tt REVPRI} on, it will print as
\begin{verbatim}
                   2            2
        9 + 7*Y + Y  + 2*X*Y + X *Y.
\end{verbatim}

\subsection{WRITE Command} \ttindex{WRITE}

In simple cases no explicit output\index{Output} command is necessary in
{\REDUCE}, since the value of any expression is automatically printed if a
semicolon is used as a delimiter.  There are, however, several situations
in which such a command is useful.

In a {\tt FOR}, {\tt WHILE}, or {\tt REPEAT} statement it may be desired
to output something each time the statement within the loop construct is
repeated.

It may be desired for a procedure to output intermediate results or other
information while it is running. It may be desired to have results labeled
in special ways, especially if the output is directed to a file or device
other than the terminal.

The {\tt WRITE} command consists of the word {\tt WRITE} followed by one
or more items separated by commas, and followed by a terminator.  There
are three kinds of items which can be used:
\begin{enumerate}
\item Expressions (including variables and constants).  The expression is
evaluated, and the result is printed out.

\item Assignments.  The expression on the right side of the {\tt :=}
operator is evaluated, and is assigned to the variable on the left; then
the symbol on the left is printed, followed by a ``{\tt :=}", followed by
the value of the expression on the right -- almost exactly the way an
assignment followed by a semicolon prints out normally. (The difference is
that if the {\tt WRITE} is in a {\tt FOR} statement and the left-hand side
of the assignment is an array position or something similar containing the
variable of the {\tt FOR} iteration, then the value of that variable is
inserted in the printout.)

\item Arbitrary strings of characters, preceded and followed by double-quote
marks (e.g., {\tt "string"}).
\end{enumerate}
The items specified by a single {\tt WRITE} statement print side by side
on one line. (The line is broken automatically if it is too long.) Strings
print exactly as quoted.  The {\tt WRITE} command itself however does not
return a value.

The print line is closed at the end of a {\tt WRITE} command evaluation.
Therefore the command {\tt WRITE "";} (specifying nothing to be printed
except the empty string) causes a line to be skipped.

{\it Examples:}
\begin{enumerate}
\item If {\tt A} is {\tt X+5}, {\tt B} is itself, {\tt C} is 123, {\tt M} is
an array, and {\tt Q}=3, then
\begin{verbatim}
        write m(q):=a," ",b/c," THANK YOU";
\end{verbatim}
will set {\tt M(3)} to {\tt x+5} and print
\begin{verbatim}
        M(Q) := X + 5 B/123 THANK YOU
\end{verbatim}
The blanks between the {\tt 5} and {\tt B}, and the
{\tt 3} and {\tt T}, come from the blanks in the quoted strings.

\item To print a table of the squares of the integers from 1 to 20:
\begin{verbatim}
        for i:=1:20 do write i," ",i^2;
\end{verbatim}

\item To print a table of the squares of the integers from 1 to 20, and at
the same time store them in positions 1 to 20 of an array {\tt A:}
\begin{verbatim}
        for i:=1:20 do <<a(i):=i^2; write i," ",a(i)>>;
\end{verbatim}
This will give us two columns of numbers. If we had used
\begin{verbatim}
        for i:=1:20 do write i," ",a(i):=i^2;
\end{verbatim}
we would also get {\tt A(}i{\tt ) := } repeated on each line.

\item The following more complete example calculates the famous f and g
series, first reported in Sconzo, P., LeSchack, A. R., and Tobey, R.,
``Symbolic Computation of f and g Series by Computer", Astronomical Journal
70 (May 1965).
\begin{verbatim}
 x1:= -sig*(mu+2*eps)$
 x2:= eps-2*sig^2$
 x3:= -3*mu*sig$
 f:= 1$
 g:= 0$
 for i:= 1 step 1 until 10 do begin
    f1:= -mu*g + x1*df(f,eps) + x2*df(f,sig) + x3*df(f,mu);
    write "f(",i,") := ",f1;
    g1:= f + x1*df(g,eps) + x2*df(g,sig) + x3*df(g,mu);
    write "g(",i,") := ",g1;
    f:=f1$
    g:=g1$
   end;
\end{verbatim}
 A portion of the output, to illustrate the printout from the {\tt WRITE}
command, is as follows:
\begin{verbatim}
                ... <prior output> ...

                           2
 F(4) := MU*(3*EPS - 15*SIG  + MU)

 G(4) := 6*SIG*MU

                                    2
 F(5) := 15*SIG*MU*( - 3*EPS + 7*SIG  - MU)

                           2
 G(5) := MU*(9*EPS - 45*SIG  + MU)

                ... <more output> ...

\end{verbatim}
\end{enumerate}
\subsection{Suppression of Zeros}

It is sometimes annoying to have zero assignments (i.e. assignments of the
form {\tt <expression> := 0}) printed, especially in printing large arrays
with many zero elements.  The output from such assignments can be
suppressed by turning on the switch {\tt NERO}. \ttindex{NERO}

\subsection{{FORTRAN} Style Output Of Expressions}

It is naturally possible to evaluate expressions numerically in {\REDUCE} by
giving all variables and sub-expressions numerical values. However, as we
pointed out elsewhere the user must declare real arithmetical operation by
turning on the switch {\tt ROUNDED}\ttindex{ROUNDED}.  However, it should be
remembered that arithmetic in {\REDUCE} is not particularly fast, since
results are interpreted rather than evaluated in a compiled form. The user
with a large amount of numerical computation after all necessary algebraic
manipulations have been performed is therefore well advised to perform
these calculations in a FORTRAN\index{FORTRAN} or similar system.  For
this purpose, {\REDUCE} offers facilities for users to produce FORTRAN
compatible files for numerical processing.

First, when the switch {\tt FORT} \ttindex{FORT} is on, the system will
print expressions in a FORTRAN notation.  Expressions begin in column
seven.  If an expression extends over one line, a continuation mark (.)
followed by a blank appears on subsequent cards.  After a certain number
of lines have been produced (according to the value of the variable {\tt
*CARDNO} (q.v.)), a new expression is started.  If the expression printed
arises from an assignment to a variable, the variable is printed as the
name of the expression.  Otherwise the expression is given the default
name {\tt ANS}.  An error occurs if identifiers or numbers are outside the
bounds permitted by FORTRAN.

A second option is to use the {\tt WRITE} command to produce other programs.

{\it Example:}

The following {\REDUCE} statements
\begin{verbatim}
 on fort;
 out "forfil";
 write "C     THIS IS A FORTRAN PROGRAM";
 write " 1    FORMAT(E13.5)";
 write "      U=1.23";
 write "      V=2.17";
 write "      W=5.2";
 x:=(u+v+w)^11;
 write "C     IT WAS FOOLISH TO EXPAND THIS EXPRESSION";
 write "      PRINT 1,X";
 write "      END";
 shut "forfil";
 off fort;
\end{verbatim}
will generate a file {\tt forfil} which contains:

\begin{verbatim}
C THIS IS A FORTRAN PROGRAM
 1    FORMAT(E13.5)
      U=1.23
      V=2.17
      W=5.2
      ANS1=1320.*U**3*V*W**7+165.*U**3*W**8+55.*U**2*V**9+495.*U
     . **2*V**8*W+1980.*U**2*V**7*W**2+4620.*U**2*V**6*W**3+
     . 6930.*U**2*V**5*W**4+6930.*U**2*V**4*W**5+4620.*U**2*V**3*
     . W**6+1980.*U**2*V**2*W**7+495.*U**2*V*W**8+55.*U**2*W**9+
     . 11.*U*V**10+110.*U*V**9*W+495.*U*V**8*W**2+1320.*U*V**7*W
     . **3+2310.*U*V**6*W**4+2772.*U*V**5*W**5+2310.*U*V**4*W**6
     . +1320.*U*V**3*W**7+495.*U*V**2*W**8+110.*U*V*W**9+11.*U*W
     . **10+V**11+11.*V**10*W+55.*V**9*W**2+165.*V**8*W**3+330.*
     . V**7*W**4+462.*V**6*W**5+462.*V**5*W**6+330.*V**4*W**7+
     . 165.*V**3*W**8+55.*V**2*W**9+11.*V*W**10+W**11
      X=U**11+11.*U**10*V+11.*U**10*W+55.*U**9*V**2+110.*U**9*V*
     . W+55.*U**9*W**2+165.*U**8*V**3+495.*U**8*V**2*W+495.*U**8
     . *V*W**2+165.*U**8*W**3+330.*U**7*V**4+1320.*U**7*V**3*W+
     . 1980.*U**7*V**2*W**2+1320.*U**7*V*W**3+330.*U**7*W**4+462.
     . *U**6*V**5+2310.*U**6*V**4*W+4620.*U**6*V**3*W**2+4620.*U
     . **6*V**2*W**3+2310.*U**6*V*W**4+462.*U**6*W**5+462.*U**5*
     . V**6+2772.*U**5*V**5*W+6930.*U**5*V**4*W**2+9240.*U**5*V
     . **3*W**3+6930.*U**5*V**2*W**4+2772.*U**5*V*W**5+462.*U**5
     . *W**6+330.*U**4*V**7+2310.*U**4*V**6*W+6930.*U**4*V**5*W
     . **2+11550.*U**4*V**4*W**3+11550.*U**4*V**3*W**4+6930.*U**
     . 4*V**2*W**5+2310.*U**4*V*W**6+330.*U**4*W**7+165.*U**3*V
     . **8+1320.*U**3*V**7*W+4620.*U**3*V**6*W**2+9240.*U**3*V**
     . 5*W**3+11550.*U**3*V**4*W**4+9240.*U**3*V**3*W**5+4620.*U
     . **3*V**2*W**6+ANS1
C     IT WAS FOOLISH TO EXPAND THIS EXPRESSION
      PRINT 1,X
      END
\end{verbatim}

If the arguments of a {\tt WRITE} statement include an expression that
requires continuation records, the output will need editing, since the
output routine prints the arguments of {\tt WRITE} sequentially, and the
continuation mechanism therefore generates its auxiliary variables after
the preceding expression has been printed.

Finally, since there is no direct analog of {\em list} in FORTRAN,
a comment line of the form
\begin{verbatim}
        C ***** INVALID FORTRAN CONSTRUCT (LIST) NOT PRINTED
\end{verbatim}
will be printed if you try to print a list with {\tt FORT} on.

\subsubsection{{FORTRAN} Output Options}\index{Output}\index{FORTRAN}

There are a number of methods available to change the default format of the
FORTRAN output.

The breakup of the expression into subparts is such that the number of
continuation lines produced is less than a given number. This number can
be modified by the assignment
\begin{verbatim}
        cardno!* := <number>;
\end{verbatim}
where {\tt <number>} is the {\em total} number of cards allowed in a
statement. {\tt CARDNO!*} is initially set to 20.

The width of the output expression is also adjustable by the assignment
\begin{verbatim}
        fortwidth!* := <integer>;
\end{verbatim}
which sets the total width of a given line to {\tt <integer>}. The initial
FORTRAN output width is 70.

{\REDUCE} automatically inserts a decimal point after each isolated integer
coefficient in a FORTRAN expression (so that, for example, 4 becomes
{\tt 4.} ). To prevent this, set the {\tt PERIOD} \ttindex{PERIOD}
mode switch to {\tt OFF}.

Finally, the default name {\tt ANS} assigned to an unnamed expression and
its subparts can be changed by the operator {\tt VARNAME}.
\ttindex{VARNAME}  This takes a single identifier as argument, which then
replaces {\tt ANS} as the expression name.  The value of {\tt VARNAME} is
its argument.

Further facilities for the production of FORTRAN and other language output
are provided by the SCOPE and GENTRAN packages described in the chapter on
user contributed packages.

\subsection{Saving Expressions for Later Use as Input}
\index{Saving an expression}

It is often useful to save an expression on an external file for use later
as input in further calculations. The commands for opening and closing
output files are explained elsewhere. However, we see in the examples on
output of expressions that the standard ``natural" method of printing
expressions is not compatible with the input syntax. So to print the
expression in an input compatible form we must inhibit this natural style
by turning off the switch {\tt NAT}. \ttindex{NAT} If this is done, a
dollar sign will also be printed at the end of the expression.

{\it Example:}

The following sequence of commands
\begin{verbatim}
        off nat; out "out"; x := (y+z)^2; write "end";
        shut "out"; on nat;
\end{verbatim}
will generate a file {\tt out} which contains
\begin{verbatim}
        X := Y**2 + 2*Y*Z + Z**2$
        END$
\end{verbatim}

\subsection{Displaying Expression Structure}\index{Displaying structure}

In those cases where the final result has a complicated form, it is often
convenient to display the skeletal structure of the answer.  The operator
{\tt STRUCTR},\ttindex{STRUCTR} which takes a single expression as argument,
will do this for you.  Its syntax is:
\begin{verbatim}
   STRUCTR(EXPRN:algebraic[,ID1:identifier[,ID2:identifier]]);
\end{verbatim}
The structure is printed effectively as a tree, in which the subparts are
laid out with auxiliary names.  If the optional {\tt ID1} is absent, the
auxiliary names are prefixed by the root {\tt ANS}.  This root may be
changed by the operator {\tt VARNAME} \ttindex{VARNAME} (q.v.).  If the
optional {\tt ID1} is present, and is an array name, the subparts are
named as elements of that array, otherwise {\tt ID1} is used as the root
prefix. (The second optional argument {\tt ID2} is explained later.)

The {\tt EXPRN} can be either a scalar or a matrix expression.  Use of any
other will result in an error.

{\it Example:}

Let us suppose that the workspace contains {\tt ((A+B)\^{ }2+C)\^{ }3+D}.
Then the input {\tt STRUCTR WS;} will (with {\tt EXP} off) result in the
output:
\begin{verbatim}
        ANS3

           where

                          3
              ANS3 := ANS2  + D

                          2
              ANS2 := ANS1  + C

              ANS1 := A + B
\end{verbatim}
The workspace remains unchanged after this operation, since {\tt STRUCTR}
\ttindex{STRUCTR} in the default situation returns
no value (if {\tt STRUCTR} is used as a sub-expression, its value is taken
to be 0).  In addition, the sub-expressions are normally only displayed
and not retained. If you wish to access the sub-expressions with their
displayed names, the switch {\tt SAVESTRUCTR} \ttindex{SAVESTRUCTR} should be
turned on.  In this case, {\tt STRUCTR} returns a list whose first element
is a representation for the expression, and subsequent elements are the
sub-expression relations.  Thus, with {\tt SAVESTRUCTR} on, {\tt STRUCTR WS}
in the above example would return
\begin{verbatim}
                       3              2
        {ANS3,ANS3=ANS2  + D,ANS2=ANS1  + C,ANS1=A + B}
\end{verbatim}
Alternatively the {\tt PART} \ttindex{PART} operator (q.v.) can
be used to retrieve the required parts of the expression.  For example, to
get the term corresponding to {\tt ANS2} in the above, one could say:
\begin{verbatim}
        part(ws,1,1);
\end{verbatim}
If {\tt FORT} is on, then the results are printed in the reverse order; the
algorithm in fact guaranteeing that no sub-expression will be referenced
before it is defined.  The second optional argument {\tt ID2} may also be
used in this case to name the actual expression (or expressions in the
case of a matrix argument).

{\it Example:}

Let us suppose that {\tt M}, a 2 by 1 matrix, contains the elements {\tt
((a+b)\^{ }2 + c)\^{ }3 + d} and {\tt (a + b)*(c + d)} respectively, and that
{\tt V} has been declared to be an array.  With {\tt EXP} off and {\tt
FORT} on, the statement {\tt structr(2*m,v,k);} will result in the output

\begin{verbatim}
      V(1)=A+B
      V(2)=V(1)**2+C
      V(3)=V(2)**3+D
      V(4)=C+D
      K(1,1)=2.*V(3)
      K(2,1)=2.*V(1)*V(4)
\end{verbatim}

\section{Changing the Internal Order of Variables}

The internal ordering of variables (more specifically kernels) can have
a significant effect on the space and time associated with a calculation.
In its default state, {\REDUCE} uses a specific order for this which may
vary between sessions.  However, it is possible for the user to change
this internal order by means of the declaration
{\tt KORDER} \ttindex{KORDER}.  The syntax for this is:
\begin{verbatim}
        korder v1,...,vn;
\end{verbatim}
where the {\tt Vi} are kernels\index{Kernel}.  With this declaration, the
{\tt Vi} are ordered internally ahead of any other kernels in the system.
{\tt V1} has the highest order, {\tt V2} the next highest, and so on.  A
further call of {\tt KORDER} replaces a previous one. {\tt KORDER NIL;}
resets the internal order to the system default.

Unlike the {\tt ORDER} \ttindex{ORDER} declaration (q.v.), which has a purely
cosmetic effect on the way results are printed, the use of {\tt KORDER}
can have a significant effect on computation time.  In critical cases
then, the user can experiment with the ordering of the variables used to
determine the optimum set for a given problem.

\section{Obtaining Parts of Algebraic Expressions}

There are many occasions where it is desirable to obtain a specific part
of an expression, or even change such a part to another expression. A
number of operators are available in {\REDUCE} for this purpose, and will be
described in this section. In addition, operators for obtaining specific
parts of polynomials and rational functions (such as a denominator) are
described in another section.

\subsection{COEFF Operator}\ttindex{COEFF}
Syntax:
\begin{verbatim}
        COEFF(EXPRN:polynomial,VAR:kernel)
\end{verbatim}
{\tt COEFF} is an operator which partitions {\tt EXPRN} into its various
coefficients with respect to {\tt VAR} and returns them as a list, with
the coefficient independent of {\tt VAR} first.

Under normal circumstances, an error results if {\tt EXPRN} is not a
polynomial in {\tt VAR}, although the coefficients themselves can be
rational as long as they do not depend on {\tt VAR}.  However, if the
switch {\tt RATARG} \ttindex{RATARG} is on, denominators are not checked for
dependence on {\tt VAR}, and are taken to be part of the coefficients.

{\it Example:}
\begin{verbatim}
        coeff((y^2+z)^3/z,y);
\end{verbatim}
returns the result
\begin{verbatim}
          2
        {Z ,0,3*Z,0,3,0,1/Z}.
\end{verbatim}
whereas
\begin{verbatim}
        coeff((y^2+z)**3/z,y);
\end{verbatim}
gives an error if {\tt RATARG} is off, and the result
\begin{verbatim}
          3        2
        {Z /Y,0,3*Z /Y,0,3*Z/Y,0,1/Y}
\end{verbatim}
if {\tt RATARG} is on.

The length of the result of {\tt COEFF} is the highest power of {\tt VAR}
encountered plus 1.  In the above examples it is 7.  In addition, the
variable {\tt HIPOW!*}\ttindex{HIPOW"!*} is set to the highest non-zero
power found in {\tt EXPRN} during the evaluation, and {\tt LOWPOW!*}
\ttindex{LOPOW"!*} to the lowest non-zero power, or zero if there is a
constant term.  If {\tt EXPRN} is a constant, then {\tt HIPOW!*} and {\tt
LOWPOW!*} are both set to zero.

\subsection{COEFFN Operator}\ttindex{COEFFN}

The {\tt COEFFN} operator is designed to give the user a particular
coefficient of a variable in a polynomial, as opposed to {\tt COEFF} which
returns all coefficients. {\tt COEFFN} is used with the syntax
\begin{verbatim}
        COEFFN(EXPRN:polynomial,VAR:kernel,N:integer)
\end{verbatim}
It returns the $n^{th}$ coefficient of {\tt VAR} in the polynomial
{\tt EXPRN}.

\subsection{PART Operator}\ttindex{PART}
Syntax:
\begin{verbatim}
        PART(EXPRN:algebraic[,INTEXP:integer])
\end{verbatim}

This operator works on the form of the expression as printed {\em or as it
would have been printed at that point in the calculation} bearing in mind
all the relevant switch settings at that point.  The reader therefore
needs some familiarity with the way that expressions are represented in
prefix form in {\REDUCE} to use these operators effectively.  Furthermore,
it is assumed that {\tt PRI} is {\tt ON} at that point in the calculation.
The reason for this is that with {\tt PRI} off, an expression is printed
by walking the tree representing the expression internally.  To save
space, it is never actually transformed into the equivalent prefix
expression as occurs when {\tt PRI} is on.  However, the operations on
polynomials described elsewhere can be equally well used in this case to
obtain the relevant parts.

The evaluation proceeds recursively down the integer expression list. In
other words,
\begin{verbatim}
     PART(<expression>,<integer1>,<integer2>)
         ->  PART(PART(<expression>,<integer1>),<integer2>)
\end{verbatim}
 and so on, and
\begin{verbatim}
        PART(<expression>) ->  <expression>.
\end{verbatim}
{\tt INTEXP} can be any expression that evaluates to an integer.  If the
integer is positive, then that term of the expression is found.  If the
integer is 0, the operator is returned.  Finally, if the integer is
negative, the counting is from the tail of the expression rather than the
head.

For example, if the expression {\tt a+b} is printed as {\tt A+B} (i.e.,
the ordering of the variables is alphabetical), then
\begin{verbatim}
        part(a+b,2)  ->   B
        part(a+b,-1) ->   B
and
        part(a+b,0)  ->  PLUS
\end{verbatim}
An operator {\tt ARGLENGTH} \ttindex{ARGLENGTH} is available to determine
the number of arguments of the top level operator in an expression.  If
the expression does not contain a top level operator, then -1 is returned.
For example,
\begin{verbatim}
        arglength(a+b+c) ->  3
        arglength(f())   ->  0
        arglength(a)     ->  -1
\end{verbatim}

\subsection{Changing Parts of Expressions}

{\tt PART} may also be used to change a given part of an expression.  In
this case, the {\tt PART} construct appears on the left-hand side of an
assignment statement, and the expression to replace the given part on the
right-hand side.

For example, with the normal settings of {\REDUCE's} switches:
\begin{verbatim}
        part(a+b,2) := c;   ->  A+C
        part(a+b,0) := -;   ->  A-B
\end{verbatim}

\chapter{Polynomials and Rationals}

Many operations in computer algebra are concerned with polynomials
\index{Polynomial} and rational functions\index{Rational function}.  In
this section, we review some of the switches and operators available for
this purpose.  These are in addition to those that work on general
expressions (such as {\tt DF} and {\tt INT}) described elsewhere.  In the
case of operators, the arguments are first simplified before the
operations are applied.  In addition, they operate only on arguments of
prescribed types, and produce a type mismatch error if given arguments
which cannot be interpreted in the required mode with the current switch
settings.  For example, if an argument is required to be a kernel and
{\tt a/2} is used (with no other rules for {\tt A}), an error
\begin{verbatim}
        A/2 invalid as kernel
\end{verbatim}
will result.

With the exception of those that select various parts of a polynomial or
rational function, these operations have potentially significant effects on
the space and time associated with a given calculation. The user should
therefore experiment with their use in a given calculation in order to
determine the optimum set for a given problem.

One such operation provided by the system is an operator {\tt LENGTH}
\ttindex{LENGTH} which returns the number of top level terms in the
numerator of its argument.  For example,
\begin{verbatim}
        length ((a+b+c)^3/(c+d));
\end{verbatim}
has the value 10.  To get the number of terms in the denominator, one
would first select the denominator by the operator {\tt DEN} \ttindex{DEN}
(q.v.) and then call {\tt LENGTH}, as in
\begin{verbatim}
        length den ((a+b+c)^3/(c+d));
\end{verbatim}
Other operations currently supported, the relevant switches and operators,
and the required argument and value modes of the latter, follow.

\section{Controlling the Expansion of Expressions}

The switch {\tt EXP} \ttindex{EXP} controls the expansion of expressions.  If
it is off, no expansion of powers or products of expressions occurs.
Users should note however that in this case results come out in a normal
but not necessarily canonical form.  This means that zero expressions
simplify to zero, but that two equivalent expressions need not necessarily
simplify to the same form.

{\it Example:} With {\tt EXP} on, the two expressions
\begin{verbatim}
        (a+b)*(a+2*b)
\end{verbatim}
and
\begin{verbatim}
        a^2+3*a*b+2*b^2
\end{verbatim}
will both simplify to the latter form.  With {\tt EXP}
off, they would remain unchanged, unless the complete factoring {\tt
(ALLFAC)} option were in force. {\tt EXP} is normally on.

Several operators that expect a polynomial as an argument behave
differently when {\tt EXP} is off, since there is often only one term at
the top level.  For example, with {\tt EXP} off
\begin{verbatim}
        length((a+b+c)^3/(c+d));
\end{verbatim}
returns the value 1.

\section{Factorization of Polynomials}\index{Factorization}
{\REDUCE} is capable of factorizing univariate and multivariate polynomials
that have integer coefficients, finding all factors that also have integer
coefficients. The package for doing this was written by Dr. Arthur C.
Norman and Ms. P. Mary Ann Moore at The University of Cambridge. It is
described in P. M. A. Moore and A. C. Norman, ``Implementing a Polynomial
Factorization and GCD Package", Proc. SYMSAC '81, ACM (New York) (1981),
109-116.

The easiest way to use this facility is to turn on the switch
{\tt FACTOR}, which causes all expressions to be output in a factored form.
For example, with {\tt FACTOR} on, the expression {\tt A\^{ }2-B\^{ }2} is
returned as {\tt (A+B)*(A-B)}.

It is also possible to factorize a given expression explicitly.  The
operator {\tt FACTORIZE} \ttindex{FACTORIZE} that invokes this facility is
used with the syntax
\begin{verbatim}
     FACTORIZE(EXPRN:polynomial[,INTEXP:prime integer]):list,
\end{verbatim}
the optional argument of which will be described later. Thus to find and
display all factors of the cyclotomic polynomial $x^{105}-1$, one could
write:
\begin{verbatim}
        factorize(x^105-1);
\end{verbatim}
In the above example, there is no overall numerical factor in the result,
so the results will consist only of polynomials in x.  The number of such
polynomials can be found by using the operator {\tt LENGTH} \ttindex{LENGTH}
(q.v.).  If there is a numerical factor, as in factorizing
$(12*x^{2}-12)$, that factor will appear as the first member of the
result.  It will however not be factored further.  Prime factors of such
numbers can be found using the switch {\tt IFACTOR} \ttindex{IFACTOR}.  For
example,
\begin{verbatim}
        on ifactor; factorize(12x^2-12);
\end{verbatim}
would result in the output
\begin{verbatim}
        {2,2,3,X - 1,X + 1}.
\end{verbatim}
Note that the {\tt IFACTOR} switch only affects the result of {\tt FACTORIZE}.
It has no effect if the {\tt FACTOR} \ttindex{FACTOR} switch is also on.

The order in which the factors occur in the result (with the exception of
a possible overall numerical coefficient which comes first) is system
dependent and should not be relied on. Similarly it should be noted that
any pair of individual factors can be negated without altering their
product, and that {\REDUCE} may sometimes do that.

The factorizer works by first reducing multivariate problems to univariate
ones and then solving the univariate ones modulo small primes. It normally
selects both evaluation points and primes using a random number generator
that should lead to different detailed behavior each time any particular
problem is tackled. If, for some reason, it is known that a certain
(probably univariate) factorization can be performed effectively with a
known prime, {\tt P} say, this value of {\tt P} can be handed to
{\tt FACTORIZE} \ttindex{FACTORIZE} as a second
argument. An error will occur if a non-prime is provided to {\tt FACTORIZE} in
this manner. It is also an error to specify a prime that divides the
discriminant of the polynomial being factored, but users should note that
this condition is not checked by the program, so this capability should be
used with care.

Factorization can be performed over a number of polynomial coefficient
domains in addition to integers. The particular description of the relevant
domain should be consulted to see if factorization is supported. For
example, the following statements will factorize $x^{4}+1$ modulo 7:
\begin{verbatim}
        setmod 7;
        on modular;
        factorize(x^4+1);
\end{verbatim}
The factorization module is provided with a trace facility that may be useful
as a way of monitoring progress on large problems, and of satisfying
curiosity about the internal workings of the package. The most simple use
of this is enabled by issuing the {\REDUCE} command \ttindex{TRFAC}
{\tt on trfac;} .
Following this, all calls to the factorizer will generate informative
messages reporting on such things as the reduction of multivariate to
univariate cases, the choice of a prime and the reconstruction of full
factors from their images.  Further levels of detail in the trace are
intended mainly for system tuners and for the investigation of suspected
bugs.  For example, {\tt TRALLFAC} gives tracing information at all levels
of detail.  The switch that can be set by {\tt on timings;} makes it
possible for one who is familiar with the algorithms used to determine
what part of the factorization code is consuming the most resources.
{\tt on overview}; reduces the amount of detail presented in other forms of
trace.  Other forms of trace output are enabled by directives of the form
\begin{verbatim}
        symbolic set!-trace!-factor(<number>,<filename>);
\end{verbatim}
where useful numbers are 1,2,3 and 100,101,... .  This facility is
intended to make it possible to discover in fairly great detail what just
some small part of the code has been doing - the numbers refer mainly to
depths of recursion when the factorizer calls itself, and to the split
between its work forming and factorizing images and reconstructing full
factors from these.  If {\tt NIL} is used in place of a filename the trace
output requested is directed to the standard output stream.  After use of
this trace facility the generated trace files should be closed by calling
\begin{verbatim}
        symbolic close!-trace!-files();
\end{verbatim}
{\it CAUTION:}  The factorization code is very large, and therefore takes
considerable time to load.  As a result, there is some delay when the
factorizer is first used.  In addition, using the factorizer with {\tt
MCD} \ttindex{MCD} off will result in an error.

\section{Cancellation of Common Factors}
Facilities are available in {\REDUCE} for cancelling common factors in the
numerators and denominators of expressions, at the option of the user. The
system will perform this greatest common divisor computation if the switch
{\tt GCD} \ttindex{GCD} is on. ({\tt GCD} is normally off.)

A check is automatically made, however, for common variable and numerical
products in the numerators and denominators of expressions, and the
appropriate cancellations made.

When {\tt GCD} is on, and {\tt EXP} is off, a check is made for square
free factors in an expression.  This includes separating out and
independently checking the content of a given polynomial where
appropriate. (For an explanation of these terms, see Anthony C. Hearn,
``Non-Modular Computation of Polynomial GCDs Using Trial Division", Proc.
EUROSAM 79, published as Lecture Notes on Comp.  Science, Springer-Verlag,
Berlin, No 72 (1979) 227-239.)

{\it Example:} With {\tt EXP} \ttindex{EXP} off and {\tt GCD} \ttindex{GCD}
on,
the polynomial {\tt a*c+a*d+b*c+b*d} would be returned as {\tt (A+B)*(C+D)}.

Under normal circumstances, GCDs are computed using an algorithm described
in the above paper. It is also possible in {\REDUCE} to compute gcd's using
an alternative algorithm, called the EZGCD Algorithm, which uses modular
arithmetic.  The switch {\tt EZGCD} \ttindex{EZGCD}, if on in addition to
{\tt GCD}, makes this happen.

In non-trivial cases, the EZGCD algorithm is almost always better
than the basic algorithm, often by orders of magnitude.  We therefore
{\em strongly} advise users to use the {\tt EZGCD} switch where they have the
resources available for supporting the package.

For a description of the EZGCD algorithm, see J. Moses and D.Y.Y. Yun,
``The EZ GCD Algorithm", Proc. ACM 1973, ACM, New York (1973) 159-166.

{\it CAUTION:} The code for the EZGCD package is quite large. Consequently,
there is usually a delay when it is first used while that module is
loaded. Note also that this package shares code with the factorizer, so a
certain amount of trace information can be produced using the factorizer
trace switches.

\subsection{Determining the GCD of Two Polynomials}
This operator, used with the syntax
\begin{verbatim}
        GCD(EXPRN1:polynomial,EXPRN2:polynomial):polynomial,
\end{verbatim}
returns the greatest common divisor of the two polynomials {\tt EXPRN1} and
{\tt EXPRN2}.

{\it Examples:}
\begin{verbatim}
        gcd(x^2+2*x+1,x^2+3*x+2) ->  X+1
        gcd(2*x^2-2*y^2,4*x+4*y) ->  2*X+2*Y
        gcd(x^2+y^2,x-y)         ->  1.
\end{verbatim}

\section{Working with Least Common Multiples}

Greatest common divisor calculations can often become expensive if
extensive work with large rational expressions is required. However, in
many cases, the only significant cancellations arise from the fact that
there are often common factors in the various denominators which are
combined when two rationals are added. Since these denominators tend to be
smaller and more regular in structure than the numerators, considerable
savings in both time and space can occur if a full GCD check is made when
the denominators are combined and only a partial check when numerators are
constructed. In other words, the true least common multiple of the
denominators is computed at each step. The switch {\tt LCM} \ttindex{LCM}
is available for this purpose, and is normally on.

In addition, the operator {\tt LCM}, \ttindex{LCM} used with the syntax
\begin{verbatim}
        LCM(EXPRN1:polynomial,EXPRN2:polynomial):polynomial,
\end{verbatim}
returns the least common multiple of the two polynomials {\tt EXPRN1} and
{\tt EXPRN2}.

{\it Examples:}
\begin{verbatim}
        lcm(x^2+2*x+1,x^2+3*x+2) ->  X**3 + 4*X**2 + 5*X + 2
        lcm(2*x^2-2*y^2,4*x+4*y) ->  4*(X**2 - Y**2)
\end{verbatim}

\section{Controlling Use of Common Denominators}

When two rational functions are added, {\REDUCE} normally produces an
expression over a common denominator. However, if the user does not want
denominators combined, he or she can turn off the switch {\tt MCD}
\ttindex{MCD} which controls this process.  The latter switch is
particularly useful if no greatest common divisor calculations are
desired, or excessive differentiation of rational functions is required.

{\it CAUTION:}  With {\tt MCD} off, results are not guaranteed to come out in
either normal or canonical form.  In other words, an expression equivalent
to zero may in fact not be simplified to zero.  This option is therefore
most useful for avoiding expression swell during intermediate parts of a
calculation.

{\tt MCD}\ttindex{MCD} is normally on.

\section{REMAINDER Operator}\ttindex{REMAINDER}

This operator is used with the syntax
\begin{verbatim}
     REMAINDER(EXPRN1:polynomial,EXPRN2:polynomial):polynomial.
\end{verbatim}
It returns the remainder when {\tt EXPRN1} is divided by {\tt EXPRN2}.  This
is the true remainder based on the internal ordering of the variables, and
not the pseudo-remainder.

{\it Examples:}
\begin{verbatim}
        remainder((x+y)*(x+2*y),x+3*y) ->  2*Y**2
        remainder(2*x+y,2)             ->  Y.
\end{verbatim}

\section{RESULTANT Operator}\ttindex{RESULTANT}

This is used with the syntax
\begin{verbatim}
     RESULTANT(EXPRN1:polynomial,EXPRN2:polynomial,VAR:kernel):
        polynomial.
\end{verbatim}
It computes the resultant of the two given polynomials with respect to the
given variable. The result can be identified as the determinant of a
Sylvester matrix, but can often also be thought of informally as the
result obtained when the given variable is eliminated between the two input
polynomials. If the two input polynomials have a non-trivial GCD their
resultant vanishes.

The sign conventions used by the resultant function follow those in R.
Loos, ``Computing in Algebraic Extensions" in ``Computer Algebra --- Symbolic
and Algebraic Computation", Second Ed., Edited by B. Buchberger, G.E.
Collins and R. Loos, Springer-Verlag, 1983. Namely, with {\tt A} and {\tt B}
not dependent on {\tt X}:
\newpage
\begin{verbatim}
                               deg(p)*deg(q)
   resultant(p(x),q(x),x)= (-1)             *resultant(q,p,x)

                            deg(p)
   resultant(a,p(x),x)   = a

   resultant(a,b,x)      = 1
\end{verbatim}

\section{DECOMPOSE Operator}\ttindex{DECOMPOSE}

The {\tt DECOMPOSE} operator takes a multivariate polynomial as argument,
and returns an expression and a list of equations from which the
original polynomial can be found by composition.  Its syntax is:
\begin{verbatim}
     DECOMPOSE(EXPRN:polynomial):list.
\end{verbatim}
For example:
\begin{verbatim}
     decompose(x^8-88*x^7+2924*x^6-43912*x^5+263431*x^4-
                    218900*x^3+65690*x^2-7700*x+234)
                   2                  2            2
              -> {U  + 35*U + 234, U=V  + 10*V, V=X  - 22*X}
                                     2
     decompose(u^2+v^2+2u*v+1)  -> {W  + 1, W=U + V}
\end{verbatim}
Users should note however than, unlike factorization, this decomposition
is not unique.

\section{INTERPOL operator}\ttindex{INTERPOL}

Syntax:
\begin{verbatim}
        INTERPOL(<values>,<variable>,<points>);
\end{verbatim}

where {\tt <values>} and {\tt <points>} are lists of equal length and
{\tt <variable>} is an algebraic expression (preferably a kernel).

{\tt INTERPOL} generates an interpolation polynomial {\em f} in the given
variable of degree length({\tt <values>})-1.  The unique polynomial {\em f}
is defined by the property that for corresponding elements {\em v} of
{\tt <values>} and {\em p} of {\tt <points>} the relation $f(p)=v$ holds.

The Aitken-Neville interpolation algorithm is used which guarantees a
stable result even with rounded numbers and an ill-conditioned problem.

\section{Obtaining Parts of Polynomials And Rationals}

These operators select various parts of a polynomial or rational function
structure. Except for the cost of rearrangement of the structure, these
operations take very little time to perform.

For those operators in this section that take a kernel {\tt VAR} as their
second argument, an error results if the first expression is not a
polynomial in {\tt VAR}, although the coefficients themselves can be
rational as long as they do not depend on {\tt VAR}.  However, if the
switch {\tt RATARG} \ttindex{RATARG} is on, denominators are not checked
for dependence on {\tt VAR}, and are taken to be part of the coefficients.

\subsection{DEG Operator}\ttindex{DEG}

This operator is used with the syntax
\begin{verbatim}
        DEG(EXPRN:polynomial,VAR:kernel):integer.
\end{verbatim}
It returns the leading degree\index{Degree} of the polynomial {\tt EXPRN}
in the variable {\tt VAR}.  If {\tt VAR} does not occur as a variable in
{\tt EXPRN}, 0 is returned.

{\it Examples:}
\begin{verbatim}
        deg((a+b)*(c+2*d)^2,a) ->  1
        deg((a+b)*(c+2*d)^2,d) ->  2
        deg((a+b)*(c+2*d)^2,e) ->  0.
\end{verbatim}
Note also that if {\tt RATARG} is on,
\begin{verbatim}
        deg((a+b)^3/a,a)       ->  3
\end{verbatim}
since in this case, the denominator {\tt A} is considered part of the
coefficients of the numerator in {\tt A}.  With {\tt RATARG} off, however,
an error would result in this case.

\subsection{DEN Operator}\ttindex{DEN}

This is used with the syntax:
\begin{verbatim}
        DEN(EXPRN:rational):polynomial.
\end{verbatim}
It returns the denominator of the rational expression {\tt EXPRN}.  If
{\tt EXPRN} is a polynomial, 1 is returned.

{\it Examples:}
\begin{verbatim}
        den(x/y^2)   ->  Y**2
        den(100/6)   ->  3
                [since 100/6 is first simplified to 50/3]
        den(a/4+b/6) ->  12
        den(a+b)     ->  1
\end{verbatim}

\subsection{LCOF Operator}\ttindex{LCOF}

LCOF is used with the syntax
\begin{verbatim}
        LCOF(EXPRN:polynomial,VAR:kernel):polynomial.
\end{verbatim}
It returns the leading coefficient\index{Leading coefficient} of the
polynomial {\tt EXPRN} in the variable {\tt VAR}.  If {\tt VAR} does not
occur as a variable in {\tt EXPRN}, {\tt EXPRN} is returned unchanged.

{\it Examples:}
\begin{verbatim}
        lcof((a+b)*(c+2*d)^2,a) ->  C**2+4*C*D+4*D**2
        lcof((a+b)*(c+2*d)^2,d) ->  4*(A+B)
        lcof((a+b)*(c+2*d),e)   ->  A*C+2*A*D+B*C+2*B*D
\end{verbatim}

\subsection{LTERM Operator}\ttindex{LTERM}

Syntax:
\begin{verbatim}
        LTERM(EXPRN:polynomial,VAR:kernel):polynomial.
\end{verbatim}
LTERM returns the leading term of {\tt EXPRN} with respect to {\tt VAR}.
If {\tt EXPRN} does not depend on {\tt VAR}, 0 is returned.

{\it Examples:}
\begin{verbatim}
        lterm((a+b)*(c+2*d)^2,a) ->  A*(C**2+4*C*D+4*D**2)
        lterm((a+b)*(c+2*d)^2,d) ->  4*D**2*(A+B)
        lterm((a+b)*(c+2*d)^2,e) ->  0
\end{verbatim}

\subsection{MAINVAR Operator}\ttindex{MAINVAR}

Syntax:
\begin{verbatim}
        MAINVAR(EXPRN:polynomial):expression.
\end{verbatim}
Returns the main variable (based on the internal polynomial representation)
of {\tt EXPRN}. If {\tt EXPRN} is a domain element, 0 is returned.

{\it Examples:}

Assuming {\tt A} has higher kernel order than {\tt B}, {\tt C}, or {\tt D}:
\begin{verbatim}
        mainvar((a+b)*(c+2*d)^2) ->  A
        mainvar(2)               ->  0
\end{verbatim}

\subsection{NUM Operator}\ttindex{NUM}

Syntax:
\begin{verbatim}
        NUM(EXPRN:rational):polynomial.
\end{verbatim}
Returns the numerator of the rational expression {\tt EXPRN}.  If {\tt EXPRN}
is a polynomial, that polynomial is returned.

{\it Examples:}
\begin{verbatim}
        num(x/y^2)  ->  X
        num(100/6)   ->  50
        num(a/4+b/6) ->  3*A+2*B
        num(a+b)     ->  A+B
\end{verbatim}

\subsection{REDUCT Operator}\ttindex{REDUCT}

Syntax:
\begin{verbatim}
        REDUCT(EXPRN:polynomial,VAR:kernel):polynomial.
\end{verbatim}
Returns the reductum of {\tt EXPRN} with respect to {\tt VAR} (i.e., the
part of {\tt EXPRN} left after the leading term is removed).  If {\tt
EXPRN} does not depend on the variable {\tt VAR}, {\tt EXPRN} is returned.

{\it Examples:}
\begin{verbatim}
     reduct((a+b)*(c+2*d),a) ->  B*(C + D)
     reduct((a+b)*(c+2*d),d) ->  C*(A + B)
     reduct((a+b)*(c+2*d),e) ->  A*C + A*D + B*C + B*D
\end{verbatim}

{\COMPATNOTE} In previous versions of REDUCE, {\tt REDUCT} returned zero
if {\tt EXPRN} did not depend on {\tt VAR}.  In the present version, {\tt
EXPRN} is always equal to {\tt LTERM(EXPRN,VAR)} $+$ {\tt
REDUCT(EXPRN,VAR)}.

\section{Polynomial Coefficient Arithmetic}\index{Coefficient}
{\REDUCE} allows for a variety of numerical domains for the numerical
coefficients of polynomials used in calculations.  The default mode is
integer arithmetic, although the possibility of using real coefficients
\index{Real coefficient} has been discussed elsewhere.  Rational
coefficients have also been available by using integer coefficients in
both the numerator and denominator of an expression, using the {\tt ON
DIV} \ttindex{DIV} option (q.v.) to print the coefficients as rationals.
However, {\REDUCE} includes several other coefficient options in its basic
version which we shall describe in this section.  All such coefficient
modes are supported in a table-driven manner so that it is
straightforward to extend the range of possibilities.  A description of
how to do this is given in R.J.  Bradford, A.C.  Hearn, J.A.  Padget and
E. Schr\"ufer, ``Enlarging the {\REDUCE} Domain of Computation," Proc. of
SYMSAC '86, ACM, New York (1986), 100-106.

\subsection{Rational Coefficients in Polynomials}\index{Coefficient}
\index{Rational coefficient}
Instead of treating rational numbers as the numerator and denominator of a
rational expression, it is also possible to use them as polynomial
coefficients directly. This is accomplished by turning on the switch
{\tt RATIONAL}.\ttindex{RATIONAL}

{\it Example:} With {\tt RATIONAL} off, the input expression {\tt a/2}
would be converted into a rational expression, whose numerator was {\tt A}
and denominator 2.  With {\tt RATIONAL} on, the same input would become a
rational expression with numerator {\tt 1/2*A} and denominator {\tt 1}.
Thus the latter can be used in operations that require polynomial input
whereas the former could not.

\subsection{Real Coefficients in Polynomials}\index{Coefficient}
\index{Real coefficient}
The switch {\tt ROUNDED}\ttindex{ROUNDED} permits the use of arbitrary
sized real coefficients in polynomial expressions.  The actual precision
of these coefficients can be set by the operator {\tt PRECISION}.
\ttindex{PRECISION} For example, {\tt precision 50;} sets the precision to
fifty decimal digits.  The default precision is system dependent and can
be found by {\tt precision 0;}.  In this mode, denominators are
automatically made monic, and an appropriate adjustment is made to the
numerator.

{\it Example:} With {\tt ROUNDED} on, the input expression {\tt a/2} would
be converted into a rational expression whose numerator is {\tt 0.5*A} and
denominator {\tt 1}.

Internally, {\REDUCE} uses floating point numbers up to the precision
supported by the underlying machine hardware, and so-called {\em
bigfloats} for higher precision or whenever necessary to represent numbers
whose value cannot be represented in floating point.  The internal
precision is two decimal digits greater than the external precision to
guard against roundoff inaccuracies.  Bigfloats represent the fraction and
exponent parts of a floating-point number by means of (arbitrary
precision) integers, which is a more precise representation in many cases
than the machine floating point arithmetic, but not as efficient.  If a
case arises where use of the machine arithmetic leads to problems, a user
can force {\REDUCE} to use the bigfloat representation at all precisions by
turning on the switch {\tt ROUNDBF}. \ttindex{ROUNDBF}  In rare cases,
this switch is turned on by the system, and the user informed by the
message
\begin{verbatim}
        ROUNDBF turned on to increase accuracy
\end{verbatim}

Rounded numbers are normally printed to the specified precision.  However,
if the user wishes to print such numbers with less precision, the printing
precision can be set by the command {\tt PRINT\_PRECISION}.
\index{Print precision} For example, {\tt print\_precision 5;} will
cause such numbers to be printed with five digits maximum.

Numbers that are stored internally as bigfloats are normally printed with
a space between every five digits to improve readability.  If this
feature is not required, it can be suppressed by turning off the switch
{\tt BFSPACE}. \ttindex{BFSPACE}

Further information on the bigfloat arithmetic may be found in T. Sasaki,
``Manual for Arbitrary Precision Real Arithmetic System in {\REDUCE}",
Department of Computer Science, University of Utah, Technical Note No.
TR-8 (1979).

When a real number is input, it is normally truncated to the precision in
effect at the time the number is read.  If it is desired to keep the full
precision of all numbers input, the switch {\tt ADJPREC} \ttindex{ADJPREC}
(for {\em adjust precision}) can be turned on.  While on, {\tt ADJPREC}
will automatically increase the precision, when necessary, to match that
of any integer or real input, and a message printed to inform the user of
the precision increase.

When {\tt ROUNDED} is on, rational numbers are normally converted to
rounded representation.  However, if a user wishes to keep such numbers in
a rational form until used in an operation that returns a real number,
the switch {\tt ROUNDALL} \ttindex{ROUNDALL} can be turned off.  This
switch is normally on.

Results from rounded calculations are returned in rounded form with two
exceptions: if the result is recognized as {\tt 0} or {\tt 1} to the
current precision, the integer result is returned.

\COMPATNOTE In previous versions of {\REDUCE}, there were two
switches to control the use of floating point arithmetic, namely {\tt
FLOAT} \ttindex{FLOAT} and {\tt BIGFLOAT}. \ttindex{BIGFLOAT} This reflected
the fact that there was a distinction at the {\em user} level between single
and multiple precision real arithmetic.  This distinction has been removed
in the present version, as described above, by the introduction of the
{\tt ROUNDED} switch, with the actual precision controlled by the {\tt
PRECISION} command.  For compatibility, the {\tt FLOAT} and {\tt BIGFLOAT}
switches are still supported.  However, they default to the use of
{\tt ROUNDED} mode, and so results may be different from previous
versions, since the algorithms used have changed.

\subsection{Modular Number Coefficients in Polynomials}\index{Coefficient}
\index{Modular coefficient}
{\REDUCE} includes facilities for manipulating polynomials whose
coefficients are computed modulo a given base.  To use this option, two
commands must be used; {\tt SETMOD} {\tt <integer>},\ttindex{SETMOD} to set
the prime modulus, and {\tt ON MODULAR}\ttindex{MODULAR} to cause the
actual modular calculations to occur.
For example, with {\tt setmod 3;} and {\tt on modular;}, the polynomial
{\tt (a+2*b)$^{ }$3} would become {\tt A\^{ }3+2*B\^{ }3}.

The argument of {\tt SETMOD} is evaluated algebraically, except that
non-modular (integer) arithmetic is used.  Thus the sequence
\begin{verbatim}
        setmod 3; on modular; setmod 7;
\end{verbatim}
will correctly set the modulus to 7.

Users should note that the modular calculations are on the polynomial
coefficients only.  It is not currently possible to reduce the exponents
since no check for a prime modulus is made (which would allow
$x^{p-1}$ to be reduced to 1 mod p).  Note also that any division by a
number not co-prime with the modulus will result in the error ``Invalid
modular division".

\subsection{Complex Number Coefficients in Polynomials}\index{Coefficient}
\index{Complex coefficient}
Although {\REDUCE} routinely treats the square of the variable {\em i} as
equivalent to $-1$, this is not sufficient to reduce expressions involving
{\em i} to lowest terms, or to factor such expressions over the complex
numbers.  For example, in the default case,
\begin{verbatim}
        factorize(a^2+1);
\end{verbatim}
gives the result
\begin{verbatim}
        {A**2+1}
\end{verbatim}
and
\begin{verbatim}
        (a^2+b^2)/(a+i*b)
\end{verbatim}
is not reduced further.  However, if the switch
{\tt COMPLEX} \ttindex{COMPLEX} is turned on, full complex arithmetic is then
carried out.  In other words, the above factorization will give the result
\begin{verbatim}
        {A - I,A + I}
\end{verbatim}
and the quotient will be reduced to {\tt A-I*B}.

The switch {\tt COMPLEX} may be combined with {\tt ROUNDED} to give complex
real numbers; the appropriate arithmetic is performed in this case.

Complex conjugation is used to remove complex numbers from denominators of
expressions.  To do this if {\tt COMPLEX} is off, you must turn the switch
{\tt RATIONALIZE} \ttindex{RATIONALIZE} on.

\chapter{Substitution Commands} \index{Substitution}
An important class of commands in {\REDUCE} is that which defines
substitutions for variables and expressions to be made during the
evaluation of expressions.  Such substitutions use the prefix operator
{\tt SUB}, various forms of the command {\tt LET}, and rule sets.

\section{SUB Operator} \ttindex{SUB}

Syntax:
\begin{verbatim}
        SUB(<substitution_list>,EXPRN1:algebraic):algebraic
\end{verbatim}
where {\tt <substitution\_list>} is a list of one or more equations of the
form
\begin{verbatim}
        VAR:kernel=EXPRN:algebraic
\end{verbatim}
or a kernel that evaluates to such a list.

The {\tt SUB} operator gives the algebraic result of replacing every
occurrence of the variable {\tt VAR} in the expression {\tt EXPRN1} by the
expression {\tt EXPRN}.  Specifically, {\tt EXPRN1} is first evaluated
using all available rules.  Next the substitutions are made, and finally
the substituted expression is reevaluated.  When more than one variable
occurs in the substitution list, the substitution is performed by
recursively walking down the tree representing {\tt EXPRN1}, and replacing
every {\tt VAR} found by the appropriate {\tt EXPRN}.  The {\tt EXPRN} are
not themselves searched for any occurrences of the various {\tt VAR}s.
The trivial case {\tt SUB(EXPRN1)} returns the algebraic value of
{\tt EXPRN1}.

{\it Examples:}
\begin{verbatim}
                                    2              2
     sub({x=a+y,y=y+1},x^2+y^2) -> A  + 2*A*Y + 2*Y  + 2*Y + 1
\end{verbatim}
and with {\tt s := {x=a+y,y=y+1}},
\begin{verbatim}
                                    2              2
     sub(s,x^2+y^2)             -> A  + 2*A*Y + 2*Y  + 2*Y + 1
\end{verbatim}

Note that the global assignments {\tt x:=a+y}, etc., do not take place.

{\tt EXPRN1} can be any valid algebraic expression whose type is such that
a substitution process is defined for it (e.g., scalar expressions, lists
and matrices).  An error will occur if an expression of an invalid type
for substitution occurs either in {\tt EXPRN} or {\tt EXPRN1}.

The braces around the substitution list may also be omitted, as in:

\begin{verbatim}
                                    2              2
     sub(x=a+y,y=y+1,x^2+y^2)   -> A  + 2*A*Y + 2*Y  + 2*Y + 1
\end{verbatim}

\section{LET Rules}  \ttindex{LET}
Unlike substitutions introduced via {\tt SUB} {\tt LET}
rules are global in scope and stay in effect until replaced or {\tt CLEAR}ed.

The simplest use of the {\tt LET} statement is in the form
\begin{verbatim}
        LET <substitution list>
\end{verbatim}
where {\tt <substitution list>} is a list of rules separated by commas, each
of the form:
\begin{verbatim}
        <variable> = <expression>
\end{verbatim}
or
\begin{verbatim}
    <prefix operator>(<argument>,...,<argument>) = <expression>
\end{verbatim}
or
\begin{verbatim}
    <argument> <infix operator>,..., <argument> = <expression>
\end{verbatim}
For example,
\begin{verbatim}
        let {x = y^2,
             h(u,v) = u - v,
             cos(pi/3) = 1/2,
             a*b = c,
             l+m = n,
             w^3 = 2*z - 3,
             z^10 = 0}
\end{verbatim}
The list brackets can be left out if preferred.  The above rules could
also have been entered as seven separate {\tt LET} statements.

After such {\tt LET} rules have been input, {\tt X} will always be
evaluated as the square of {\tt Y}, and so on.  This is so even if at the
time the {\tt LET} rule was input, the variable {\tt Y} had a value other
than {\tt Y}. (In contrast, the assignment {\tt x:=y\^{ }2} will set {\tt X}
equal to the square of the current value of {\tt Y}, which could be quite
different.)

The rule {\tt let a*b=c} means that whenever {\tt A} and {\tt B} are both
factors in an expression their product will be replaced by {\tt C}.  For
example, {\tt a\^{ }5 *} {\tt b\^{ }*w} would be replaced by
{\tt c\^{ }*b\^{ }2*w}.

The rule for {\tt l+m} will not only replace all occurrences of {\tt l+m}
by {\tt N}, but will also normally replace {\tt L} by {\tt n-m}, but not
{\tt M} by {\tt n-l}.  A more complete description of this case is given
in Section~\ref{sec-gensubs}.

The rule pertaining to {\tt w\^{ }3} will apply to any power of {\tt W}
greater than or equal to the third.

Note especially the last example, {\tt let z\^{ }10=0}.  This declaration
means, in effect: ignore the tenth or any higher power of {\tt Z}.  Such
declarations, when appropriate, often speed up a computation to a
considerable degree. (See \index{Asymptotic command}
Asymptotic Commands for more details.)

Any new operators occurring in such {\tt LET} rules will be automatically
declared {\tt OPERATOR} by the system, if the rules are being read from a
file.  If they are being entered interactively, the system will ask
{\tt DECLARE} ... {\tt OPERATOR?} .  Answer {\tt Y} or {\tt N} and hit RETURN.

In each of these examples, substitutions are only made for the explicit
expressions given; i.e., none of the variables may be considered arbitrary
in any sense. For example, the command
\begin{verbatim}
        let h(u,v) = u - v;
\end{verbatim}
will cause {\tt h(u,v)} to evaluate to {\tt U - V}, but will not affect
{\tt h(u,z)} or {\tt H} with any arguments other than precisely the
symbols {\tt U,V}.

These simple {\tt LET} rules are on the same logical level as assignments
made with the := operator.  An assignment {\tt x := p+q} cancels a rule
{\tt let x = y\^{ }2} made earlier, and vice versa.

{\it CAUTION:} A recursive rule such as
\begin{verbatim}
        let x = x + 1;
\end{verbatim}
is erroneous, since any subsequent evaluation of {\tt X} would lead to a
non-terminating chain of substitutions:
\begin{verbatim}
      x -> x + 1 -> (x + 1) + 1 -> ((x + 1) + 1) + 1 -> ...
\end{verbatim}
Similarly, coupled substitutions such as
\begin{verbatim}
        let l = m + n, n = l + r;
\end{verbatim}
would lead to the same error. As a result, if you try to evaluate an {\tt X},
{\tt L} or {\tt N} defined as above, you will get an error such as
\begin{verbatim}
        X improperly defined in terms of itself
\end{verbatim}

Array and matrix elements can appear on the left-hand side of a {\tt LET}
statement. However, because of their ``instant evaluation'' property, it is
the value of the element that is substituted for, rather than the element
itself. E.g.,
\begin{verbatim}
        array a(5);
        a(2) := b;
        let a(2) = c;
\end{verbatim}
results in {\tt B} being substituted by {\tt C}; the assignment for
{\tt a(2)} does not change.

Finally, if an error occurs in any equation in a {\tt LET} statement
(including generalized statements involving {\tt FOR ALL} and {\tt SUCH
THAT)}, the remaining rules are not evaluated.

\subsection{FOR ALL \ldots LET}  \ttindex{FOR ALL}
If a substitution for all possible values of a given argument of an
operator is required, the declaration {\tt FOR ALL} may be used. The
syntax of such a command is
\begin{verbatim}
        FOR ALL <variable>,...,<variable>
                <LET statement> <terminator>
\end{verbatim}
e.g.,
\begin{verbatim}
        for all x,y let h(x,y) = x-y;
        for all x let k(x,y) = x^y;
\end{verbatim}
The first of these declarations would cause {\tt h(a,b)} to be evaluated
as {\tt A-B}, {\tt h(u+v,u+w)} to be {\tt V-W}, etc.  If the operator
symbol {\tt H} is used with more or fewer argument places, not two, the
{\tt LET} would have no effect, and no error would result.

The second declaration would cause {\tt k(a,y)} to be evaluated as
{\tt a\^{ }y}, but would have no effect on {\tt k(a,z)} since the rule
didn't say {\tt FOR ALL Y} ... .

Where we used {\tt X} and {\tt Y} in the examples, any variables could
have been used.  This use of a variable doesn't affect the value it may
have outside the {\tt LET} statement.  However, you should remember what
variables you actually used.  If you want to delete the rule subsequently,
you must use the same variables in the {\tt CLEAR} command (q.v.).

It is possible to use more complicated expressions as a template for a
{\tt LET} statement, as explained in the section on substitutions for
general expressions.  In nearly all cases, the rule will be accepted, and
a consistent application made by the system.  However, if there is a sole
constant or a sole free variable on the left-hand side of a rule (e.g.,
{\tt let 2=3} or {\tt for all x let x=2)}, then the system is unable to
handle the rule, and the error message
\begin{verbatim}
        Substitution for ... not allowed
\end{verbatim}
will be issued.  Any variable listed in the {\tt FOR ALL} part will have
its symbol preceded by an equal sign: {\tt X} in the above example will
appear as {\tt =X}.  An error will also occur if a variable in the
{\tt FOR ALL} part is not properly matched on both sides of the {\tt LET}
equation.

\subsection{FOR ALL \ldots SUCH THAT \ldots LET}
\ttindex{FOR ALL} \ttindex{SUCH THAT}

If a substitution is desired for more than a single value of a variable in
an operator or other expression, but not all values, a conditional form of
the {\tt FOR ALL \ldots LET} declaration can be used.

{\it Example:}
\begin{verbatim}
        for all x such that numberp x and x<0 let h(x)=0;
\end{verbatim}
will cause {\tt h(-5)} to be evaluated as 0, but {\tt H} of a positive
integer, or of an argument which is not an integer at all, would not be
affected.  Any boolean expression can follow the {\tt SUCH THAT} keywords.

\subsection{Removing Assignments and Substitution Rules} \ttindex{CLEAR}

The user may remove all assignments and substitution rules from any
expression by the command {\tt CLEAR}, in the form
\begin{verbatim}
        CLEAR <expression>,...,<expression><terminator>
\end{verbatim}
e.g.
\begin{verbatim}
        clear x, h(x,y);
\end{verbatim}
Because of their ``instant evaluation" property, array and matrix elements
cannot be cleared with {\tt CLEAR}.  For example, if {\tt A} is an array,
you must say
\begin{verbatim}
        a(3) := 0;
\end{verbatim}
rather than
\begin{verbatim}
        clear a(3);
\end{verbatim}
to ``clear" element {\tt a(3)}.

On the other hand, a whole array (or matrix) {\tt A} can be cleared by the
command {\tt clear a};  This means much more than resetting to 0 all the
elements of {\tt A}.  The fact that {\tt A} is an array, and what its
dimensions are, are forgotten, so {\tt A} can be redefined as another type
of object, for example an operator.

The more general types of {\tt LET} declarations can also be deleted by
using {\tt CLEAR}.  Simply repeat the {\tt LET} rule to be deleted, using
{\tt CLEAR} in place of {\tt LET}, and omitting the equal sign and
right-hand part.  The same dummy variables must be used in the {\tt FOR
ALL} part, and the boolean expression in the {\tt SUCH THAT} part must be
written the same way. (The placing of blanks doesn't have to be
identical.)

{\it Example:} The {\tt LET} rule
\begin{verbatim}
        for all x such that numberp x and x<0 let h(x)=0;
\end{verbatim}
can be erased by the command
\begin{verbatim}
        for all x such that numberp x and x<0 clear h(x);
\end{verbatim}

\subsection{Overlapping LET Rules}
{\tt CLEAR} is not the only way to delete a {\tt LET} rule.  A new {\tt
LET} rule identical to the first, but with a different expression after
the equal sign, replaces the first.  Replacements are also made in other
cases where the existing rule would be in conflict with the new rule.  For
example, a rule for {\tt x\^{ }4} would replace a rule for {\tt x\^{ }5}.
The user should however be cautioned against having several {\tt LET}
rules in effect which relate to the same expression.  No guarantee can be
given as to which rules will be applied by {\REDUCE} or in what order.  It
is best to {\tt CLEAR} an old rule before entering a new related {\tt LET}
rule.

\subsection{Substitutions for General Expressions}
\label{sec-gensubs}
The examples of substitutions discussed in other sections have involved
very simple rules. However, the substitution mechanism used in {\REDUCE} is
very general, and can handle arbitrarily complicated rules without
difficulty.

The general substitution mechanism used in {\REDUCE} is discussed in Hearn, A.
C., ``{\REDUCE}, A User-Oriented Interactive System for Algebraic
Simplification,'' Interactive Systems for Experimental Applied Mathematics,
(edited by M. Klerer and J. Reinfelds), Academic Press, New York (1968),
79-90, and Hearn. A. C., ``The Problem of Substitution,'' Proc. 1968 Summer
Institute on Symbolic Mathematical Computation, IBM Programming Laboratory
Report FSC 69-0312 (1969).

For the reasons given in these references, {\REDUCE} does not attempt to
implement a general pattern matching algorithm. However, the present
system uses far more sophisticated techniques than those discussed in the
above papers. It is now possible for the rules appearing in arguments of
{\tt LET} to have the form
\begin{verbatim}
        <substitution expression> = <expression>
\end{verbatim}
where any rule to which a sensible meaning can be assigned is permitted.
However, this meaning can vary according to the form of {\tt <substitution
expression>}. The semantic rules associated with the application of the
substitution are completely consistent, but somewhat complicated by the
pragmatic need to perform such substitutions as efficiently as possible.
The following rules explain how the majority of the cases are handled.

To begin with, the {\tt <substitution expression>} is first partly simplified
by collecting like terms and putting identifiers (and kernels) in the
system order. However, no substitutions are performed on any part of the
expression with the exception of expressions with the ``instant evaluation"
property, such as array and matrix elements, whose actual values are used.
It should also be noted that the system order used is not changeable by the
user, even with the {\tt KORDER} command. Specific cases are then handled as
follows:
\begin{enumerate}
\item If the resulting simplified rule has a left-hand side which is an
identifier, an expression with a top-level algebraic operator or a power,
then the rule is added without further change to the appropriate table.

\item If the operator * appears at the top level of the simplified left-hand
side, then any constant arguments in that expression are moved to the
right-hand side of the rule.  The remaining left-hand side is then added
to the appropriate table.  For example,
\begin{verbatim}
        let 2*x*y=3
\end{verbatim}
becomes
\begin{verbatim}
        let x*y=3/2
\end{verbatim}
so that {\tt x*y} is added to the product substitution table, and when
this rule is applied, the expression {\tt x*y} becomes 3/2, but {\tt X} or
{\tt Y} by themselves are not replaced.

\item If the operators {\tt +}, {\tt -} or {\tt /} appear at the top level
of the simplified left-hand side, all but the first term is moved to the
right-hand side of the rule.  Thus the rules
\begin{verbatim}
        let l+m=n, x/2=y, a-b=c
\end{verbatim}
become
\begin{verbatim}
        let l=n-m, x=2*y, a=c+b.
\end{verbatim}
\end{enumerate}
One problem that can occur in this case is that if a quantified expression
is moved to the right-hand side, a given free variable might no longer
appear on the left-hand side, resulting in an error because of the
unmatched free variable. E.g.,
\begin{verbatim}
        for all x,y let f(x)+f(y)=x*y
\end{verbatim}
would become
\begin{verbatim}
        for all x,y let f(x)=x*y-f(y)
\end{verbatim}
which no longer has {\tt Y} on both sides.

The fact that array and matrix elements are evaluated in the left-hand side
of rules can lead to confusion at times. Consider for example the
statements
\begin{verbatim}
        array a(5); let x+a(2)=3; let a(3)=4;
\end{verbatim}
The left-hand side of the first rule will become {\tt X}, and the second
0.  Thus the first rule will be instantiated as a substitution for
{\tt X}, and the second will result in an error.

The order in which a set of rules is applied is not easily understandable
without a detailed knowledge of the system simplification protocol. It is
also possible for this order to change from release to release, as improved
substitution techniques are implemented. Users should therefore assume
that the order of application of rules is arbitrary, and program
accordingly.

After a substitution has been made, the expression being evaluated is
reexamined in case a new allowed substitution has been generated. This
process is continued until no more substitutions can be made.

As mentioned elsewhere, when a substitution expression appears in a
product, the substitution is made if that expression divides the product.
For example, the rule
\begin{verbatim}
        let a^c = 3*z;
\end{verbatim}
would cause {\tt a\^{ }2*c*x} to be replaced by {\tt 3*Z*X} and
{\tt a\^{ }2*c\^{ }2} by {\tt 3*Z*C}.  If the substitution is desired only
when the substitution expression appears in a product with the explicit
powers supplied in the rule, the command {\tt MATCH} should be used
instead. \ttindex{MATCH}

For example,
\begin{verbatim}
        match a^2*c = 3*z;
\end{verbatim}
would cause {\tt a\^{ }2*c*x} to be replaced by {\tt 3*Z*X}, but
{\tt a\^{ }2*c\^{ }2} would not be replaced. {\tt MATCH} can also be used
with the {\tt FOR ALL} constructions described above.

To remove substitution rules of the type discussed in this section, the
{\tt CLEAR} \ttindex{CLEAR} command can be used, combined, if necessary,
with the same {\tt FOR ALL} clause with which the rule was defined, for
example:
\begin{verbatim}
        for all x clear log(e^x),e^log(x),cos(w*t+theta(x));
\end{verbatim}
Note, however, that the arbitrary variable names in this case {\em must}
be the same as those used in defining the substitution.

\section{Rule Lists} \index{Rule Lists}

Rule lists offer an alternative approach to defining substitutions that is
different from either {\tt SUB} or {\tt LET}.  In fact, they provide the
best features of both, since they have all the capabilities of {\tt LET},
but the rules can also be applied locally as is possible with {\tt SUB}.
In time, they will be used more and more in {\REDUCE}.  However, since they
are relatively new, most {\REDUCE} code you see uses the older constructs.

A rule list is a list of {\em rules} that have the syntax
\begin{verbatim}
        <expression> => <expression> (WHEN <boolean expression>)
\end{verbatim}
For example,
\begin{verbatim}
        {cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2,
         cos(~n*pi)      => (-1)^n when remainder(n,2)=0}
\end{verbatim}

The tilde preceding a variable marks that variable as {\em free} for that
rule, much as a variable in a {\tt FOR ALL} clause in a {\tt LET}
statement.  The first occurrence of that variable in each relevant rule
must be so marked on input, otherwise inconsistent results can occur.
For example, the rule list
\begin{verbatim}
        {cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2,
         cos(x)^2        => (1+cos(2x))/2}
\end{verbatim}
designed to replace products of cosines, would not be correct, since the
second rule would only apply to the explicit argument {\tt X}.  Later
occurrences in the same rule may also be marked, but this is optional
(internally, all such rules are stored with each relevant variable
explicitly marked).  The optional {\tt WHEN} \ttindex{WHEN} clause allows
constraints to be placed on the application of the rule, much as the {\tt
SUCH THAT} clause in a {\tt LET} statement.

A rule set may be named, for example
\begin{verbatim}
        trig1 := {cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2,
                  cos(~x)*sin(~y) => (sin(x+y)-sin(x-y))/2,
                  sin(~x)*sin(~y) => (cos(x-y)-cos(x+y))/2,
                  cos(~x)^2       => (1+cos(2*x))/2,
                  sin(~x)^2       => (1-cos(2*x))/2};
\end{verbatim}

Such named rule lists may be inspected as needed. E.g., the command
{\tt trig1;} would cause the above list to be printed.

Rule lists may be used in two ways.  They can be globally instantiated by
means of the command {\tt LET}.\ttindex{LET} For example,
\begin{verbatim}
        let trig1;
\end{verbatim}
would cause the above set of rules to be globally active from then on until
cancelled by the command {\tt CLEARRULES}, \ttindex{CLEARRULES} as in
\begin{verbatim}
        clearrules trig1;
\end{verbatim}
{\tt CLEARRULES} has the syntax
\begin{verbatim}
        CLEARRULES <rule list>|<name of rule list>(,...) .
\end{verbatim}

The second way to use rule lists is to invoke them locally by means of a
{\tt WHERE} \ttindex{WHERE} clause.  For example
\begin{verbatim}
        cos(a)*cos(b+c)
           where {cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2};
\end{verbatim}
or
\begin{verbatim}
        cos(a)*sin(b) where trigrules;
\end{verbatim}

The syntax of an expression with a {\tt WHERE} clause is:
\begin{verbatim}
        <expression>
            WHERE <rule>|<rule list>(,<rule>|<rule list> ...)
\end{verbatim}
so the first example above could also be written
\begin{verbatim}
        cos(a)*cos(b+c)
           where cos(~x)*cos(~y) => (cos(x+y)+cos(x-y))/2;
\end{verbatim}

The effect of this construct is that the rule set(s) in the {\tt WHERE}
clause only apply to the expression on the left of {\tt WHERE}.  They have
no effect outside the expression.  In particular, they do not affect
previously defined {\tt WHERE} clauses or {\tt LET} statements.  For
example, the sequence
\begin{verbatim}
     let a=2;
     a where a=>4;
     a;
\end{verbatim}
would result in the output
\begin{verbatim}
     4

     2
\end{verbatim}

Although {\tt WHERE} has a precedence less than any other infix operator,
it still binds higher than keywords such as {\tt ELSE}, {\tt THEN},
{\tt DO}, {\tt REPEAT} and so on.  Thus the expression
\begin{verbatim}
        if a=2 then 3 else a+2 where a=3
\end{verbatim}
will parse as
\begin{verbatim}
        if a=2 then 3 else (a+2 where a=3)
\end{verbatim}

{\tt WHERE} may be used to introduce auxiliary variables in symbolic mode
expressions, as described in Section~\ref{sec-lambda}.  However, the
symbolic mode use has different semantics, so expressions do not carry
from one mode to the other.

\COMPATNOTE In order to provide compatibility with older versions of rule
sets released through the Network Library, it is currently possible to use
an equal sign interchangably with the replacement sign {\tt =>} in rules
and {\tt LET} statements.  However, since this may change in future
versions, the replacement sign is preferable in rules and the equal sign
in nonrule-based {\tt LET} statements.

\subsection*{Order of Application of Rules}

If rules have overlapping domains, their order of application is
important.  In general, it is very difficult to specify this order
precisely, so that it is best to assume that the order is arbitrary.
However, if only one operator is involved, the order of application of the
rules for this operator can be determined from the following:

\begin{enumerate}
\item Rules containing at least one free variable apply before all rules
without free variables.
\item Rules activated in the most recent {\tt LET}
command are applied first.
\item {\tt LET} with several entries generate
the same order of application as a corresponding sequence of commands with
one rule or rule set each.
\item Within a rule set, the rules containing at least
one free variable are applied in their given order.
In other words, the first member of the list is applied first.
\item Consistent with the first item, any rule in a rule list that
contains no free variables is applied after all rules containing free
variables.
\end{enumerate}
{\it Example:} The following rule set enables the computation of exact
values of the Gamma function:
\begin{verbatim}
        operator gamma,gamma_error;
        gamma_rules :=
        {gamma(~x)=>sqrt(pi)/2 when x=1/2,
         gamma(~n)=>factorial(n-1) when fixp n and n>0,
         gamma(~n)=>gamma_error(n) when fixp n,
         gamma(~x)=>(x-1)*gamma(x-1) when fixp(2*x) and x>1,
         gamma(~x)=>gamma(x+1)/x when fixp(2*x)};
\end{verbatim}
Here, rule by rule, cases of known or definitely uncomputable values
are sorted out; e.g. the rule leading to the error expression
will be applied for negative integers only, since the positive
integers are caught by the preceding rule, and the
last rule will apply for negative odd multiples of $1/2$ only.
Alternatively the first rule could have been written as
\begin{verbatim}
        gamma(1/2) => sqrt(pi)/2,
\end{verbatim}
but then the case $x=1/2$ should be excluded in the {\tt WHEN} part of the
last rule explicitly because a rule without free variables cannot take
precedence over the other rules.

\section{Asymptotic Commands} \index{Asymptotic command}
In expansions of polynomials involving variables which are known to be
small, it is often desirable to throw away all powers of these variables
beyond a certain point to avoid unnecessary computation.  The command {\tt
LET} may be used to do this.  For example, if only powers of {\tt X} up to
{\tt x\^{ }7} are needed, the command
\begin{verbatim}
        let x^8 = 0;
\end{verbatim}
will cause the system to delete all powers of {\tt X} higher than 7.

{\it CAUTION:}  This particular simplification works differently from most
substitution mechanisms in {\REDUCE} in that it is applied during
polynomial manipulation rather than to the whole evaluated expression.
Thus, with the above rule in effect, {\tt x\^{ }10/x\^{ }5} would give the
result zero, since the numerator would simplify to zero.  Similarly
{\tt x\^{ }20/x\^{ }10} would give a {\tt Zero divisor} error message,
since both numerator and denominator would first simplify to zero.

The method just described is not adequate when expressions involve several
variables having different degrees of smallness. In this case, it is
necessary to supply an asymptotic weight to each variable and count up the
total weight of each product in an expanded expression before deciding
whether to keep the term or not. There are two associated commands in the
system to permit this type of asymptotic constraint. The command {\tt WEIGHT}
\ttindex{WEIGHT}
takes a list of equations of the form
\begin{verbatim}
        <kernel form> = <number>
\end{verbatim}
where {\tt <number>} must be a positive integer (not just evaluate to a
positive integer).  This command assigns the weight {\tt <number>} to the
relevant kernel form.  A check is then made in all algebraic evaluations
to see if the total weight of the term is greater than the weight level
assigned to the calculation.  If it is, the term is deleted.  To compute
the total weight of a product, the individual weights of each kernel form
are multiplied by their corresponding powers and then added.

The weight level of the system is initially set to 2. The user may change
this setting by the command \ttindex{WTLEVEL}
\begin{verbatim}
        wtlevel <number>;
\end{verbatim}
which sets {\tt <number>} as the new weight level of the system.  Again,
{\tt <number>} must be a positive integer.

\chapter{File Handling Commands} \index{File handling}

In many applications, it is desirable to load previously prepared {\REDUCE}
files into the system, or to write output on other files. {\REDUCE} offers
four commands for this purpose, namely, {\tt IN}, {\tt OUT}, {\tt SHUT},
{\tt LOAD}, and {\tt LOAD\_PACKAGE}.  The first \ttindex{IN} \ttindex{OUT}
\ttindex{SHUT} three operators are described here; {\tt LOAD} and {\tt
LOAD\_PACKAGE} are discussed in Section~\ref{sec-load}.

\section{IN Command} \ttindex{IN}
This command takes a list of file names as argument and directs the system
to input \index{Input} each file (which should contain {\REDUCE} statements
and commands) into the system.  File names can either be an identifier or
a string.  The explicit format of these will be system dependent and, in
many cases, site dependent.  The explicit instructions for the
implementation being used should therefore be consulted for further
details. For example:
\begin{verbatim}
        in f1,"ggg.rr.s";
\end{verbatim}
will first load file {\tt F1}, then {\tt ggg.rr.s}.  When a semicolon is
used as the terminator of the IN statement, the statements in the file are
echoed on the terminal or written on the current output file.  If \$
\index{Command terminator} is used as the terminator, the input is not
shown.  Echoing of all or part of the input file can be prevented, even if
a semicolon was used, by placing an {\tt off echo;} \ttindex{ECHO} command
in the input file.

Files to be read using {\tt IN} should end with {\tt ;END;}.  Note the two
semicolons!  First of all, this is protection against obscure difficulties
the user will have if there are, by mistake, more {\tt BEGIN}s than
{\tt END}s on the file.  Secondly, it triggers some file control book-keeping
which may improve system efficiency.  If {\tt END} is omitted, an error
message {\tt "End-of-file read"} will occur.

\section{OUT Command} \ttindex{OUT}
This command takes a single file name as argument, and directs output to
that file from then on, until another {\tt OUT} changes the output file,
or {\tt SHUT} closes it.  Output can go to only one file at a time,
although many can be open.  If the file has previously been used for
output during the current job, and not {\tt SHUT}, \ttindex{SHUT} the new
output is appended to the end of the file.  Any existing file is erased
before its first use for output in a job, or if it had been {\tt SHUT}
before the new {\tt OUT}.

To output on the terminal without closing the output file, the reserved
file name T (for terminal) may be used.  For example,
{\tt out ofile;} will direct output to the file {\tt OFILE} and
{\tt out t;} will direct output to the user's terminal.

The output sent to the file will be in the same form that it would have on
the terminal.  In particular {\tt x\^{ }2} would appear on two lines, an
{\tt X} on the lower line and a 2 on the line above.  If the purpose of the
output file is to save results to be read in later, this is not an
appropriate form.  We first must turn off the {\tt NAT} switch which
specifies that output should be in standard mathematical notation.

{\it Example:} To create a file {\tt ABCD} from which it will be possible
to read -- using {\tt IN} -- the value of the expression {\tt XYZ}:
\begin{verbatim}
 off echo$      % needed if your input is from a file.
 off nat$       % output in IN-readable form. Each expression
                % printed will end with a $ .
 out abcd$      % output to new file
 linelength 72$ % for systems with fixed input line length.
 xyz:=xyz;      % will output "XYZ := " followed by the value
                % of XYZ
 write ";end"$  % standard for ending files for IN
 shut abcd$     % save ABCD, return to terminal output
 on nat$                % restore usual output form
\end{verbatim}

\section{SHUT Command} \ttindex{SHUT}
This command takes a list of names of files which have been previously
opened via an {\tt OUT} statement and closes them. Most systems require this
action by the user before he ends the {\REDUCE} job (if not sooner),
otherwise the output may be lost. If a file is shut and a further {\tt OUT}
command issued for the same file, the file is erased before the new output
is written.

If it is the current output file which is shut, output will switch to the
terminal.  Attempts to shut files that have not been opened by {\tt OUT},
or an input file, will lead to errors.

\chapter{Commands for Interactive Use} \index{Interactive use}

{\REDUCE} is designed as an interactive system, but naturally it can also
operate in a batch processing or background mode by taking its input
command by command from the relevant input stream. There is a basic
difference, however, between interactive and batch use of the system. In
the former case, whenever the system discovers an ambiguity at some point
in a calculation, such as a forgotten type assignment for instance, it asks
the user for the correct interpretation. In batch operation, it is not
practical to terminate the calculation at such points and require
resubmission of the job, so the system makes the most obvious guess of the
user's intentions and continues the calculation.

There is also a difference in the handling of errors.  In the former case,
the computation can continue since the user has the opportunity to correct
the mistake.  In batch mode, the error may lead to consequent erroneous
(and possibly time consuming) computations.  So in the default case, no
further evaluation occurs, although the remainder of the input is checked
for syntax errors.  A message {\tt "Continuing with parsing only"}
informs the user that this is happening.  On the other hand, the switch
{\tt ERRCONT}, \ttindex{ERRCONT} if on, will cause the system to continue
evaluating expressions after such errors occur.

When a syntactical error occurs, the place where the system detected the
error is marked with three dollar signs (\$\$\$). In interactive mode, the
user can then use {\tt ED} \ttindex{ED} to correct the error, or retype the
command.  When a non-syntactical error occurs in interactive mode, the
command being evaluated at the time the last error occurred is saved, and
may later be reevaluated by the command {\tt RETRY}. \ttindex{RETRY}

\section{Referencing Previous Results}

It is often useful to be able to reference results of previous
computations during a {\REDUCE} session.  For this purpose, {\REDUCE}
maintains a history \index{History} of all interactive inputs and the
results of all interactive computations during a given session.  These
results are referenced by the command number that {\REDUCE} prints
automatically in interactive mode.  To use an input expression in a new
computation, one writes {\tt input(}$n${\tt )}, \ttindex{INPUT} where
$n$ is the command number.  To use an output expression, one writes {\tt
WS(}$n${\tt )}. \ttindex{WS} {\tt WS} references the previous command.
E.g., if command number 1 was {\tt INT(X-1,X)}; and the result of command
number 7 was {\tt X-1}, then
\begin{verbatim}
        2*input(1)-ws(7)^2;
\end{verbatim}
would give the result {\tt -1}, whereas
\begin{verbatim}
        2*ws(1)-ws(7)^2;
\end{verbatim}
would yield the same result, but {\em without} a recomputation of the
integral.

The operator {\tt DISPLAY} \ttindex{DISPLAY} is available to display previous
inputs.  If its argument is a positive integer, {\it n} say, then the
previous n inputs are displayed.  If its argument is {\tt ALL} (or in fact
any non-numerical expression), then all previous inputs are displayed.

\section{Interactive Editing}
It is possible when working interactively to edit any {\REDUCE} input that
comes from the user's terminal, and also some user-defined procedure
definitions.  At the top level, one can access any previous command string
by the command {\tt ed(}$n${\tt )}, \ttindex{ED} where n is the desired
command number as prompted by the system in interactive mode. {\tt ED};
(i.e. no argument) accesses the previous command.

After {\tt ED} has been called, you can now edit the displayed string using a
string editor with the following commands:
\begin{verbatim}
     B                   move pointer to beginning
     C<character>        replace next character by <character>
     D                   delete next character
     E                   end editing and reread text
     F<character>        move pointer to next occurrence of
                         <character>
     I<string><escape>   insert <string> in front of pointer
     K<character>        delete all chars until <character>
     P                   print string from current pointer
     Q                   give up with error exit
     S<string><escape>   search for first occurrence of
                         <string> positioning pointer just
                         before it
     <space> or X        move pointer right one char.
\end{verbatim}
The above table can be displayed online by typing a question mark followed
by a carriage return to the editor. The editor prompts with an angle
bracket. Commands can be combined on a single line, and all command
sequences must be followed by a carriage return to become effective.

Thus, to change the command {\tt x := a+1;} to {\tt x := a+2}; and cause
it to be executed, the following edit command sequence could be used:
\begin{verbatim}
        f1c2e<return>.
\end{verbatim}
The interactive editor may also be used to edit a user-defined procedure that
has not been compiled (q.v.). To do this, one says:
\ttindex{EDITDEF}
\begin{verbatim}
        editdef <id>;
\end{verbatim}
where {\tt <id>} is the name of the procedure.  The procedure definition
will then be displayed in editing mode, and may then be edited and
redefined on exiting from the editor.

\section{Interactive File Control}
If input is coming from an external file, the system treats it as a batch
processed calculation.  If the user desires interactive
\index{Interactive use} response in this case, he can include the command
{\tt on int}; \ttindex{INT} in the file.  Likewise, he can issue the
command {\tt off int}; in the main program if he does not desire continual
questioning from the system.  Regardless of the setting of {\tt INT},
input commands from a file are not kept in the system, and so cannot be
edited using {\tt ED}.  However, many implementations of {\REDUCE} provide
a link to an external system editor that can be used for such editing.
The specific instructions for the particular implementation should be
consulted for information on this.

Two commands are available in {\REDUCE} for interactive use of files. {\tt
PAUSE}; \ttindex{PAUSE} may be inserted at any point in an input file.  When
this command is encountered on input, the system prints the message {\tt
CONT?} on the user's terminal and halts.  If the user responds {\tt Y}
(for yes), the calculation continues from that point in the file.  If the
user responds {\tt N} (for no), control is returned to the terminal, and
the user can input further statements and commands.  Later on he can use
the command {\tt cont;} \ttindex{CONT} to transfer control back to the
point in the file following the last {\tt PAUSE} encountered.  A top-level
{\tt pause;} \ttindex{PAUSE} from the user's terminal has no effect.

\chapter{Matrix Calculations} \index{Matrix calculations}
A very powerful feature of {\REDUCE} is the ease with which matrix
calculations can be performed. To extend our syntax to this class of
calculations we need to add another prefix operator, {\tt MAT},
\ttindex{MAT} and a further
variable and expression type as follows:

\section{MAT Operator} \ttindex{MAT}
This prefix operator is used to represent {\em n} x {\em m} matrices. {\tt
MAT} has {\em n} arguments interpreted as rows of the matrix, each of
which is a list of {\em m} expressions representing elements in that row.
For example, the matrix
\[ \left( \begin{array}{lcr} a & b & c \\ d & e & f \end{array} \right) \]
would be written as {\tt mat((a,b,c),(d,e,f))}.

Note that the single column matrix
\[ \left( \begin{array}{c} x \\ y \end{array} \right) \]
becomes {\tt mat((x),(y))}.  The inside parentheses are required to
distinguish it from the single row matrix
\[ \left( \begin{array}{lr} x & y \end{array} \right) \]
which would be written as {\tt mat((x,y))}.

\section{Matrix Variables}

An identifier may be declared a matrix variable by the declaration {\tt
MATRIX}.\ttindex{MATRIX}
The size of the matrix may be declared explicitly in the matrix
declaration, or by default in assigning such a variable to a matrix
expression. For example,
\begin{verbatim}
        matrix x(2,1),y(3,4),z;
\end{verbatim}
declares {\tt X} to be a 2 x 1 (column) matrix, {\tt Y} to be a 3 x 4
matrix and {\tt Z} a matrix whose size is to be declared later.

Matrix declarations can appear anywhere in a program. Once a symbol is
declared to name a matrix, it can not also be used to name an array,
operator or a procedure, or used as an ordinary variable. It can however
be re-declared to be a matrix, and its size may be changed at that time.
Note however that matrices once declared are {\em global} in scope, and so
can then be referenced anywhere in the program.  In other words, a
declaration within a block (or a procedure) does not limit the scope of
the matrix to that block, nor does the matrix go away on exiting the block
(use {\tt CLEAR} instead for this purpose).  An element of a matrix is
referred to in the expected manner; thus {\tt x(1,1)} gives the first
element of the matrix {\tt X} defined above.  References to elements of a
matrix whose size has not yet been declared leads to an error.  All
elements of a matrix whose size is declared are initialized to 0.  As a
result, a matrix element has an ``instant evaluation" \index{Instant
evaluation} property and cannot stand for itself.  If this is required,
then an operator (q.v.) should be used to name the matrix elements as in:
\begin{verbatim}
        matrix m; operator x;  m := mat((x(1,1),x(1,2));
\end{verbatim}

\section{Matrix Expressions}

These follow the normal rules of matrix algebra as defined by the
following syntax: \ttindex{MAT}
\begin{verbatim}
        <matrix expression> ::=
                  MAT<matrix description>|<matrix variable>|
                  <scalar expression>*<matrix expression>|
                  <matrix expression>*<matrix expression>
                  <matrix expression>+<matrix expression>|
                  <matrix expression>^<integer>|
                  <matrix expression>/<matrix expression>
\end{verbatim}
Sums and products of matrix expressions must be of compatible size;
otherwise an error will result during their evaluation.  Similarly, only
square matrices may be raised to a power.  A negative power is computed as
the inverse of the matrix raised to the corresponding positive power.
{\tt a/b} is interpreted as {\tt a*b\^{ }(-1)}.

{\it Examples:}

Assuming {\tt X} and {\tt Y} have been declared as matrices, the following
are matrix expressions
\begin{verbatim}
        y
        y^2*x-3*y^(-2)*x
        y + mat((1,a),(b,c))/2
\end{verbatim}
The computation of the quotient of two matrices normally uses a two-step
elimination method due to Bareiss. An alternative method using Cramer's
method is also available. This is often more efficient than the Bareiss
method, although we have no solid statistics on this as yet. To use Cramer's
method instead, the switch {\tt CRAMER} should be turned on.


\section{Operators with Matrix Arguments}

The operator {\tt LENGTH} (q.v.) \ttindex{LENGTH} applied to a matrix
returns a list of the number of rows and columns in the matrix.  Three
additional operators are useful in matrix calculations, namely {\tt DET},
{\tt TP} and {\tt TRACE} defined in the following subsections.

\subsection{DET Operator} \ttindex{DET}
Syntax:
\begin{verbatim}
        DET(EXPRN:matrix_expression):algebraic.
\end{verbatim}

The operator {\tt DET} is used to represent the determinant of a square
matrix expression.  E.g.,
\begin{verbatim}
        det(y^2)
\end{verbatim}
is a scalar expression whose value is the determinant of the square of the
matrix {\tt Y}, and
\begin{verbatim}
        det mat((a,b,c),(d,e,f),(g,h,j));
\end{verbatim}
is a scalar expression whose value is the determinant of the matrix
\[ \left( \begin{array}{lcr} a & b & c \\ d & e & f \\ g & h & j
\end{array} \right) \]

Determinant expressions have the ``instant evaluation" property.
\index{Instant evaluation}  In other words, the statement
\begin{verbatim}
        let det mat((a,b),(c,d)) = 2;
\end{verbatim}
sets the {\em value} of the determinant to 2, and does not set up a rule
for the determinant itself.

\subsection{MATEIGEN Operator} \ttindex{MATEIGEN}
Syntax:
\begin{verbatim}
        MATEIGEN(EXPRN:matrix_expression,ID):list.
\end{verbatim}

{\tt MATEIGEN} calculates the eigenvalue equation and the corresponding
eigenvectors of a matrix, using the variable {\tt ID} to denote the
eigenvalue.  A square free decomposition of the characteristic polynomial
is carried out.  The result is a list of lists of 3 elements, where the
first element is a square free factor of the characteristic polynomial,
the second its multiplicity and the third the corresponding eigenvector
(as an {\em n} by 1 matrix).  If the square free decomposition was
successful, the product of the first elements in the lists is the minimal
polynomial.  In the case of degeneracy, several eigenvectors can exist for
the same eigenvalue, which manifests itself in the appearance of more than
one arbitrary variable in the eigenvector.  To extract the various parts
of the result use the operations defined on lists.

{\it Example:}
 The command
\begin{verbatim}
        mateigen(mat((2,-1,1),(0,1,1),(-1,1,1)),eta);
\end{verbatim}
gives the output
\begin{verbatim}
        {{ETA - 1,2,

          [ARBCOMPLEX(1)]
          [             ]
          [ARBCOMPLEX(1)]
          [             ]
          [      0      ]

          },

         {ETA - 2,1,

          [      0      ]
          [             ]
          [ARBCOMPLEX(2)]
          [             ]
          [ARBCOMPLEX(2)]

          }}
\end{verbatim}

\subsection{TP Operator} \ttindex{TP}
Syntax:
\begin{verbatim}
        TP(EXPRN:matrix_expression):matrix.
\end{verbatim}

This operator takes a single matrix argument and returns its transpose.

\subsection{Trace Operator} \ttindex{TRACE}
Syntax:
\begin{verbatim}
        TRACE(EXPRN:matrix_expression):algebraic.
\end{verbatim}
The operator {\tt TRACE} is used to represent the trace of a square matrix.

\subsection{Matrix Cofactors} \ttindex{COFACTOR}
Syntax:
\begin{verbatim}
  COFACTOR(EXPRN:matrix_expression,ROW:integer,COLUMN:integer):
           algebraic
\end{verbatim}

The operator {\tt COFACTOR} returns the cofactor of the element in row
{\tt ROW} and column {\tt COLUMN} of the matrix {\tt MATRIX}.  Errors occur
if {\tt ROW} or {\tt COLUMN} do not simplify to integer expressions or if
{\tt MATRIX} is not square.

\subsection{NULLSPACE Operator} \ttindex{NULLSPACE}
Syntax:
\begin{verbatim}
        NULLSPACE(EXPRN:matrix_expression):list
\end{verbatim}
{\tt NULLSPACE} calculates for a matrix {\tt A} a list of linear
independent vectors (a basis) whose linear combinations satisfy the
equation $A x = 0$.  The basis is provided in a form such that as many
upper components as possible are isolated.

Note that with {\tt b := nullspace a} the expression {\tt length b} is the
{\em nullity} of A, and that {\tt second length a - length b} calculates the
{\em rank} of A.  The rank of a matrix expression can also be found more
directly by the {\tt RANK} operator described below.

{\it Example:} The command
\begin{verbatim}
        nullspace mat((1,2,3,4),(5,6,7,8));
\end{verbatim}
   gives the output
 
\begin{verbatim}
        {
         [ 1  ]
         [    ]
         [ 0  ]
         [    ]
         [ - 3]
         [    ]
         [ 2  ]
         ,
         [ 0  ]
         [    ]
         [ 1  ]
         [    ]
         [ - 2]
         [    ]
         [ 1  ]
         }
\end{verbatim}
 
In addition to the {\REDUCE} matrix form, {\tt NULLSPACE} accepts as input a
matrix given as a list of lists, which is interpreted as a row matrix.  If
that form of input is chosen, the vectors in the result will be
represented by lists as well.  This additional input syntax facilitates
the use of {\tt NULLSPACE} in applications different from classical linear
algebra.

\subsection{RANK Operator} \ttindex{RANK}
 
Syntax:
\begin{verbatim}
        RANK(EXPRN:matrix_expression):integer
\end{verbatim}
{\tt RANK} calculates the rank of its argument, which, like {\tt NULLSPACE}
can either be a standard matrix expression, or a list of lists, which can
be interpreted either as a row matrix or a set of equations.

{\tt Example:}

\begin{verbatim}
        rank mat((a,b,c),(d,e,f));
\end{verbatim}
returns the value 2.

\section{Matrix Assignments} \index{Matrix assignment}

Matrix expressions may appear in the right-hand side of assignment
statements. If the left-hand side of the assignment, which must be a
variable, has not already been declared a matrix, it is declared by default
to the size of the right-hand side. The variable is then set to the value
of the right-hand side.

Such an assignment may be used very conveniently to find the solution of a
set of linear equations. For example, to find the solution of the
following set of equations
\begin{verbatim}
        a11*x(1) + a12*x(2) = y1
        a21*x(1) + a22*x(2) = y2
\end{verbatim}
we simply write
\begin{verbatim}
        x := 1/mat((a11,a12),(a21,a22))*mat((y1),(y2));
\end{verbatim}

\section{Evaluating Matrix Elements}

Once an element of a matrix has been assigned, it may be referred to in
standard array element notation.  Thus {\tt y(2,1)} refers to the element
in the second row and first column of the matrix {\tt Y}.

\chapter{Procedures} \ttindex{PROCEDURE}

It is often useful to name a statement for repeated use in calculations
with varying parameters, or to define a complete evaluation procedure for
an operator. {\REDUCE} offers a procedural declaration for this purpose. Its
general syntax is:
\begin{verbatim}
  [<procedural type>] PROCEDURE <name>[<varlist>];<statement>;
\end{verbatim}
where
\begin{verbatim}
        <varlist> ::= (<variable>,...,<variable>)
\end{verbatim}
This will be explained more fully in the following sections.

In the algebraic mode of {\REDUCE} the {\tt <procedure type>} can be
omitted, since the default is {\tt ALGEBRAIC}.  Procedures of type {\tt
INTEGER} or {\tt REAL} may also be used.  In the former case, the system
checks that the value of the procedure is an integer.  At present, such
checking is not done for a real procedure, although this will change in
the future when a more complete type checking mechanism is installed.
Users should therefore only use these types when appropriate.  An empty
variable list may also be omitted.

All user-defined procedures are automatically declared to be operators.

In order to allow users relatively easy access to the whole {\REDUCE} source
program, system procedures are not protected against user redefinition. If
a procedure is redefined, a message
\begin{verbatim}
        *** <procedure name> REDEFINED
\end{verbatim}
is printed. If this occurs, and the user is not redefining his own
procedure, he is well advised to rename it, and possibly start over
(because he has {\em already} redefined some internal procedure whose correct
functioning may be required for his job!)

All required procedures should be defined at the top level, since they
have global scope throughout a program. In particular, an attempt to
define a procedure within a procedure will cause an error to occur.

\section{Procedure Heading} \index{Procedure heading}

Each procedure has a heading consisting of the word {\tt PROCEDURE}
(optionally preceded by the word {\tt ALGEBRAIC}), followed by the name of
the procedure to be defined, and followed by its formal parameters -- the
symbols which will be used in the body of the definition to illustrate
what is to be done.  There are three cases:
\begin{enumerate}
\item No parameters. Simply follow the procedure name with a terminator
(semicolon or dollar sign).
\begin{verbatim}
        procedure abc;
\end{verbatim}

When such a procedure is used in an expression or command, {\tt abc()}, with
empty parentheses, must be written.

\item One parameter.  Enclose it in parentheses {\em or} just leave at
least one space, then follow with a terminator.
\begin{verbatim}
        procedure abc(x);
\end{verbatim}
or
\begin{verbatim}
        procedure abc x;
\end{verbatim}

\item More than one parameter. Enclose them in parentheses, separated by
commas, then follow with a terminator.
\begin{verbatim}
        procedure abc(x,y,z);
\end{verbatim}
\end{enumerate}
Referring to the last example, if later in some expression being evaluated
the symbols {\tt abc(u,p*q,123)} appear, the operations of the procedure
body will be carried out as if {\tt X} had the same value as {\tt U} does,
{\tt Y} the same value as {\tt p*q} does, and {\tt Z} the value 123.  The
values of {\tt X}, {\tt Y}, {\tt Z}, after the procedure body operations
are completed are unchanged.  So, normally, are the values of {\tt U},
{\tt P}, {\tt Q}, and (of course) 123. (This is technically referred to as
call by value.) \index{Call by value}

The reader will have noted the word {\em normally} a few lines earlier. The
call by value protections can be bypassed if necessary, as described
elsewhere.

\section{Procedure Body} \index{Procedure body}

Following the delimiter which ends the procedure heading must be a {\em
single} statement defining the action to be performed or the value to be
delivered.  A terminator must follow the statement.  If it is a semicolon,
the name of the procedure just defined is printed.  It is not printed if a
dollar sign is used.

If the result wanted is given by a formula of some kind, the body is just
that formula, using the variables in the procedure heading.

{\it Simple Example:}

If {\tt f(x)} is to mean {\tt (x+5)*(x+6)/(x+7)}, the entire procedure
definition could read
\begin{verbatim}
        procedure f x; (x+5)*(x+6)/(x+7);
\end{verbatim}
Then {\tt f(10)} would evaluate to 240/17, {\tt f(a-6)} to
{\tt A*(A-1)/(A+1)}, and so on.

{\it More Complicated Example:}

Suppose we need a function {\tt p(n,x)} which, for any positive integer
{\tt N}, is the Legendre polynomial \index{Legendre polynomial} of order
{\em n}. We can define this operator using the
textbook formula defining these functions:
\begin{displaymath}
p_n(x) = \displaystyle{1\over{n!}}\  
\displaystyle{d^n\over dy^n}\ \displaystyle{{1\over{(y^2 - 2xy + 1)
^{{1\over2}}}}}\Bigg\vert_{y=0}
\end{displaymath}
Put into words, the Legendre polynomial $p_n(x)$ is the result of
substituting $y=0$ in the $n^{th}$ partial derivative with respect to $y$
of a certain fraction involving $x$ and $y$, then dividing that by $n!$.

This verbal formula can easily be written in {\REDUCE}:
\begin{verbatim}
        procedure p(n,x);
           sub(y=0,df(1/(y^2-2*x*y+1)^(1/2),y,n))
               /(for i:=1:n product i);
\end{verbatim}
Having input this definition, the expression evaluation
\begin{verbatim}
        2p(2,w);
\end{verbatim}
would result in the output
\begin{verbatim}
           2
        3*W  - 1 .
\end{verbatim}
If the desired process is best described as a series of steps, then a group
or compound statement can be used.

{\it Example:}

The above Legendre polynomial example can be rewritten as a series of steps
instead of a single formula as follows:
\begin{verbatim}
        procedure p(n,x);
          begin scalar seed,deriv,top,fact;
               seed:=1/(y^2 - 2*x*y +1)^(1/2);
               deriv:=df(seed,y,n);
               top:=sub(y=0,deriv);
               fact:=for i:=1:n product i;
               return top/fact
          end;
\end{verbatim}
Procedures may also be defined recursively.  In other words, the procedure
body \index{Procedure body} can include references to the procedure name
itself, or to other procedures which themselves reference the given
procedure.  As an example, we can define the Legendre polynomial through
its standard recurrence relation:
\begin{verbatim}
        procedure p(n,x);
           if n<0 then rederr "Invalid argument to P(N,X)"
            else if n=0 then 1
            else if n=1 then x
            else ((2*n-1)*x*p(n-1,x)-(n-1)*p(n-2,x))/n;
\end{verbatim}

The operator {\tt REDERR} \ttindex{REDERR} in the above example provides
for a simple error exit from an algebraic procedure (and also a block).
It can take a string as argument.

It should be noted however that all the above definitions of {\tt p(n,x)} are
quite inefficient if extensive use is to be made of such polynomials, since
each call effectively recomputes all lower order polynomials. It would be
better to store these expressions in an array, and then use say the
recurrence relation to compute only those polynomials that have not already
been derived. We leave it as an exercise for the reader to write such a
definition.


\section{Using LET Inside Procedures}

By using {\tt LET} \ttindex{LET} instead of an assignment in the procedure
body \index{Procedure body} it is possible to bypass the call-by-value
\index{Call by value} protection.  If {\tt X} is a formal parameter or local
variable of the procedure (i.e. is in the heading or in a local
declaration), and {\tt LET} is used instead of {\tt :=} to make an
assignment to {\tt X}, e.g.

\begin{verbatim}
        let x = 123;
\end{verbatim}
then it is the variable which is the value of {\tt X} that is changed.
This effect also occurs with local variables defined in a block.  If the
value of {\tt X} is not a variable, but a more general expression, then it
is that expression that is used on the left-hand side of the {\tt LET}
statement.  For example, if {\tt X} had the value {\tt p*q}, it is as if
{\tt let p*q = 123} had been executed.

\section{LET Rules as Procedures}

The {\tt LET} \ttindex{LET} statement offers an alternative syntax and
semantics for procedure definition.

In place of
\begin{verbatim}
        procedure abc(x,y,z); <procedure body>;
\end{verbatim}
one can write
\begin{verbatim}
        for all x,y,z let abc(x,y,z) = <procedure body>;
\end{verbatim}
There are several differences to note.

If the procedure body contains an assignment to one of the formal
parameters, e.g.
\begin{verbatim}
        x := 123;
\end{verbatim}
in the {\tt PROCEDURE} case it is a variable holding a copy of the first
actual argument which is changed.  The actual argument is not changed.

In the {\tt LET} case, the actual argument is changed.  Thus, if {\tt ABC}
is defined using {\tt LET}, and {\tt abc(u,v,w)} is evaluated, the value
of {\tt U} changes to 123.  That is, the {\tt LET} form of definition
allows the user to bypass the protections which are enforced by the call
by value conventions of standard {\tt PROCEDURE} definitions.

{\it Example:}  We take our earlier {\tt FACTORIAL} \ttindex{FACTORIAL}
procedure and write it as a {\tt LET} statement.
\begin{verbatim}
        for all n let factorial n =
                    begin scalar m,s;
                    m:=1; s:=n;
                l1: if s=0 then return m;
                    m:=m*s;
                    s:=s-1;
                    go to l1
                end;
\end{verbatim}
The reader will notice that we introduced a new local variable, {\tt S},
and set it equal to {\tt N}.  The original form of the procedure contained
the statement {\tt n:=n-1;}.  If the user asked for the value of {\tt
factorial(5)} then {\tt N} would correspond to -- not just have the value
of -- 5, and {\REDUCE} would object to trying to execute the statement
5:=5-1.

If {\tt PQR} is a procedure with no parameters,
\begin{verbatim}
        procedure pqr;
           <procedure body>;
\end{verbatim}
it can be written as a {\tt LET} statement quite simply:
\begin{verbatim}
        let pqr = <procedure body>;
\end{verbatim}
To call {\em procedure} {\tt PQR}, if defined in the latter form, the empty
parentheses would not be used: use {\tt PQR} not {\tt PQR()} where a call
on the procedure is needed.

The two notations for a procedure with no arguments can be combined. {\tt PQR}
can be defined in the standard {\tt PROCEDURE} form. Then a {\tt LET}
statement
\begin{verbatim}
        let pqr = pqr();
\end{verbatim}
would allow a user to use {\tt PQR} instead of {\tt PQR()} in calling the
procedure.

A feature available with {\tt LET}-defined procedures and not with procedures
defined in the standard way is the possibility of defining partial
functions. \index{Function}
\begin{verbatim}
    for all x such that numberp x let uvw(x)=<procedure body>;
\end{verbatim}
Now {\tt UVW} of an integer would be calculated as prescribed by the procedure
body, while {\tt UVW} of a general argument, such as {\tt Z} or {\tt p+q}
(assuming these evaluate to themselves) would simply stay {\tt uvw(z)}
or {\tt uvw(p+q)} as the case may be.

\chapter{User Contributed Packages} \index{User packages}

The complete {\REDUCE} system includes a number of packages that have been
contributed by users.  These packages are unsupported, but are provided with
the {\REDUCE} distribution as a service to the user community.  All questions
regarding these packages should therefore be directed to their individual
authors, who are solely responsible for their maintenance and development.
There are two classes of such packages.  The first are those for which
explicit files exist in the source, test and documentation directories on the
system tape.  The second are those which are bundled into a single library
directory ``lib" on the system tape, although this organization may
differ from implementation to implementation.

All packages in the first class have been precompiled as part of the
installation process.  However, in order to emphasize the unsupported
nature of these packages, many must be specifically loaded before they can
be used. (Those that are loaded automatically are noted specifically in
their description.) You should consult the user notes for your particular
implementation for further information on whether this is necessary.  If
it is, the relevant command is {\tt LOAD\_PACKAGE}, \index{Load package}
which takes a list of one or more package names as argument, for example:
\begin{verbatim}
        load_package algint;
\end{verbatim}
although this syntax may vary from implementation to implementation.
Packages in the second class must be individually compiled and loaded by
the installer or user.

Most packages come with separate documentation and test file (except for
some very simple packages in the ``lib" directory, and those noted here
that have no additional documentation), which is included, along with the
source of the package, in the {\REDUCE} system distribution.  These items
should be studied for details on the use of any particular package.  We
also list below the packages in the first class available in the current
release of {\REDUCE}, together with a brief paragraph describing their
capabilities.  More detailed documentation may be found in the ``doc''
directory of the REDUCE system distribution.  The packages in the second
class are listed in a header ``README'' file in the ``lib'' directory.

In some cases, the additional documentation for these packages is in plain
text.  However, an increasing number of documents are now being supplied
in {\LaTeX} format (and one in troff form).  Those documents not in plain
text are so noted in the descriptions below.

\section{ALGINT: Integration of Square Roots} \ttindex{ALGINT}

This package, which is an extension of the basic integration package
distributed with {\REDUCE}, will analytically integrate a wide range of
expressions involving square roots where the answer exists in that class
of functions. It is an implementation of the work described in J.H.
Davenport, ``On the Integration of Algebraic Functions", LNCS 102,
Springer Verlag, 1981.  Both this and the source code should be consulted
for a more detailed description of this work.

Once the {\tt ALGINT} package has been loaded, using {\tt LOAD\_PACKAGE},
one enters an expression for integration, as with the regular integrator
(q.v.), for example:
\begin{verbatim}
        int(sqrt(x+sqrt(x**2+1)/x,x);
\end{verbatim}
If one later wishes to integrate expressions without using the facilities of
this package, the switch {\tt ALGINT} \ttindex{ALGINT} should be turned
off.  This is turned on automatically when the package is loaded.

The switches supported by the standard integrator (e.g., {\tt TRINT})
\ttindex{TRINT} are also supported by this package.  In addition, the
switch {\tt TRA}, \ttindex{TRA} if on, will give further tracing
information about the specific functioning of the algebraic integrator.

There is no additional documentation for this package.
\\ \\
Author: James H. Davenport.

\section{ARNUM: An Algebraic Number Package} \ttindex{ARNUM}

This package provides facilities for handling algebraic numbers as
polynomial coefficients in {\REDUCE} calculations. It includes facilities for
introducing indeterminates to represent algebraic numbers, for calculating
splitting fields, and for factoring and finding greatest common divisors
in such domains.
\\ \\
Author: Eberhard Schr\"ufer.

\section{AVECTOR: A Vector Algebra and Calculus Package} \ttindex{AVECTOR}

This package provides REDUCE with the ability to perform vector algebra
using the same notation as scalar algebra.  The basic algebraic operations
are supported, as are differentiation and integration of vectors with
respect to scalar variables, cross product and dot product, component
manipulation and application of scalar functions (e.g. cosine) to a vector
to yield a vector result.

The documentation for this package is in {\LaTeX} format.
\\ \\
Author: David Harper.

\section{COMPACT: A Package for Compacting Expressions} \ttindex{COMPACT}

COMPACT is a package of functions for the reduction of a polynomial in the
presence of side relations.  COMPACT applies the side relations to the
polynomial so that an equivalent expression results with as few terms as
possible.  For example, the evaluation of
\begin{verbatim}
     compact(s*(1-sin x^2)+c*(1-cos x^2)+sin x^2+cos x^2,
             {cos x^2+sin x^2=1});
\end{verbatim}
yields the result
\begin{verbatim}
              2           2
        SIN(X) *C + COS(X) *S + 1
\end{verbatim}

The documentation for this package is in {\LaTeX} format.
\\ \\
Author:  Anthony C. Hearn.

\section{EXCALC: A Differential Geometry Package} \ttindex{EXCALC}

EXCALC is designed for easy use by all who are familiar with the calculus
of Modern Differential Geometry. The program is currently able to handle
scalar-valued exterior forms, vectors and operations between them, as well
as non-scalar valued forms (indexed forms). It is thus an ideal tool for
studying differential equations, doing calculations in general relativity
and field theories, or doing simple things such as calculating the
Laplacian of a tensor field for an arbitrary given frame.
\\ \\
Author: Eberhard Schr\"ufer.


\section{GENTRAN: A Code Generation Package} \ttindex{GENTRAN}

GENTRAN is an automatic code GENerator and TRANslator. It constructs
complete numerical programs based on sets of algorithmic specifications
and symbolic expressions. Formatted FORTRAN, RATFOR, PASCAL or C code can be
generated through a series of interactive commands or under the control of
a template processing routine. Large expressions can be automatically
segmented into subexpressions of manageable size, and a special
file-handling mechanism maintains stacks of open I/O channels to allow
output to be sent to any number of files simultaneously and to facilitate
recursive invocation of the whole code generation process.

The documentation for this package is in {\LaTeX} format.
\\ \\
Author: Barbara L. Gates.

\section{GROEBNER: A Gr\"obner Basis Package}
\index{Gr\"obner basis}

GROEBNER \ttindex{GROEBNER} is a package for the computation of Gr\"obner
Bases using the Buchberger algorithm.  It can be used over a variety of
different coefficient domains, and for different variable and term
orderings.

The documentation for this package is in {\LaTeX} format.
\\ \\
Authors: Herbert Melenk, H.M. M\"oller and Winfried Neun.

\section{LIMITS:  A Package for Finding Limits} \ttindex{LIMITS}

LIMITS is a fast limit package for REDUCE for functions which are
continuous except for computable poles and singularities, based on some
earlier work by Ian Cohen and John P. Fitch.  The Truncated Power Series
package is used for non-critical points, at which the value of the
function is the constant term in the expansion around that point.
L'Hopital's rule is used in critical cases, with preprocessing of
$\infty - \infty$ forms and reformatting of product forms in order to
be able to apply l'Hopital's rule.  A limited amount of bounded arithmetic
is also employed where applicable.

This package defines a {\tt LIMIT} operator, called with the syntax:
\begin{verbatim}
        LIMIT(EXPRN:algebraic,VAR:kernel,LIMPOINT:algebraic):
              algebraic.
\end{verbatim}
For example:
\begin{verbatim}
        limit(x*sin(1/x),x,infinity)   -> 1
        limit(sin x/x^2,x,0)           -> INFINITY
\end{verbatim}
Direction-dependent limit operators {\tt LIMIT!+} and {\tt LIMIT!-} are
also defined.

This package loads automatically.

The documentation for this package is in {\LaTeX} format.
\\ \\
Author: Stanley L. Kameny.

\section{ODESOLVE: A Solver for Ordinary Differential Equations}
\ttindex{ODESOLVE}

The ODESOLVE package is a solver for ordinary differential equations.  At
the present time it has very limited capabilities.  It can handle only a
single scalar equation presented as an algebraic expression or equation,
and it can solve only first-order equations of simple types, linear
equations with constant coefficients and Euler equations.  These solvable
types are exactly those for which Lie symmetry techniques give no useful
information.  For example, the evaluation of
\begin{verbatim}
        depend(y,x);
        odesolve(df(y,x)=x**2+e**x,y,x);
\end{verbatim}
yields the result
\begin{verbatim}
               X                    3
            3*E  + 3*ARBCONST(1) + X
        {Y=---------------------------}
                        3
\end{verbatim}

The documentation for this package is in {\LaTeX} format.
\\ \\
Main Author: Malcolm A.H. MacCallum.

Other contributors: Francis Wright, Alan Barnes.

\section{ORTHOVEC: A Package for the Manipulation of Scalars and Vectors}
\ttindex{ORTHOVEC}

ORTHOVEC is a collection of REDUCE procedures and operations which
provide a simple-to-use environment for the manipulation of scalars and
vectors.  Operations include addition, subtraction, dot and cross
products, division, modulus, div, grad, curl, laplacian, differentiation,
integration, and Taylor expansion.

The documentation for this package is in {\LaTeX} format.
\\ \\
Author: James W. Eastwood.

\section{ROOTS: A REDUCE Root Finding Package} \ttindex{ROOTS}

This root finding package can be used to find some or all of the roots of a
univariate polynomial with real or complex coefficients, to the accuracy
specified by the user.

It is designed so that it can be used as an independent package, or it may
be called from {\tt SOLVE} if {\tt ROUNDED} is on. For example,
the evaluation of
\begin{verbatim}
        on rounded,complex;
        solve(x**3+x+5,x);
\end{verbatim}
yields the result
\begin{verbatim}
    {X= - 1.51598,X=0.75799 + 1.65035*I,X=0.75799 - 1.65035*I}
\end{verbatim}

This package loads automatically.
\\ \\
Author: Stanley L. Kameny.

\section{SCOPE: A Source Code Optimization Package for REDUCE}
\ttindex{SCOPE}

SCOPE is a package for the production of an optimized form of a set of
expressions.  It applies an heuristic search for common (sub)expressions
to almost any set of proper REDUCE assignment statements.  The
output is obtained as a sequence of assignment statements.  GENTRAN is
used to facilitate expression output.

The document for this package is in troff format.
\\ \\
Author:  J.A. van Hulzen.

\section{SPDE: A Package for finding Symmetry groups of {PDE}'s}
\ttindex{SPDE}

The package SPDE provides a set of functions which may be used to
determine the symmetry group of Lie- or point-symmetries of a given system
of partial differential equations. In many cases the determining system is
solved completely automatically. In other cases the user has to provide
additional input information for the solution algorithm to terminate.
\\ \\
Author: Fritz Schwarz.

\section{SUM:  A Package for Series Summation} \ttindex{SUM}

This package implements the Gosper algorithm for the summation of series.
It defines operators {\tt SUM} and {\tt PROD}.  The operator {\tt SUM}
returns the indefinite or definite summation of a given expresson, and
{\tt PROD} returns the product of the given expression.

This package loads automatically.

The documentation for this package is in {\LaTeX} format.
\\ \\
Author: Fujio Kako.

\section{TAYLOR: A Package for the Manipulation of Taylor Series}
\ttindex{TAYLOR}

This package carries out the Taylor expansion of an expression in one or
more variables and efficient manipulation of the resulting Taylor series.
Capabilities include basic operations (addition, subtraction,
multiplication and division) and also application of certain algebraic and
transcendental functions.

The document for this package is in {\LaTeX} format.
\\ \\
Author: Rainer Sch\"opf.

\section{TPS: A Truncated Power Series Package} \ttindex{TPS} \ttindex{PS}

This package implements formal Laurent series expansions in one variable
using the domain mechanism of REDUCE.  This means that power series
objects can be added, multiplied, differentiated etc.,  like other first
class objects in the system.  A lazy evaluation scheme is used and thus
terms of the series are not evaluated until they are required for printing
or for use in calculating terms in other power series.  The series are
extendible giving the user the impression that the full infinite series is
being manipulated.  The errors that can sometimes occur using series that
are truncated at some fixed depth (for example when a term in the required
series depends on terms of an intermediate series beyond the truncation
depth) are thus avoided.

The documentation for this package is in {\LaTeX} format.
\\ \\
Authors:  Alan Barnes and Julian Padget.

\chapter{Symbolic Mode} \index{Symbolic mode}

At the system level, {\REDUCE} is based on a version of the programming
language Lisp \index{Lisp} known as {\em Standard Lisp} which is described
in J.  Marti, Hearn, A. C., Griss, M. L. and Griss, C., ``Standard LISP
Report" SIGPLAN Notices, ACM, New York, 14, No 10 (1979) 48-68.  We shall
assume in this section that the reader is familiar with the material in
that paper.  This also assumes implicitly that the reader has a reasonable
knowledge about Lisp in general, say at the level of the LISP 1.5
Programmer's Manual (McCarthy, J., Abrahams, P. W., Edwards, D. J., Hart,
T. P. and Levin, M. I., ``LISP 1.5 Programmer's Manual", M.I.T.  Press,
1965) or any of the books mentioned at the end of this section.  Persons
unfamiliar with this material will have some difficulty understanding this
section.

Although {\REDUCE} is designed primarily for algebraic calculations, its
source language is general enough to allow for a full range of Lisp-like
symbolic calculations.  To achieve this generality, however, it is
necessary to provide the user with two modes of evaluation, namely an
algebraic mode \index{Algebraic mode} and a symbolic mode. \index{Symbolic
mode} To enter symbolic mode, the user types {\tt symbolic;}
\ttindex{SYMBOLIC} (or {\tt lisp;}) \ttindex{LISP} and to return to
algebraic mode he types {\tt algebraic;}. \ttindex{ALGEBRAIC}.
Evaluations proceed differently in each mode so the user is advised to
check what mode he is in if a puzzling error arises.  He can find his mode
by typing \ttindex{"!*MODE}

\begin{verbatim}
        !*mode;
\end{verbatim}
The current mode will then be printed as {\tt ALGEBRAIC} or {\tt SYMBOLIC}.

Expression evaluation may proceed in either mode at any level of a
calculation, provided the results are passed from mode to mode in a
compatible manner. One simply prefixes the relevant expression by the
appropriate mode. If the mode name prefixes an expression at the top
level, it will then be handled as if the global system mode had been
changed for the scope of that particular calculation.

For example, if the current mode is {\tt ALGEBRAIC}, then the commands
\begin{verbatim}
        symbolic car '(a);
        x+y;
\end{verbatim}
will cause the first expression to be evaluated and printed in symbolic
mode and the second in algebraic mode. Only the second evaluation will
thus affect the expression workspace. On the other hand, the statement
\begin{verbatim}
        x + symbolic car '(12);
\end{verbatim}
will result in the algebraic value {\tt X+12}.

The use of {\tt SYMBOLIC} (and equivalently {\tt ALGEBRAIC}) in this
manner is the same as any operator.  That means that parentheses could be
omitted in the above examples since the meaning is obvious.  In other
cases, parentheses must be used, as in

\begin{verbatim}
        symbolic(x := 'a);
\end{verbatim}
Omitting the parentheses, as in
\begin{verbatim}
        symbolic x := a;
\end{verbatim}
would be wrong, since it would parse as
\begin{verbatim}
        symbolic(x) := a;
\end{verbatim}
For convenience, it is assumed that any operator whose {\em first} argument is
quoted is being evaluated in symbolic mode, regardless of the mode in
effect at that time. Thus, the first example above could be equally well
written:
\begin{verbatim}
        car '(a);
\end{verbatim}
Except where explicit limitations have been made, most {\REDUCE} algebraic
constructions carry over into symbolic mode. \index{Symbolic mode}
However, there are some differences.  First, expression evaluation now
becomes Lisp evaluation.  Secondly, assignment statements are handled
differently, as we shall discuss shortly.  Thirdly, local variables and array
elements are initialized to {\tt NIL} rather than {\tt 0}. (In fact, any
variables not explicitly declared {\tt INTEGER} are also initialized to
{\tt NIL} in algebraic mode, but the algebraic evaluator recognizes {\tt
NIL} as {\tt 0}.) Finally, function definitions follow the conventions of
Standard Lisp.

To begin with, we mention a few extensions to our basic syntax which are
designed primarily if not exclusively for symbolic mode.

\section{Symbolic Infix Operators}

There are four binary infix operators in {\REDUCE} intended for use in
symbolic mode, namely . {\tt (CONS), EQ, MEMBER and MEMQ}. The precedence of
these operators was given in another section.

\section{Symbolic Expressions}

These consist of scalar variables and operators and follow the normal
rules of the Lisp meta language.

{\it Examples:}
\begin{verbatim}
        x
        car u . reverse v
        simp (u+v^2)
\end{verbatim}

\section{Quoted Expressions} \ttindex{QUOTE}

Because symbolic evaluation requires that each variable or expression has a
value, it is necessary to add to {\REDUCE} the concept of a quoted expression
by analogy with the Lisp {\tt QUOTE} function. This is provided by the single
quote mark {\tt '}.  For example,
\begin{quote}
\begin{tabbing}
{\tt 'a} \hspace{0.5in} \= represents the Lisp S-expression \hspace{0.2 in} \=
{\tt (quote a)} \\
{\tt '(a b c)} \> represents the Lisp S-expression \> {\tt (quote (a b c))}
\end{tabbing}
\end{quote}
Note, however, that strings are constants and therefore evaluate to
themselves in symbolic mode. Thus, to print the string {\tt "A String"}, one
would write
\begin{verbatim}
        prin2 "A String";
\end{verbatim}
Within a quoted expression, identifier syntax rules are those of {\REDUCE}.
Thus {\tt ( A !.  B)} is the list consisting of the three elements {\tt A},
{\tt .}, and {\tt B}, whereas {\tt (A .  B)} is the dotted pair of {\tt A}
and {\tt B}.

\section{Lambda Expressions} \ttindex{LAMBDA}
\label{sec-lambda}

{\tt LAMBDA} expressions provide the means for constructing Lisp {\tt LAMBDA}
expressions in symbolic mode. They may not be used in algebraic mode.

Syntax:
\begin{verbatim}
        <LAMBDA expression> ::=
                LAMBDA <varlist><terminator><statement>
\end{verbatim}
 where
\begin{verbatim}
        <varlist> ::= (<variable>,...,<variable>)
\end{verbatim}
e.g.,
\begin{verbatim}
        lambda (x,y); car x . cdr y;
\end{verbatim}
is equivalent to the Lisp {\tt LAMBDA} expression
\begin{verbatim}
        (lambda (x y) (cons (car x) (cdr y)))
\end{verbatim}
The parentheses may be omitted in specifying the variable list if desired.

{\tt LAMBDA} expressions may be used in symbolic mode in place of prefix
operators, or as an argument of the reserved word {\tt FUNCTION}.

In those cases where a {\tt LAMBDA} expression is used to introduce local
variables to avoid recomputation, a {\tt WHERE} statement can also be
used.  For example, the expression
\begin{verbatim}
        (lambda (x,y); list(car x,cdr x,car y,cdr y))
            (reverse u,reverse v)
\end{verbatim}
can also be written
\begin{verbatim}
      {car x,cdr x,car y,cdr y} where x=reverse u,y=reverse v
\end{verbatim}
Where possible, {\tt WHERE} syntax is preferred to {\tt LAMBDA} syntax,
since it is more natural.

\section{Symbolic Assignment Statements} \index{Assignment}

In symbolic mode, if the left side of an assignment statement is a
variable, a {\tt SETQ} of the right-hand side to that variable occurs.  If
the left-hand side is an expression, it must be of the form of an array
element, otherwise an error will result.  For example, {\tt x:=y}
translates into {\tt (SETQ X Y)} whereas {\tt a(3) := 3} will be valid if
{\tt A} has been previously declared a single dimensioned array of at
least four elements.

\section{FOR EACH Statement} \ttindex{FOR EACH}

The {\tt FOR EACH} form of the {\tt FOR} statement, designed for iteration
down a list, is more general in symbolic mode.  Its syntax is:

\begin{verbatim}
        FOR EACH ID:identifier {IN|ON} LST:list
            {DO|COLLECT|JOIN|PRODUCT|SUM} EXPRN:S-expr
\end{verbatim}

As in algebraic mode, if the keyword {\tt IN} is used, iteration is on
each element of the list.  With {\tt ON}, iteration is on the whole list
remaining at each point in the iteration.  As a result, we have the
following equivalence between each form of {\tt FOR EACH} and the various
mapping functions in Lisp:
\begin{center}
{\tt
\begin{tabular}{|l|lr r|} \hline
& DO & COLLECT & JOIN \\ \hline
        IN &   MAPC & MAPCAR & MAPCAN \\
        ON &   MAP &  MAPLIST & MAPCON \\ \hline
\end{tabular}}
\end{center}
{\it Example:} To list each element of the list {\tt (a b c)}:
\begin{verbatim}
        for each x in '(a b c) collect list x;
\end{verbatim}

\section{Symbolic Procedures} \index{Symbolic procedure}

All the functions described in the Standard Lisp Report are available to
users in symbolic mode. Additional functions may also be defined as
symbolic procedures. For example, to define the Lisp function {\tt ASSOC},
the following could be used:
\begin{verbatim}
        symbolic procedure assoc(u,v);
           if null v then nil
            else if u = caar v then car v
            else assoc(u, cdr v);
\end{verbatim}
If the default mode were symbolic, then {\tt SYMBOLIC} could be omitted in
the above definition. {\tt MACRO}s may be defined by
prefixing the keyword {\tt PROCEDURE} by the word {\tt MACRO}.
(In fact, ordinary functions may be defined with the keyword {\tt
EXPR} prefixing {\tt PROCEDURE} as was used in the Standard Lisp Report.)
For example, we could define a {\tt MACRO CONSCONS} by
\begin{verbatim}
        symbolic macro procedure conscons l;
           expand(cdr l,'cons);
\end{verbatim}

The Standard Lisp Report also defines a function type {\tt FEXPR}.
However, its use is discouraged since it is hard to implement efficiently,
and most uses can be replaced by macros.  At the present time, there are
no {\tt FEXPR}s in the core REDUCE system.

\section{Standard Lisp Equivalent of Reduce Input}

A user can obtain the Standard Lisp equivalent of his {\REDUCE} input by
turning on the switch {\tt DEFN} \ttindex{DEFN} (for definition).  The
system then prints the Lisp translation of his input but does not evaluate
it.  Normal operation is resumed when {\tt DEFN} is turned off.

\section{Communicating with Algebraic Mode} \index{Mode communication}

One of the principal motivations for a user of the algebraic facilities of
{\REDUCE} to learn about symbolic mode \index{Symbolic mode} is that it
gives one access to a wider range of techniques than is possible in
algebraic mode \index{Algebraic mode} alone.  For example, if a user
wishes to use parts of the system defined in the basic system source code,
or refine their algebraic code definitions to make them more efficient,
then it is necessary to understand the source language in fairly complete
detail.  Moreover, it is also necessary to know a little more about the
way {\REDUCE} operates internally.  Basically, {\REDUCE} considers
expressions in two forms: prefix form, which follow the normal Lisp rules
of function composition, and so called canonical form, which uses a
completely different syntax.

Once these details are understood, the most critical problem faced by a
user is how to make expressions and procedures communicate between symbolic
and algebraic mode. The purpose of this section is to teach a user the
basic principles for this.

If one wants to evaluate an expression in algebraic mode, and then use
that expression in symbolic mode calculations, or vice versa, the easiest
way to do this is to assign a variable to that expression whose value is
easily obtainable in both modes.  To facilitate this, a declaration {\tt
SHARE} \ttindex{SHARE} is available. {\tt SHARE} takes a list of
identifiers as argument, and marks these variables as having recognizable
values in both modes.  The declaration may be used in either mode.

E.g.,
\begin{verbatim}
        share x,y;
\end{verbatim}
says that {\tt X} and {\tt Y} will receive values to be used in both modes.

If a {\tt SHARE} declaration is made for a variable with a previously
assigned algebraic value, that value is also made available in symbolic
mode.

\subsection{Passing Algebraic Mode Values to Symbolic Mode}

If one wishes to work with parts of an algebraic mode
\index{Algebraic mode} expression in symbolic mode, \index{Symbolic mode}
one simply makes an assignment \index{Assignment} of a shared variable to
the relevant expression in algebraic mode.  For example, if one wishes to
work with {\tt (a+b)\^{ }2}, one would say, in algebraic mode:
\begin{verbatim}
        x := (a+b)^2;
\end{verbatim}
assuming that {\tt X} was declared shared as above.  If we now change to
symbolic mode and say
\begin{verbatim}
        x;
\end{verbatim}
its value will be printed as a prefix form with the syntax:
\begin{verbatim}
        (*SQ <standard quotient> T)
\end{verbatim}
This particular format reflects the fact that the algebraic mode processor
currently likes to transfer prefix forms from command to command, but
doesn't like to reconvert standard forms \index{Standard form} (which
represent polynomials) and standard quotients back to a true Lisp prefix
form for the expression (which would result in excessive computation).  So
{\tt *SQ} is used to tell the algebraic processor that it is dealing with
a prefix form which is really a standard quotient \index{Standard
quotient} and the second argument ({\tt T} or {\tt NIL}) tells it whether
it needs further processing (essentially, an {\em already simplified}
flag).

So to get the true standard quotient form in symbolic mode, one needs
{\tt CADR} of the variable. E.g.,
\begin{verbatim}
        z := cadr x;
\end{verbatim}
would store in {\tt Z} the standard quotient form for {\tt (a+b)\^{ }2}.

Once you have this expression, you can now manipulate it as you wish.  To
facilitate this, a standard set of selectors \index{Selector} and
constructors \index{Constructor} are available for getting at parts of the
form.  Those presently defined are as follows:

\begin{center}
{\large  REDUCE Selectors}
\end{center}
\begin{center}
\begin{tabular}{l r}
{\tt DENR} & \parbox[t]{\rboxwidth}{denominator of standard quotient} \\ \\

{\tt LC} & \parbox[t]{\rboxwidth}{leading coefficient of polynomial} \\ \\

{\tt LDEG} & \parbox[t]{\rboxwidth}{leading degree of polynomial} \\ \\

{\tt LPOW} & \parbox[t]{\rboxwidth}{leading power of polynomial} \\ \\

{\tt LT} & \parbox[t]{\rboxwidth}{leading term of polynomial} \\ \\

{\tt MVAR} & \parbox[t]{\rboxwidth}{main variable of polynomial} \\ \\

{\tt NUMR} & \parbox[t]{\rboxwidth}{numerator (of standard quotient)} \\ \\

{\tt PDEG} & \parbox[t]{\rboxwidth}{degree of a power} \\ \\

{\tt RED} & \parbox[t]{\rboxwidth}{reductum of polynomial} \\ \\

{\tt TC} & \parbox[t]{\rboxwidth}{coefficient of a term} \\ \\

{\tt TDEG} & \parbox[t]{\rboxwidth}{degree of a term} \\ \\

{\tt TPOW} & \parbox[t]{\rboxwidth}{power of a term} \\ \\
\end{tabular}
\end{center}

\begin{center}
{\large REDUCE Constructors}
\end{center}
\begin{center}
\begin{tabular}{l r}
{\tt .+} & \parbox[t]{\redboxwidth}{add a term to a polynomial} \\ \\

{\tt ./} & \parbox[t]{\redboxwidth}{divide (two polynomials to get quotient)}
\\ \\
{\tt  .*} & \parbox[t]{\redboxwidth}{multiply power by coefficient to produce
                term} \\ \\

{\tt .\^{ }} & \parbox[t]{\redboxwidth}{raise a variable to a power} \\ \\
\end{tabular}
\end{center}

For example, to find the numerator of the standard quotient above, one
could say:
\begin{verbatim}
        numr z;
\end{verbatim}
or to find the leading term of the numerator:
\begin{verbatim}
        lt numr z;
\end{verbatim}
Conversion between various data structures is facilitated by the use of a
set of functions defined for this purpose. Those currently implemented
include: \\ \\
\begin{tabular}{l r}
{\tt !*A2F} & \parbox[t]{\reduceboxwidth}{convert an algebraic expression to
a standard form.  If result is rational, an error results;} \\ \\

{\tt !*A2K} & \parbox[t]{\reduceboxwidth}{converts an algebraic expression to
a kernel.  If this is not possible, an error results;} \\ \\

{\tt !*F2A} & \parbox[t]{\reduceboxwidth}{converts a standard form to an
algebraic expression;} \\ \\

{\tt !*F2Q} & \parbox[t]{\reduceboxwidth}{convert a standard form to a
standard quotient;} \\ \\

{\tt !*K2F} & \parbox[t]{\reduceboxwidth}{convert a kernel to a standard form;}
\\ \\
{\tt !*K2Q} & \parbox[t]{\reduceboxwidth}{convert a kernel to a standard
quotient;} \\ \\

{\tt !*P2F} & \parbox[t]{\reduceboxwidth}{convert a standard power to a
standard form;} \\ \\

{\tt !*P2Q} & \parbox[t]{\reduceboxwidth}{convert a standard power to a standard
quotient;} \\ \\

{\tt !*Q2F} & \parbox[t]{\reduceboxwidth}{convert a standard quotient to a
standard form.  If the quotient denominator is not 1, an error results;} \\ \\

{\tt !*Q2K} & \parbox[t]{\reduceboxwidth}{convert a standard quotient to a
kernel.  If this is not possible, an error results;} \\ \\

{\tt !*T2F} & \parbox[t]{\reduceboxwidth}{convert a standard term to a
standard form} \\ \\

{\tt !*T2Q} & \parbox[t]{\reduceboxwidth}{convert a standard term to a
standard quotient.}
\end{tabular}

\subsection{Passing Symbolic Mode Values to Algebraic Mode}

In order to pass the value of a shared variable from symbolic mode to
algebraic mode, the only thing to do is make sure that the value in
symbolic mode is a prefix expression. E.g., one uses
{\tt (expt (plus a b) 2)} for {\tt (a+b)\^{ }2}, or the format ({\tt *sq
<standard quotient> t}) as described above.  However, if you have
been working with parts of a standard form they will probably not be in
this form.  In that case, you can do the following:
\begin{enumerate}
\item If it is a standard quotient, call {\tt PREPSQ} on it.  This takes a
standard quotient as argument, and returns a prefix expression.
Alternatively, you can call {\tt MK!*SQ} on it, which returns a prefix
form like ({\tt *SQ <standard quotient> T)} and avoids translation of
the expression into a true prefix form.

\item If it is a standard form, call {\tt PREPF} on it.  This takes a
standard form as argument, and returns the equivalent prefix expression.
Alternatively, you can convert it to a standard quotient and then call
{\tt MK!*SQ}.

\item If it is a part of a standard form, you must usually first build up a
standard form out of it, and then go to step 2. The conversion functions
described earlier may be used for this purpose. For example,
\begin{enumerate}
\item If {\tt Z} is an expression which is a term, {\tt !*T2F Z} is a
standard form.
\item If {\tt Z} is a standard power, {\tt !*P2F Z} is a standard form.
\item If {\tt Z} is a variable, you can pass it direct to algebraic mode.
\end{enumerate}
\end{enumerate}
For example, to pass the leading term of {\tt (a+b)\^{ }2} back to
algebraic mode, one could say:
\begin{verbatim}
        y:= mk!*sq !*t2q lt numr z;
\end{verbatim}
where {\tt Y} has been declared shared as above.  If you now go back to
algebraic mode, you can work with {\tt Y} in the usual way.


\subsection{Complete Example}

The following is the complete code for doing the above steps. The end
result will be that the square of the leading term of $(a+b)^{2}$ is
calculated.

\begin{tabular}{l r}
{\tt share x,y;} & \parbox[t]{\rboxwidth}{{\tt \% declare {\tt X} and
{\tt Y} as shared}} \\
{\tt x := (a+b)\^{ }2;} & \parbox[t]{\rboxwidth}{{\tt \% store (a+b)\^{ }2
in X}} \\
{\tt symbolic;} & \parbox[t]{\rboxwidth}{{\tt \% transfer to symbolic mode}}
\\
{\tt z := cadr x;} & \parbox[t]{\rboxwidth}{\tt {\% store a true standard
quotient \% in Z}} \\
{\tt lt numr z;} & \parbox[t]{\rboxwidth}{{\tt \% print the leading term
of the \% numerator of Z}} \\
{\tt y := mk!*sq !*t2q numr z;} & \parbox[t]{\rboxwidth}{{\tt \% store the
prefix form of this \% leading term in Y}} \\
{\tt algebraic;} & \parbox[t]{\rboxwidth}{{\tt \% return to algebraic mode}}
\\
{\tt y\^{ }2;} & \parbox[t]{\rboxwidth}{{\tt \% evaluate square of the leading
\% term of (a+b)\^{ }2}} \\
\end{tabular}

\subsection{Defining Procedures to Communicate Between Modes}

If one wishes to define a procedure in symbolic mode for use as an
operator in algebraic mode, it is necessary to declare this fact to the
system by using the declaration {\tt OPERATOR} \ttindex{OPERATOR} in
symbolic mode. Thus
\begin{verbatim}
        symbolic operator leadterm;
\end{verbatim}
would declare the procedure {\tt LEADTERM} as an algebraic operator. This
declaration {\em must} be made in symbolic mode as the effect in algebraic
mode is different.  The value of such a procedure must be a prefix form.

The algebraic processor will pass arguments to such procedures in prefix
form. Therefore if you want to work with the arguments as standard
quotients you must first convert them to that form by using the function
{\tt SIMP!*}. This function takes a prefix form as argument and returns the
evaluated standard quotient.

For example, if you want to define a procedure {\tt LEADTERM} which gives the
leading term of an algebraic expression, one could do this as follows:
\begin{verbatim}
symbolic operator leadterm; % Declare LEADTERM as a symbolic
                            % mode procedure to be used in
                            % algebraic mode.

symbolic procedure leadterm u; % Define LEADTERM.
   mk!*sq !*t2q lt numr simp!* u;
\end{verbatim}
Note that this operator has a different effect than the operator {\tt LTERM}
\ttindex{LTERM} (q.v.).  In the latter case, the calculation is done
with respect to the second argument of the operator.  In the example here,
we simply extract the leading term with respect to the system's choice of
main variable.

Finally, if you wish to use the algebraic evaluator on an argument in a
symbolic mode definition, the function {\tt REVAL} can be used.  The one
argument of {\tt REVAL} must be the prefix form of an expression. {\tt
REVAL} returns the evaluated expression as a true Lisp prefix form.

\section{References}

There are a number of useful books which can give you further information
about LISP. Here is a selection:

 Allen, J.R., ``The Anatomy of LISP", McGraw Hill, New York, 1978.

 McCarthy J., P.W. Abrahams, J. Edwards, T.P. Hart and
     M.I. Levin, ``LISP 1.5 Programmer's Manual", M.I.T. Press, 1965.

 Touretzky, D.S, ``{LISP}: A Gentle Introduction to Symbolic Computation",
 Harper \& Row, New York, 1984.

 Winston, P.H. and Horn, B.K.P., ``LISP", Addison-Wesley, 1981.

\chapter{Calculations in High Energy Physics}

A set of {\REDUCE} commands is provided for users interested in symbolic
calculations in high energy physics. Several extensions to our basic
syntax are necessary, however, to allow for the different data structures
encountered.

\section{High Energy Physics Operators}

We begin by introducing three new operators required in these calculations.

\subsection{. (Cons) Operator} \index{Dot product}
\begin{verbatim}
Syntax: (EXPRN1:vector_expression)
                 . (EXPRN2:vector_expression):algebraic.
\end{verbatim}
The binary {\tt .} operator, which is normally used to denote the addition
of an element to the front of a list, can also be used in algebraic mode
to denote the scalar product of two Lorentz four-vectors.  For this to
happen, the second argument must be recognizable as a vector expression
\index{High energy vector expression} (q.v.) at the time of
evaluation.  With this meaning, this operator is often referred to as the
``dot" operator.  In the present system, the index handling routines all
assume that Lorentz four-vectors are used, but these routines could be
rewritten to handle other cases.

Components of vectors can be represented by including representations of
unit vectors in the system.  Thus if {\tt EO} represents the unit vector
{\tt (1,0,0,0)}, {\tt (p.eo)} represents the zeroth component of the
four-vector P.  Our metric and notation follows Bjorken and Drell
``Relativistic Quantum Mechanics" (McGraw-Hill, New York, 1965).
Similarly, an arbitrary component {\tt P} may be represented by
{\tt (p.u)}.  If contraction over components of vectors is required, then
the declaration {\tt INDEX} \ttindex{INDEX} must be used.  Thus
\begin{verbatim}
        index u;
\end{verbatim}
declares {\tt U} as an index, and the simplification of
\begin{verbatim}
        p.u * q.u
\end{verbatim}
would result in
\begin{verbatim}
        P.Q
\end{verbatim}
The metric tensor $g^{\mu \nu}$ may be represented by {\tt (u.v)}.  If
contraction over {\tt U} and {\tt V} is required, then they should be
declared as indices.

Errors occur if indices are not properly matched in expressions.

If a user later wishes to remove the index property from specific vectors,
he can do it with the declaration {\tt REMIND}.\ttindex{REMIND} Thus
{\tt remind v1...vn;} removes the index flags from the variables {\tt V1}
through {\tt Vn}.  However, these variables remain vectors in the system.

\subsection{G Operator for Gamma Matrices}  \index{Dirac $\gamma$ matrix}
\ttindex{G}

Syntax:
\begin{verbatim}
        G(ID:identifier[,EXPRN:vector_expression])
                :gamma_matrix_expression.
\end{verbatim}
{\tt G} is an n-ary operator used to denote a product of $\gamma$ matrices
contracted with Lorentz four-vectors. Gamma matrices are associated with
fermion lines in a Feynman diagram. If more than one such line occurs,
then a different set of $\gamma$ matrices (operating in independent spin
spaces) is required to represent each line. To facilitate this, the first
argument of {\tt G} is a line identification identifier (not a number)
used to distinguish different lines.

Thus
\begin{verbatim}
        g(l1,p) * g(l2,q)
\end{verbatim}
denotes the product of {\tt P/} associated with a fermion line identified as
{\tt L1}, and {\tt Q/} associated with another line identified as {\tt L2} and
where {\tt P} and {\tt Q} are Lorentz four-vectors.  A product of $\gamma$
matrices associated with the same line may be written in a contracted
form.

Thus
\begin{verbatim}
        g(l1,p1,p2,...,p3) = g(l1,p1)*g(l1,p2)*,...,*g(l1,p3) .
\end{verbatim}
The vector {\tt A} is reserved in arguments of G to denote the special
$\gamma$ matrix $\gamma^{5}$. Thus
\begin{quote}
\begin{tabbing}
\ \ \ \ \ {\tt g(l,a)}\hspace{0.2in} \= =\ \ \  $\gamma^{5}$ \hspace{0.5in}
\= associated with the line {\tt l} \\[0.1in]
\ \ \ \ \ {\tt g(l,p,a)} \> =\ \ \  $\gamma$.p $\times \gamma^{5}$ \>
associated with the line {\tt L}.
\end{tabbing}
\end{quote}
$\gamma^{\mu}$ (associated with the line {\tt L}) may be written as
{\tt g(l,u)}, with {\tt U} flagged as an index if contraction over {\tt U}
is required.

The notation of Bjorken and Drell is assumed in all operations involving
$\gamma$ matrices.

\subsection{EPS Operator} \ttindex{EPS}
\begin{verbatim}
 Syntax: EPS(EXPRN1:vector_expression,...,EXPRN4:vector_exp)
            :vector_exp.
\end{verbatim}
The operator {\tt EPS} has four arguments, and is used only to denote the
completely antisymmetric tensor of order 4 and its contraction with Lorentz
four-vectors. Thus
\[ \epsilon_{i j k l} = \left\{ \begin{array}{cl}
                                +1 & \mbox{if $i,j,k,l$ is an even permutation
                                              of 0,1,2,3} \\
                                -1 & \mbox{if an odd permutation} \\
                                0 & \mbox{otherwise}
                              \end{array}
                      \right. \]

A contraction of the form $\epsilon_{i j \mu \nu}p_{\mu}q_{\nu}$ may be
written as {\tt eps(i,j,p,q)}, with {\tt I} and {\tt J} flagged as indices,
and so on.

\section{Vector Variables}

Apart from the line identification identifier in the {\tt G} operator, all
other arguments of the operators in this section are vectors.  Variables
used as such must be declared so by the type declaration {\tt VECTOR},
\ttindex{VECTOR} for example:
\begin{verbatim}
        vector  p1,p2;
\end{verbatim}
declares {\tt P1} and {\tt P2} to be vectors.  Variables declared as
indices or given a mass \ttindex{MASS} (q.v.) are automatically declared
vector by these declarations.

\section{Additional Expression Types}

Two additional expression types are necessary for high energy
calculations, namely

\subsection{Vector Expressions} \index{High energy vector expression}

These follow the normal rules of vector combination. Thus the product of a
scalar or numerical expression and a vector expression is a vector, as are
the sum and difference of vector expressions. If these rules are not
followed, error messages are printed. Furthermore, if the system finds an
undeclared variable where it expects a vector variable, it will ask the
user in interactive mode whether to make that variable a vector or not. In
batch mode, the declaration will be made automatically and the user
informed of this by a message.

{\tt Examples:}

Assuming {\tt P} and {\tt Q} have been declared vectors, the following are
vector expressions
\begin{verbatim}
        p
        2*q/3
        2*x*y*p - p.q*q/(3*q.q)
\end{verbatim}
whereas {\tt p*q} and {\tt p/q} are not.

\subsection{Dirac Expressions}

These denote those expressions which involve $\gamma$ matrices. A $\gamma$
matrix is implicitly a 4 $\times$ 4 matrix, and so the product, sum and
difference of such expressions, or the product of a scalar and Dirac
expression is again a Dirac expression.  There are no Dirac variables in
the system, so whenever a scalar variable appears in a Dirac expression
without an associated $\gamma$ matrix expression, an implicit unit 4
by 4 matrix is assumed.  For example, {\tt g(l,p) + m} denotes {\tt
g(l,p) + m*<unit 4 by 4 matrix>}.  Multiplication of Dirac
expressions, as for matrix expressions, is of course non-commutative.

\section{Trace Calculations} \index{High energy trace}

When a Dirac expression is evaluated, the system computes one quarter of
the trace of each $\gamma$ matrix product in the expansion of the expression.
One quarter of each trace is taken in order to avoid confusion between the
trace of the scalar {\tt M}, say, and {\tt M} representing {\tt M * <unit
4 by 4 matrix>}.  Contraction over indices occurring in such expressions is
also performed.  If an unmatched index is found in such an expression, an
error occurs.

The algorithms used for trace calculations are the best available at the
time this system was produced. For example, in addition to the algorithm
developed by Chisholm for contracting indices in products of traces,
{\REDUCE} uses the elegant algorithm of Kahane for contracting indices in
$\gamma$ matrix products.  These algorithms are described in Chisholm, J. S.
R., Il Nuovo Cimento X, 30, 426 (1963) and Kahane, J., Journal Math.
Phys. 9, 1732 (1968).

It is possible to prevent the trace calculation over any line identifier
by the declaration {\tt NOSPUR}. \ttindex{NOSPUR}  For example,
\begin{verbatim}
        nospur l1,l2;
\end{verbatim}
will mean that no traces are taken of $\gamma$ matrix terms involving the line
numbers {\tt L1} and {\tt L2}.  However, in some calculations involving
more than one line, a catastrophic error
\begin{verbatim}
        This NOSPUR option not implemented
\end{verbatim}
can occur (for the reason stated!) If you encounter this error, please let
us know!

A trace of a $\gamma$ matrix expression involving a line identifier which has
been declared {\tt NOSPUR} may be later taken by making the declaration
{\tt SPUR}. \ttindex{SPUR}

\section{Mass Declarations} \ttindex{MASS}

It is often necessary to put a particle ``on the mass shell" in a
calculation.  This can, of course, be accomplished with a {\tt LET}
command such as
\begin{verbatim}
        let p.p= m^2;
\end{verbatim}
but an alternative method is provided by two commands {\tt MASS} and
{\tt MSHELL}. \ttindex{MSHELL}
{\tt MASS} takes a list of equations of the form:
\begin{verbatim}
        <vector variable> = <scalar variable>
\end{verbatim}
for example,
\begin{verbatim}
        mass p1=m, q1=mu;
\end{verbatim}
The only effect of this command is to associate the relevant scalar
variable as a mass with the corresponding vector. If we now say
\begin{verbatim}
        mshell <vector variable>,...,<vector variable>;
\end{verbatim}
and a mass has been associated with these arguments, a substitution of the
form
\begin{verbatim}
        <vector variable>.<vector variable> = <mass>^2
\end{verbatim}
is set up. An error results if the variable has no preassigned mass.

\section{Example}

We give here as an example of a simple calculation in high energy physics
the computation of the Compton scattering cross-section as given in
Bjorken and Drell Eqs. (7.72) through (7.74). We wish to compute the trace of

$$\left. \alpha^2\over2 \right. \left({k^\prime\over k}\right)^2
 \left({\gamma.p_f+m\over2m}\right)\left({\gamma.e^\prime \gamma.e
 \gamma.k_i\over2k\cdot \gamma.p_i} + {\gamma.e\gamma.e^\prime
 \gamma.k_f\over2k^\prime\cdot \gamma.p_i}\right)
 \left({\gamma.p_i+m\over2m}\right)$$
$$
 \left({\gamma.k_i\gamma.e\gamma.e^\prime\over2k\cdot \gamma.p_i} +
 {\gamma.k_f\gamma.e^\prime\gamma.e\over2k^\prime\cdot \gamma.p_i}
 \right)
$$

where $k_i$ and $k_f$ are the four-momenta of incoming and outgoing photons
(with polarization vectors $e$ and $e^\prime$ and laboratory energies 
$k$ and $k^\prime$
respectively) and $p_i$, $p_f$ are incident and final electron four-momenta.

Omitting therefore an overall factor
${\alpha^2\over2m^2}\left({k^\prime\over k}\right)^2$ we need to find
one quarter of the trace of
$${
 \left( \gamma.p_f + m\right)
 \left({\gamma.e^\prime \gamma.e\gamma.k_i\over2k.pi} +
  {\gamma.e\gamma.e^\prime \gamma.k_f\over 2k^\prime .p_i}\right) \left(
  \gamma.p_i + m\right)
 \left({\gamma.k_i\gamma.e\gamma.e^\prime\over 2k.p_i} +
  {\gamma.k_f\gamma.e^\prime \gamma.e\over2k^\prime .p_i}\right) }$$

A straightforward REDUCE program for this, with appropriate substitutions
(using {\tt P1} for $p_i$, {\tt PF} for $p_f$, {\tt KI}
for $k_i$ and {\tt KF} for $k_f$) is
\begin{verbatim}
 on div; % this gives output in same form as Bjorken and Drell.
 mass ki= 0, kf= 0, p1= m, pf= m; vector e,ep;
 % if e is used as a vector, it loses its scalar identity as
        the base of natural logarithms.
 mshell ki,kf,p1,pf;
 let p1.e= 0, p1.ep= 0, p1.pf= m^2+ki.kf, p1.ki= m*k,p1.kf=
     m*kp, pf.e= -kf.e, pf.ep= ki.ep, pf.ki= m*kp, pf.kf=
     m*k, ki.e= 0, ki.kf= m*(k-kp), kf.ep= 0, e.e= -1,
     ep.ep=-1;
 for all p let gp(p)= g(l,p)+m;
 comment this is just to save us a lot of writing;
 gp(pf)*(g(l,ep,e,ki)/(2*ki.p1) + g(l,e,ep,kf)/(2*kf.p1))
   * gp(p1)*(g(l,ki,e,ep)/(2*ki.p1) + g(l,kf,ep,e)/
     (2*kf.p1))$
 write "The Compton cxn is",ws;
\end{verbatim}

(We use {\tt P1} instead of {\tt PI} in the above to avoid confusion with
the reserved variable {\tt PI}).

This program will print the following result
\begin{verbatim}
                            (-1)        (-1)            2
 The Compton cxn is 1/2*K*KP     + 1/2*K    *KP + 2*E.EP  - 1
\end{verbatim}

\section{Extensions to More Than Four Dimensions}

In our discussion so far, we have assumed that we are working in the
normal four dimensions of QED calculations. However, in most cases, the
programs will also work in an arbitrary number of dimensions. The command
\ttindex{VECDIM}
\begin{verbatim}
        vecdim <expression>;
\end{verbatim}
sets the appropriate dimension. The dimension can be symbolic as well as
numeric. Users should note however, that the {\tt EPS} operator and the
$\gamma_{5}$ symbol ({\tt A}) are not properly defined in other than four
dimensions and will lead to an error if used.

\chapter{{\REDUCE} and Rlisp Utilities}

{\REDUCE} and its associated support language system Rlisp \index{Rlisp}
include a number of utilities which have proved useful for program
development over the years.  The following are supported in most of the
implementations of {\REDUCE} currently available.

\section{The Standard Lisp Compiler}  \index{Compiler}

Many versions of {\REDUCE} include a Standard Lisp compiler that is
automatically loaded on demand.  You should check your system specific
user guide to make sure you have such a compiler.  To make the compiler
active, the switch {\tt COMP} \ttindex{COMP} should be turned on.  Any
further definitions input after this will be compiled automatically.  If
the compiler used is a derivative version of the original Griss-Hearn
compiler
(M. L. Griss and A.
C. Hearn, ``A Portable LISP Compiler", SOFTWARE --- Practice and Experience
11 (1981) 541-605),
there are other switches that might also be
used in this regard.  However, these additional switches are not supported
in all compilers.  They are as follows: \ttindex{PLAP} \ttindex{PGWD}
\ttindex{PWRDS}

\begin{tabular}{l r}
{\tt PLAP} & \parbox[t]{\reduceboxwidth}{If ON, causes the printing of the
portable macros produced by the compiler;} \\ \\

{\tt PGWD} & \parbox[t]{\reduceboxwidth}{If ON, causes the printing of the
actual assembly language instructions generated from the macros;} \\ \\

{\tt PWRDS} & \parbox[t]{\reduceboxwidth}{If ON, causes a statistic
message of the form \\
{\tt    <function> COMPILED, <words> WORDS, <words> LEFT} \\
to be printed.  The first number is the number of words of binary
program space the compiled function took, and the second number
the number of words left unused in binary program space.} \\ \\
\end{tabular}

\section{Fast Loading Code Generation Program} \index{Fast loading of code}
\label{sec-load}
In most versions of {\REDUCE}, it is possible to take any set of Lisp, Rlisp
or {\REDUCE} commands and build a fast loading version of them. In Rlisp or
{\REDUCE}, one does the following:
\begin{verbatim}
         faslout <filename>;
         <commands or IN statements>
         faslend;
\end{verbatim}
To load such a file, one uses the command {\tt LOAD}, \ttindex{LOAD}
e.g. {\tt load foo;}
or {\tt load foo,bah;}

Fast-loading files produced by this process may have an implementation
dependent extension added by this process. For example, in PSL-based systems,
the extension is {\tt b} (for binary).  Such extensions are required by
the {\tt LOAD} program; if they are missing, an error occurs.

In doing this build, as with the production of a Standard Lisp form of
such statements, it is important to remember that some of the commands
must be instantiated during the building process.  For example, macros
must be expanded, and some property list operations must happen.
The {\REDUCE} sources should be consulted for further details on this.
% To facilitate this, the {\tt EVAL} and {\tt IGNORE} flags (q.v.) may be
% used.  Note also that there can be no {\tt LOAD} command within the input
% statements.

To avoid excessive printout, input statements should be followed by a \$
instead of the semicolon.  With {\tt LOAD} however, the input doesn't
print out regardless of which terminator is used with the command.

If you subsequently change the source files used in producing a fast
loading file, don't forget to repeat the above process in order to update
the fast loading file correspondingly.  Remember also that the text which
is read in during the creation of the fast load file, in the compiling
process described above, is {\em not} stored in your {\REDUCE}
environment, but only translated and output.  If you want to use the file
just created, you must then use {\tt LOAD} to load the output of the
fast-loading file generation program.

When the file to be loaded contains a complete package for a given
application, the use of {\tt LOAD\_PACKAGE} \index{Load package}
rather than {\tt LOAD} is
recommended.  The syntax is the same.  However, {\tt LOAD\_PACKAGE} does some
additional bookkeeping such as recording that this package has now be loaded,
which may be used by various utilities in future releases of REDUCE.

\section{The Standard Lisp Cross Reference Program} \index{Cross reference}

{\tt CREF} \ttindex{CREF} is a Standard Lisp program for processing a
set of Standard LISP function definitions to produce:
\begin{enumerate}
\item A ``summary" showing:
\begin{enumerate}
\item A list of files processed;
\item A list of ``entry points" (functions which are not called or
are only called by themselves);
\item A list of undefined functions (functions called but not
defined in this set of functions);
\item A list of variables that were used non-locally but not
declared {\tt GLOBAL} or {\tt FLUID} before their use;
\item A list of variables that were declared {\tt GLOBAL} but not used
as {\tt FLUID}s, i.e., bound in a function;
\item A list of {\tt FLUID} variables that were not bound in a function
so that one might consider declaring them {\tt GLOBAL}s;
\item A list of all {\tt GLOBAL} variables present;
\item A list of all {\tt FLUID} variables present;
\item A list of all functions present.
\end{enumerate}
\item A ``global variable usage" table, showing for each non-local
   variable:
\begin{enumerate}
\item Functions in which it is used as a declared {\tt FLUID} or {\tt GLOBAL};
\item Functions in which it is used but not declared;
\item Functions in which it is bound;
\item Functions in which it is changed by {\tt SETQ}.
\end{enumerate}
\item A ``function usage" table showing for each function:
\begin{enumerate}
\item Where it is defined;
\item Functions which call this function;
\item Functions called by it;
\item Non-local variables used.
\end{enumerate}
\end{enumerate}

The program will also check that functions are called with the correct
number of arguments, and print a diagnostic message otherwise.

The output is alphabetized on the first seven characters of each function
name.

\subsection{Restrictions}

Algebraic procedures in {\REDUCE} are treated as if they were symbolic, so
that algebraic constructs will actually appear as calls to symbolic
functions, such as {\tt AEVAL}.

\subsection{Usage}

To invoke the cross reference program, the switch {\tt CREF}
\ttindex{CREF} is used. {\tt on cref} causes the cref program to load
and the cross-referencing process to begin.  After all the required
definitions are loaded, {\tt off cref} will cause the cross-reference
listing to be produced.  For example, if you wish to cross-reference all
functions in the file {\tt tst.red}, and produce the cross-reference
listing in the file {\tt tst.crf}, the following sequence can be used:
\begin{verbatim}
        out "tst.crf";
        on cref;
        in "tst.red"$
        off cref;
        end;
\end{verbatim}
To process more than one file, more {\tt IN} statements may be added
before the call of {\tt off cref}, or the {\tt IN} statement changed to
include a list of files.

\subsection{Options}

Functions with the flag {\tt NOLIST} will not be examined or output.
Initially, all Standard Lisp functions are so flagged. (In fact, they are
kept on a list {\tt NOLIST!*}, so if you wish to see references to {\em
all} functions, then {\tt CREF} should be first loaded with the command {\tt
load cref}, and this variable then set to {\tt NIL}).

It should also be remembered that any macros with the property list flag
{\tt EXPAND}, or, if the switch {\tt FORCE} is on, without the property
list flag {\tt NOEXPAND}, will be expanded before the definition is seen
by the cross-reference program, so this flag can also be used to select
those macros you require expanded and those you do not.

\section{Prettyprinting Reduce Expressions} \index{Prettyprinting}

{\REDUCE} includes a module for printing {\REDUCE} syntax in a standard
format.  This module is activated by the switch {\tt PRET},
\ttindex{PRET} which is normally off.

Since the system converts algebraic input into an equivalent symbolic form,
the printing program tries to interpret this as an algebraic expression
before printing it. In most cases, this can be done successfully. However,
there will be occasional instances where results are printed in symbolic
mode form that bears little resemblance to the original input, even though
it is formally equivalent.

If you want to prettyprint a whole file, say {\tt off output,msg;}
\ttindex{MSG} and (hopefully) only clean output will result.  Unlike {\tt
DEFN} (q.v.), \ttindex{DEFN} input is also evaluated with {\tt PRET}
\ttindex{PRET} on.

\section{Prettyprinting Standard Lisp S-Expressions} \index{Prettyprinting}

REDUCE includes a module for printing
S-expressions in a standard format.  The Standard Lisp function for this
purpose is {\tt PRETTYPRINT} \ttindex{PRETTYPRINT} which takes a Lisp
expression and prints the formatted equivalent.

Users can also have their {\REDUCE} input printed in this form by use of
the switch {\tt DEFN}. \ttindex{DEFN} This is in fact a convenient way to
convert {\REDUCE} (or Rlisp) syntax into Lisp. {\tt off msg;} will prevent
warning messages from being printed.

NOTE: When {\tt DEFN} is on, input is not evaluated.

\chapter {Maintaining {\REDUCE}}

{\REDUCE} continues to evolve both in terms of the number of facilities
available, and the power of the individual facilities.  Corrections are
made as bugs are discovered, and awkward features simplified.  In order to
provide users with easy access to such enhancements, a {\em {\REDUCE}
Network Library} has been established from which material can be extracted
by anyone with electronic mail access to the Internet computer network.
This includes those with access to BITNET, EARN and UUCP-based networks as
well as commercial networks such as MCIMail and Compuserve.

In addition to miscellaneous documents, source and utility files, the library
includes a bibliography of papers referencing {\REDUCE} which contains over
600 entries.  Instructions on using this library are sent to all registered
{\REDUCE} users who provide a network address.  If you would like a more
complete list of the contents of the library, send to
{\em reduce-netlib@rand.org} the single line message {\em send index} or
{\em help}.  The current {\REDUCE} information package can also be obtained
in this manner by including on a separate line {\em send info-package} and a
demonstration file by including the line {\em send demonstration}.  If you
prefer, hard copies of the information package and the bibliography are
available from the {\REDUCE} secretary at RAND, 1700 Main Street, P.O. Box
2138, Santa Monica, CA 90407-2138 ({\em reduce@rand.org}).  Copies of the
network library are also maintained at other addresses.  At the time of
writing, {\em reduce-netlib@can.nl} may also be used instead of
{\em reduce-netlib@rand.org}.  In addition, elib@elib.zib-berlin.de provides
interactive access to this library.  For more information on {\em eLib},
send the message {\em send index} or {\em help} to that address.

Finally, there is a {\REDUCE} electronic forum accessible from the same
networks.  This enables {\REDUCE} users to raise questions and discuss ideas
concerning the use and development of {\REDUCE} with other users.  Additions
and changes to the network library and new releases of {\REDUCE} are also
announced in this forum.  Any user with appropriate electronic mail access is
encouraged to register for membership in this forum.  To do so, send a
message requesting inclusion to {\em reduce-forum-request@rand.org}.

\appendix
\chapter{Reserved Identifiers}

We list here all identifiers that are normally reserved in REDUCE
including names of commands, operators and switches initially in the system.
Excluded are words that are reserved in specific implementations of the
system. \\ \\

\begin{tabular}{l r}
{Commands} & \parbox[t]{\redboxwidth}{{\tt ALGEBRAIC} {\tt ANTISYMMETRIC}
{\tt ARRAY} {\tt BYE} {\tt CLEAR} {\tt CLEARRULES} {\tt COMMENT} {\tt
CONT} {\tt DECOMPOSE} {\tt DEFINE} {\tt DEPEND} {\tt DISPLAY} {\tt ED}
{\tt EDITDEF} {\tt END} {\tt FACTOR} {\tt FOR} {\tt FORALL} {\tt FOREACH}
{\tt GO} {\tt GOTO} {\tt IF} {\tt IN} {\tt INDEX} {\tt INFIX} {\tt INPUT}
{\tt INTEGER} {\tt KORDER} {\tt LET} {\tt LINEAR} {\tt LISP} {\tt MASS}
{\tt MATCH} {\tt MATRIX} {\tt MSHELL} {\tt NODEPEND} {\tt NONCOM} {\tt
NOSPUR} {\tt OFF} {\tt ON} {\tt OPERATOR} {\tt ORDER} {\tt OUT} {\tt
PAUSE} {\tt PRECEDENCE} {\tt PRINT\_PRECISION} {\tt PROCEDURE} {\tt QUIT}
{\tt REAL} {\tt REMFAC} {\tt REMIND} {\tt RETRY} {\tt RETURN} {\tt SAVEAS}
{\tt SCALAR} {\tt SETMOD} {\tt SHARE} {\tt SHOWTIME} {\tt SHUT} {\tt SPUR}
{\tt SYMBOLIC} {\tt SYMMETRIC} {\tt VECDIM} {\tt VECTOR} {\tt WEIGHT} {\tt
WRITE} {\tt WTLEVEL}} \\ \\

{Boolean Operators} & \parbox[t]{\redboxwidth}{{\tt EVENP} {\tt FIXP}
{\tt FREEOF} {\tt NUMBERP} {\tt ORDP} {\tt PRIMEP}} \\ \\

{Infix Operators} & \parbox[t]{\redboxwidth}{
{\tt \&} {\tt :=} {\tt =} {\tt $>$=} {\tt $>$} {\tt $<$=} {\tt $<$} {\tt
=$>$} {\tt +} {\tt *} {\tt /} {\tt \^{ }} {\tt **} {\tt .} {\tt WHERE}
{\tt SETQ} {\tt OR} {\tt AND} {\tt NOT} {\tt MEMBER} {\tt MEMQ} {\tt
EQUAL} {\tt NEQ} {\tt EQ} {\tt GEQ} {\tt GREATERP} {\tt LEQ} {\tt LESSP}
{\tt PLUS} {\tt DIFFERENCE} {\tt MINUS} {\tt TIMES} {\tt QUOTIENT} {\tt
EXPT} {\tt CONS}}
\end{tabular}

\newpage
\begin{tabular}{l r}
{Numerical Operators} & \parbox[t]{\redboxwidth}{{\tt ABS} {\tt ACOS}
{\tt ACOSD} {\tt ACOSH} {\tt ACOT} {\tt ACOTD} {\tt ACOTH} {\tt ACSC} {\tt
ACSCD} {\tt ACSCH} {\tt ASEC} {\tt ASECD} {\tt ASECH} {\tt ASIN} {\tt
ASIND} {\tt ASINH} {\tt ATAN} {\tt ATAND} {\tt ATANH} {\tt ATAN2} {\tt
ATAN2D} {\tt CBRT} {\tt COS} {\tt COSD} {\tt COSH} {\tt COT} {\tt COTD}
{\tt COTH} {\tt CSC} {\tt CSCD} {\tt CSCH} {\tt EXP} {\tt FACTORIAL} {\tt
FIX} {\tt FLOOR} {\tt HYPOT} {\tt LN} {\tt LOG} {\tt LOGB} {\tt LOG10}
{\tt NEXTPRIME} {\tt ROUND} {\tt SEC} {\tt SECD} {\tt SECH} {\tt SIN} {\tt
SIND} {\tt SINH} {\tt SQRT} {\tt TAN} {\tt TAND} {\tt TANH}} \\ \\

{Prefix Operators} & \parbox[t]{\redboxwidth}{{\tt APPEND} {\tt
ARGLENGTH} {\tt CEILING} {\tt COEFF} {\tt COEFFN} {\tt COFACTOR} {\tt
CONJ} {\tt DEG} {\tt DEN} {\tt DET} {\tt DF} {\tt DILOG} {\tt EPS} {\tt
ERF} {\tt EXPINT} {\tt FACTORIZE} {\tt FIRST} {\tt GCD} {\tt G} {\tt
IMPART} {\tt INT} {\tt INTERPOL} {\tt LCM} {\tt LCOF} {\tt LENGTH} {\tt
LHS} {\tt LINELENGTH} {\tt LTERM} {\tt MAINVAR} {\tt MAT} {\tt MATEIGEN}
{\tt MAX} {\tt MIN} {\tt MKID} {\tt NULLSPACE} {\tt NUM} {\tt PART} {\tt
PF} {\tt PRECISION} {\tt RANK} {\tt REDERR} {\tt REDUCT} {\tt REMAINDER}
{\tt REPART} {\tt REST} {\tt RESULTANT} {\tt REVERSE} {\tt RHS} {\tt
SECOND} {\tt SET} {\tt SOLVE} {\tt STRUCTR} {\tt SUB} {\tt SUM} {\tt
THIRD} {\tt TP} {\tt TRACE} {\tt VARNAME}} \\ \\

{Reserved Variables} & \parbox[t]{\redboxwidth}{{\tt E} {\tt I} {\tt
INFINITY} {\tt K!*} {\tt NIL} {\tt PI} {\tt T}} \\ \\

{Switches} & \parbox[t]{\redboxwidth}{{\tt ADJPREC} {\tt ALGINT} {\tt
ALLBRANCH} {\tt ALLFAC} {\tt BFSPACE} {\tt COMP} {\tt COMPLEX} {\tt
CRAMER} {\tt CREF} {\tt DEFN} {\tt DEMO} {\tt DIV} {\tt ECHO} {\tt
ERRCONT} {\tt EVALLHSEQP} {\tt EXP} {\tt EZGCD} {\tt FACTOR} {\tt FORT}
{\tt GCD} {\tt IFACTOR} {\tt INT} {\tt INTSTR} {\tt LCM} {\tt LIST} {\tt
LISTARGS} {\tt MCD} {\tt MODULAR} {\tt MSG} {\tt MULTIPLICITIES} {\tt NAT}
{\tt NERO} {\tt NOSPLIT} {\tt OUTPUT} {\tt PERIOD} {\tt PGWD} {\tt PLAP}
{\tt PRET} {\tt PRI} {\tt PWRDS} {\tt RAISE} {\tt RAT} {\tt RATARG} {\tt
RATIONAL} {\tt RATIONALIZE} {\tt RATPRI} {\tt REVPRI} {\tt ROUNDALL} {\tt
ROUNDBF} {\tt ROUNDED} {\tt SAVESTRUCTR} {\tt SOLVESINGULAR} {\tt TIME}
{\tt TRA} {\tt TRFAC} {\tt TRINT}} \\ \\

{Other Reserved Ids} & \parbox[t]{\redboxwidth}{{\tt BEGIN} {\tt DO} {\tt
EXPR} {\tt FASLOUT} {\tt FEXPR} {\tt FLAGOP} {\tt INPUT} {\tt LAMBDA} {\tt
LISP} {\tt LOAD} {\tt MACRO} {\tt PRODUCT} {\tt REPEAT} {\tt SMACRO} {\tt
SUM} {\tt WHILE} {\tt WS}}
\end{tabular}


\printindex

\end{document}

Added r34.1/doc/roots.tex version [32d07988c1].

























































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
\documentstyle[11pt,reduce]{article}
\title{The REDUCE Root Finding Package \\ Mod 1.91, 16 May 1990}
\date{}
\author {Stanley L. Kameny \\ E-mail: valley!stan@rand.org}
\begin{document}
\maketitle
\index{root finding} \index{ROOTS package}

\section{Introduction}

The Root Finding package is designed so that it can be used as an
independent package, or it can be integrated with and called by {\tt SOLVE}.
\index{SOLVE package ! with ROOTS package}
This document describes the package in its independent use.  It can be
used to find some or all of the roots of polynomials with real or
complex coefficients, to the accuracy specified by the user.

\section{Top Level Functions}

The top level functions can be called either as symbolic operators from
algebraic mode, or they can be called directly from symbolic mode with
symbolic mode arguments.  Outputs are expressed in forms that print out
correctly in algebraic mode.


\subsection{Functions which refer to real roots only}

Three top level functions refer only to real roots.  Each of these
functions can receive 1, 2 or 3 arguments.

The first argument is the polynomial p, which can be complex and can
have multiple or zero roots.  If arg2 and arg3 are not present, all real
roots are found.  If the additional arguments are present, they restrict
the region of consideration.
                                                    
\begin{itemize}
\item If arguments are (p,arg2) then
(Arg2 must be  POSITIVE or NEGATIVE)  If arg2=NEGATIVE then only
negative roots of p are included; if arg2=POSITIVE then only positive
roots of p are included. Zero roots are excluded.

\item If arguments are (p,arg2,arg3)
\ttindex{EXCLUDE} \ttindex{POSITIVE} \ttindex{NEGATIVE} \ttindex{INFINITY}
(Arg2 and Arg3 must be r (a real number) or  EXCLUDE r  or a member of
the list POSITIVE, NEGATIVE, INFINITY, -INFINITY.  EXCLUDE r causes the
value r to be excluded from the region.  The order of the sequence
arg2, arg3 is unimportant.  Assuming that arg2 $\leq$ arg3 if both are
numeric, then

\begin{tabular}{l c l}
\{-INFINITY,INFINITY\} & is equivalent to & \{\} represents all roots; \\
\{arg2,NEGATIVE\} & represents & $-\infty < r < arg2$; \\
\{arg2,POSITIVE\} & represents & $arg2 < r < \infty$;
\end{tabular}

In each of the following, replacing an {\em arg} with EXCLUDE {\em arg}
converts the corresponding inclusive $\leq$ to the exclusive $<$

\begin{tabular}{l c l}
\{arg2,-INFINITY\} & represents & $-\infty < r \leq arg2$; \\
\{arg2,INFINITY\} & represents & $arg2 \leq r < \infty$; \\
\{arg2,arg3\} & represents & $arg2 \leq r \leq arg3$;
\end{tabular}

\item If zero is in the interval, zero root is included.
\end{itemize}

\begin{description}
\ttindex{REALROOTS} \index{Sturm Sequences}
\item[REALROOTS] This function finds the real roots of the polynomial p,
using the REALROOT package to isolate real roots by the method of Sturm
sequences, then polishing the root to the desired accuracy.  Precision
of computation is guaranteed to be sufficient to separate all real roots
in the specified region.  (cf. MULTIROOT for treatment of multiple
roots.)

\ttindex{ISOLATER}
\item[ISOLATER] This function produces a list of rational intervals, each
containing a single real root of the polynomial p, within the specified
region, but does not find the roots.

\ttindex{RLROOTNO}
\item[RLROOTNO] This function computes the number of real roots of p in
the specified region, but does not find the roots.
\end{description}

\subsection{Functions which return both real and complex roots}

\begin{description}
\ttindex{ROOTS}
\item[ROOTS p;] This is the main top level function of the roots package.
It will find all roots, real and complex, of the polynomial p to an
accuracy sufficient to separate them.  The value returned by ROOTS is a
list of equations for all roots.  In addition, ROOTS stores separate lists
of real roots and complex roots in the global variables ROOTSREAL and
ROOTSCOMPLEX. \ttindex{ROOTSREAL} \ttindex{ROOTSCOMPLEX}

\ttindex{NEARESTROOT}
\item[NEARESTROOT(p,s);] This top level function uses an iterative method
to find the root to which the method converges given the initial starting
origin s, which can be complex.  If there are several roots in the
vicinity of s and s is not significantly closer to one root than it is to
all others, the convergence could arrive at a root which is not truly the
nearest root.  This function should therefore be used only when the user
is certain that there is only one root in the immediate vicinity of the
starting point s.

\ttindex{FIRSTROOT}
\item[FIRSTROOT p;]   Equivalent to NEARESTROOT(p,0).
\end{description}


\subsection{Other top level function}

\begin{description}
\ttindex{CSIZE}
\item[CSIZE p;] This function will determine the maximum coefficient size of
the polynomial p.  The initial precision used in root finding is at
least 2+CSIZE p (in some cases significantly greater, as determined by
the heuristic function CALCPREC.)

\ttindex{GETROOT} \ttindex{ROOTS} \ttindex{REALROOTS} \ttindex{NEARESTROOTS}
\item[GETROOT(n,rr);] If rr has the form of the output of ROOTS, REALROOTS,
or NEARESTROOTS; GETROOT returns the rational, real, or complex value of the
root equation.  Error occurs if $n<1$ or $n>$ the number of roots in rr.

\ttindex{MKPOLY}
\item[MKPOLY rr;] This function can be used to reconstruct a polynomial
whose root equation list is rr and whose denominator is 1.  Thus one can
verify that $if rr := ROOTS p, and rr1 := ROOTS MKPOLY rr, then 
rr1 = rr$.
(This will be true if MULTIROOT and RATROOT are ON,  and  BIGFLOAT  and
FLOAT are off.)
However, $MKPOLY rr - NUM p = 0$ will be true iff all roots of p 
have been computed exactly.
\end{description}

\subsection{Functions available for diagnostic or instructional use only}

\begin{description}
\ttindex{GFNEWT}
\item[GFNEWT(p,r,cpx);] This function will do a single pass through the
function GFNEWTON for polynomial p and root r.  If cpx=T, then any
complex part of the root will be kept, no matter how small.

\ttindex{GFROOT}
\item[GFROOT(p,r,cpx);] This function will do a single pass through the
function GFROOTFIND for polynomial p and root r.  If cpx=T, then any
complex part of the root will be kept, no matter how small.

\ttindex{ROOTS2}
\item[ROOTS2 p;] The same as ROOTS p, except that if an abort occurs, the
roots already found will be printed and then ROOTS2 will be applied to
the polynomial which exists at that point.  (Note:  there is no
known polynomial on which ROOTS aborts.)
\end{description}

\section{Switches Used in Input}

The input of polynomials in algebraic mode is sensitive to the switches {\tt
COMPLEX}, {\tt FLOAT} and {\tt BIGFLOAT}.  The correct choice of input method
is important since incorrect choices will result in undesirable truncation or
rounding of the input coefficients.

Truncation or rounding will occur if {\tt FLOAT} or {\tt BIGFLOAT} is on and
one of the following is true:

\begin{enumerate}
\item a coefficient is entered in floating point form or rational form.
\item {\tt COMPLEX} is on and a coefficient is imaginary or complex.
\end{enumerate}

Therefore, to avoid undesirable truncation or rounding, then:

\begin{enumerate}
\item both {\tt FLOAT} and {\tt BIGFLOAT} should be off and input should be
in integer or rational form; or
\item {\tt FLOAT} can be on if it is acceptable to truncate or round input to
the machine-dependent precision limit, which may be quite small; or
\item {\tt BIGFLOAT} can be on if {\tt PRECISION} is set to a value large
enough to prevent undesired rounding. \end{enumerate}

\begin{description}
\item[integer and complex modes] (off {\tt FLOAT, BIGFLOAT}) any real
polynomial can be input using integer coefficients of any size; integer or
rational coefficients can be used to input any real or complex polynomial,
independent of the setting of the switch {\tt COMPLEX}.  These are the most
versatile input modes, since any real or complex polynomial can be input
exactly.

\item[modes float and complex-float] (on {\tt FLOAT}) polynomials can be input using
integer coefficients of any size.  Floating point coefficients will be
truncated or rounded, to a size dependent upon the system.  If complex
is on, real coefficients can be input to any precision using integer
form, but coefficients of imaginary parts of complex coefficients will
be rounded or truncated.

\item[modes bigfloat and big-complex] (on {\tt BIGFLOAT}) the setting of
precision determines the precision of all coefficients except for real
coefficients input in integer form.  Floating point coefficients will be
truncated by the system to a size dependent upon the system, the same as
floating point coefficients in float mode.  If precision is set high enough,
any real or complex polynomial can be input exactly provided that
coefficients are input in integer or rational form.
\end{description}

\section{Internal and Output Use of Switches}

REDUCE arithmetic mode switches {\tt BIGFLOAT, FLOAT}, and {\tt COMPLEX}.
These switches are returned in the same state in which they were set
initially, (barring catastrophic error).

\begin{description}
\ttindex{COMPLEX}
\item[COMPLEX] The Root Finding Package controls the switch {\tt COMPLEX}
internally, turning the switch on if it is processing a complex
polynomial. (However, if {\tt COMPLEX} is on, algebraic mode input may not
work correctly in modes {\tt COMPLEX\_FLOAT} or {\tt BIG\_COMPLEX}, so it is
best to
use integer or rational input only.  See example 62 of {\tt roots.tst} for a
way to get this to work.) For a polynomial with real coefficients, the
\ttindex{NEARESTROOT}
starting point argument for NEARESTROOT can be given in algebraic mode
in complex form as rl + im * I  and will be handled correctly,
independent of the setting of the switch {\tt COMPLEX.} Complex roots will be
computed and printed correctly regardless of the setting of the switch
{\tt COMPLEX}.  However, if {\tt COMPLEX} is off, the imaginary part will
print out ahead of the real part, while the reverse order will be obtained if
COMPLEX is on.

\ttindex{FLOAT} \ttindex{BIGFLOAT}
\item[FLOAT, BIGFLOAT] If the switch {\tt AUTOMODE} (Default ON) is ON, the
Root Finding package performs computations using the arithmetic mode that is
required at the time, which may be integer, Gaussian integer, float,
bigfloat, complex float or complex bigfloat.  Switch BFTAG is used internally
to govern the mode of computation and :PREC: is adjusted whenever necessary.
The initial position of switches {\tt FLOAT} and {\tt BIGFLOAT} are ignored.
At output, these switches will emerge in their initial positions.  Outputs
will be printed out in float format only if the float format of the Lisp
system will properly print out quantities of the required accuracy.
Otherwise, the printout will be in bigfloat format. (See also the paragraph
describing {\tt AUTOMODE.)} \ttindex{AUTOMODE}
\end{description}

\section{Root Package Switches}

Note: switches ISOROOT and ACCROOT, present in earlier versions, have been
eliminated.

\begin{description}
\ttindex{RATROOT}
\item[RATROOT] (Default OFF) If {\tt RATROOT} is on all root equations are
output in rational form.  Assuming that the mode is {\tt COMPLEX} (i.e. {\tt
FLOAT} and {\tt BIGFLOAT} are both off,) the root equations are guaranteed to
be able to be input into REDUCE without truncation or rounding errors. (Cf.
the function MKPOLY described above.)

\ttindex{MULTIROOT}
\item[MULTIROOT] (Default ON) Whenever the polynomial has complex
coefficients or has real coefficients and has multiple roots, as
\ttindex{SQFRF} determined by the Sturm function, the function {\tt SQFRF} is
called automatically to factor the polynomial into square-free factors.  If
{\tt MULTIROOT} is on, the multiplicity of the roots will be indicated in the
output of ROOTS or REALROOTS by printing the root output repeatedly,
according to its multiplicity.  If {\tt MULTIROOT} is off, each root will be
printed once, and all roots should be normally be distinct. (Two identical
roots should not appear.  If the initial precision of the computation or the
accuracy of the output was insufficient to separate two closely-spaced roots,
the program attempts to increase accuracy and/or precision if it detects
equal roots.  If however, if the initial accuracy specified was too low, and
it was possible to separate the roots, the program will abort.)

\index{tracing ! ROOTS package}
\ttindex{TRROOT}
\item[TRROOT] (Default OFF)  If switch {\tt TRROOT} is on, trace messages are
printed out during the course of root determination, to show the
progress of solution.
                  
\ttindex{ROOTMSG}
\item[ROOTMSG] (Default OFF) If switch {\tt ROOTMSG} is on in addition to
switch {\tt TRROOT,} additional messages are printed out to aid in following
the progress of Laguerre and Newton complex iteration.  These messages are
intended for debugging use primarily.


NOTE: the switch {\tt AUTOMODE} is included mainly for diagnostic purposes.
If it is changed from its default setting, the automatic determination
of computation modes is bypassed, and correct root determination may not
be achieved!

\ttindex{AUTOMODE}
\item[AUTOMODE] (Default ON) If switch {\tt AUTOMODE} is on, then,
independent of the user setting of the switch {\tt BIGFLOAT}, all floating
point computations are carried out in floating point mode (rather than
bigfloat) if the system floating point mode has sufficient precision at that
point in the computation.  If {\tt AUTOMODE} is off and the user setting of
{\tt BIGFLOAT} is on, bigfloat computations are used for all floating point
computations.  The default setting of {\tt AUTOMODE} is {\tt ON}, in order to
speed up computations and guarantee that the exact input polynomial is
evaluated. \end{description}


\section{Operational Parameters and Parameter Setting.}

\begin{description}                 
\ttindex{ROOTACC\#}
\item[ROOTACC\#] (Default 6) This parameter can be set using the function
ROOTACC n; which causes {\tt ROOTACC\#} to be set to MAX(n,6).  If {\tt
ACCROOT} is on, roots will be determined to a minimum of {\tt ROOT\-ACC\#}
significant places. (If roots are closely spaced, a higher number of
significant places is computed where needed.)

\ttindex{:PREC:}
\item[:PREC:] (Default 8) This REDUCE parameter is used to determine the
precision of bigfloat computations.  The function PRECISION n; causes
:PREC: to be set to the value n+2 but returns the value n.  The roots
package, during its operation, will change the value of :PREC: but will
restore the original value of :PREC: at termination except that the
value of :PREC: is increased if necessary to allow the full output to be
printed.

\ttindex{ROOTPREC}
\item[ROOTPREC n;] The roots package normally sets the computation mode and
precision automatically if {\tt AUTOMODE} is on.  However, if ROOTPREC n; is
called and $n>!!NFPD$  (where !!NFPD is the number of floating point
digits in the Lisp system,) then all root computation will be done
initially in bigfloat mode of minimum precision n.  Automatic operation
can be restored by input of ROOTPREC 0;.
\ttindex{"!"!NFPD}
\end{description}


\section{Avoiding truncation of polynomials on input}

The roots package will not internally truncate polynomials provided that the
switch {\tt AUTOMODE} is on (or, if {\tt AUTOMODE} is off, provided that
{\tt ROOTPREC} is not set to some value smaller than the number of
significant figures needed to represent the polynomial precisely.) However,
it is possible that a polynomial can be truncated by input reading functions
of the embedding lisp system, particularly when input is given in floating
point or bigfloat formats. (Some lisp systems use the floating point input
routines to input bigfloats.)

To avoid any difficulties, input can be done in integer or Gaussian
integer format, or mixed, with integers or rationals used to represent
quantities of high precision. There are many examples of this in the
test package. Note that use of bigfloat of high precision will not
necessarily avoid truncation of coefficients if floating point input
format is used.  It is usually sufficient to let the roots package
determine the precision needed to compute roots.

The number of digits that can be safely represented in floating point in the
lisp system are contained in the global variable {\tt !!NFPD}.  Similarly,
the maximum number of significant figures in floating point output are
contained in the global variable {\tt !!FLIM}.  The roots package computes
these values, which are needed to control the logic of the program.
\ttindex{"!"!FLIM} \ttindex{"!"!NFPD}

The values of intermediate root iterations (that are printed when
{\tt TRROOT} is on) are given in bigfloat format even when the actual values
are computed in floating point.  This avoids intrusive rounding of root
printout.

\end{document}

Added r34.1/doc/scope.bib version [ef77a810ed].































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
@ARTICLE{Gates:85,
  AUTHOR = "B. L. Gates",
  TITLE =  "{GENTRAN}: An automatic code generation facility for {REDUCE}",
  JOURNAL = "{SIGSAM} Bulletin",
  VOLUME = 19, NUMBER = 3, PAGES = "24-42",
  YEAR = 1985}

@INPROCEEDINGS{Gates:84,
  AUTHOR = "B. L. Gates and P. S. Wang",
  TITLE = "{LISP}-based {RATFOR} code generator",
  YEAR = 1984,
  EDITOR = "V. E. Golden",
  PAGES = "319-329",
  BOOKTITLE = "1984 MACSYMA User's Conference",
  ADDRESS = "Schenectady, N.Y.",
  ORGANIZATION = "Gen. El."}

@INPROCEEDINGS{Hearn:85,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Structure:  The Key to Improved Algebraic Computation",
 YEAR = 1985,
 BOOKTITLE = "Proc. of the Second {RIKEN} International
Symposium on Symbolic and Algebraic Computation by Computers",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "215-230"}

@INPROCEEDINGS{Hearn:86,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Optimal Evaluation of Algebraic Expressions",
 BOOKTITLE = "Proc. of {AAECC}-3, Lecture Notes on Comp.
Science",
 YEAR = 1986, VOLUME = 229, PAGES = "392-403"}

@ARTICLE{Knuth:71,
  AUTHOR = "D. E. Knuth",
  TITLE = "An empirical study of Fortran programs",
  JOURNAL = "Software Practice and Experience",
  VOLUME = 1, PAGES = "105-133", YEAR = 1971}

@BOOK{Aho:86,
  AUTHOR = "A. V. Aho and R. Sethi and J. D. Ullman",
  TITLE = "Compiler Principles, Techniques and Tools",
  ADDRESS = "Reading, Mass",
  PUBLISHER = "Addison-Wesley",
  YEAR = 1986}

@ARTICLE{Gonzales,
  AUTHOR = "T. Gonzales and J. Ja' Ja'",
  TITLE = "Evaluation of arithmetic expressions with algebraic identities",
  JOURNAL = "{SIAM} J. Comp", YEAR = 1982,
  VOLUME = 11, NUMBER = 4, PAGES = "633-662"}

@ARTICLE{Johnson:79,
  AUTHOR = "B. B. Johnson and W. Miller and B. Minnihan and C. Wrathall",
  TITLE = "Reducibility among floating-point graphs",
  JOURNAL = "Journal of the {ACM}", VOLUME = 26, NUMBER = 4,
  PAGES = "739-760", YEAR = 1979}

@ARTICLE{Smit:81,
  AUTHOR = "J. Smit and J.A. van Hulzen and B.J.A. Hulshof",
  TITLE = "{NETFORM} and code optimizer manual",
  JOURNAL = "{SIGSAM} Bulletin",
  VOLUME =15, NUMBER = 4, PAGES = "23-32",
  YEAR = 1981}

@INPROCEEDINGS{Smit:82,
  AUTHOR = "J. Smit and J.A. van Hulzen",
  TITLE = "Symbolic-numeric methods in microwave technology",
  BOOKTITLE = "Proceedings {EUROCAM} '82",
  EDITOR = "J. Calmet",
  PUBLISHER = "Springer Verlag",
  SERIES = "Springer {LNCS}",
  VOLUME = 144, PAGES = "281-288",
  ADDRESS = "Heidelberg",
  YEAR = 1982}

@INPROCEEDINGS{vanHulzen:83,
  AUTHOR = "J.A. van Hulzen",
  TITLE = "Code optimization of multivariate polynomial schemes: A pragmatic
approach",
  BOOKTITLE = "Proceedings {EUROCAL} '83",
  EDITOR = "J.A. van Hulzen",
  SERIES = "Springer {LNCS}",
  VOLUME = 162, PAGES = "286-300",
  ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1983}

@INPROCEEDINGS{Wang:84,
  AUTHOR = "P.S. Wang and T.Y.P. Chang and J.A. van Hulzen, J.A",
  TITLE = "Code generation and optimization for finite element analysis",
  BOOKTITLE = "Proceedings {EUROSAM} '84",
  EDITOR = "J.P. Fitch",
  SERIES = "Springer {LNCS}",
  VOLUME = 174, PAGES = "237-247",
  ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1984}

@INPROCEEDINGS{Heuvel:89,
  AUTHOR = "P. van den Heuvel and J.A. van Hulzen and V.V. Goldman",
  TITLE = "Automatic generation of {FORTRAN}-coded Jacobians and Hessians",
  BOOKTITLE = "Proceedings {EUROCAL} '87",
  EDITOR = "J.H. Davenport",
  SERIES = "Springer {LNCS}",
  VOLUME = 378, PAGES = "120-131",
  ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1989}

@INBOOK{Goldman:89,
  AUTHOR = "V.V. Goldman and J.A. van Hulzen",
  TITLE = "Automatic code vectorization of arithmetic expressions by
bottom-up structure recognition",
  BOOKTITLE = "Computer Algebra and Parallelism",
  PAGES = "119-132",
  ADDRESS = "London",
  PUBLISHER = "Academic Press", YEAR = 1989}

@INPROCEEDINGS{vanHulzen:81,
  AUTHOR = "J.A. van Hulzen",
  TITLE = "Breuer's grow factor algorithm in computer algebra",
  BOOKTITLE = "Proceedings {SYMSAC} '81",
  EDITOR = "P.S. Wang",
  PAGES = "100-104", ADDRESS = "New York", PUBLSHER = "{ACM} Press",
  YEAR = 1981}

@ARTICLE{Breuer:69,
  AUTHOR = "M.A. Breuer",
  TITLE = "Generation of optimal code for expressions via factorization",
  JOURNAL = "Communications of the {ACM}",
  VOLUME = 12, NUMBER = 6, PAGES = "330-340", YEAR = 1969}

@BOOK{Knuth:80,
  AUTHOR = "D.E. Knuth",
  TITLE = "The art of computer programming",
  VOLUME = 2, EDITION = "Second", ADDRESS = "Reading, Mass",
  PUBLISHER = "Addison-Wesley",
  YEAR = 1980}

@INPROCEEDINGS{vanHulzen:90,
  AUTHOR = "J.A. van Hulzen",
  TITLE = "Current trends in source-code optimization",
  BOOKTITLE = "Proceedings {JINR IV} Conference on Computer Algebra and its
Applications in Theoretical Physics",
  ADDRESS = "Dubna", MONTH = "May", YEAR = 1990,
  NOTE = "Also available as Memorandum {\bf INF-90-41}, Department of
Computer Science, Uniersity Twente"}


Added r34.1/doc/scope.tex version [95654e9f28].

































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
\documentstyle[11pt,reduce]{article}
\title{SCOPE, a Source-Code Optimization PackagE for REDUCE}
\date{}
\author{J.A. van Hulzen \\ Twente University, The Netherlands \\
Email: infhvh@cs.utwente.nl}
\begin{document}
\maketitle
\index{SCOPE package !}

A survey of the strategy behind and the facilities of SCOPE, a
Source-Code Optimization PackagE for {\REDUCE} is given. We avoid a
detailed discussion of the different algorithms and concentrate on the
user aspects of the package.  Examples of straightforward and more
advanced usage are shown.  A combined use of GENTRAN and SCOPE is not
yet discussed in this preliminary version of the SCOPE manual.
\index{GENTRAN ! with SCOPE package}

\section{Introduction}\label{SCOPE:intro}

An important application of computer algebra systems is the generation
of code for numerical purposes via automatic or semiautomatic program
generation. GENTRAN~\cite{Gates:85,Gates:84} a flexible general-purpose
package, was especially developed to assist in such a task, when using
MACSYMA or {\REDUCE}.

\index{optimization}
Attendant to automatic program generation is the problem of automatic
source-code optimization. This is a crucial aspect because code
generated from symbolic computations often tends to be made up of
lengthy arithmetic expressions. One of our test examples contained,
for instance, 20534 additions and subtractions, 4174 multiplications,
12473 integer exponentiations and 7990 other operations, such as
function calls.  These lengthy expressions will be grouped together in
blocks of straight-line code in a program for numerical purposes. The
main objective of source-code optimization is to minimize the number
of (elementary) arithmetic operations in such blocks.  This form of
optimization is often helpful in reducing redundancy in expressions.
Simplification algorithms applied on expressions viewed as entities,
neither guarantee complete structure preservation nor allow
improvements inside expressions by renaming subexpressions.

\index{optimizing compilers}
Optimizing compilers ought to deal effectively and efficiently with
the average, hand coded program. The enormous, arithmetic intensive
expressions, easily producable by a computer algebra system, fall
outside the range of the FORTRAN programs, once analyzed and discussed
by Knuth~\cite{Knuth:71}. He suggested that optimization of the arithmetic in
such a program is slightly overdone. This may explain why even in
reasonably recent literature, such as~\cite{Aho:86}, optimization of arithmetic
code is hardly discussed. The DAG models, usually employed for
optimization of arithmetic code, hardly allow the application of any
algebraic identity (see for instance~\cite{Gonzales}). These models often force
constants to act as if they were indeterminates and powers as objects
requiring function calls, i.e. they force to think of $2a\ +\ 3b$ and
$4 a \ +\ 6b$ or of $a^2$, $a^{4}$ and $a^{6}$ as being different
entities.  Our optimization strategy however, requires the validity of
some elementary algebraic laws. We employ heuristic techniques to
reduce the arithmetic complexity of the given representation of a set
of input expressions $ {\rm E}_in$, thus producing a set of output
expressions ${\rm E}_out$. The optimized version of the earlier
mentioned test example contains ``only'' 4316 additions and
subtractions, 4919 multiplications, 13 integer exponentiations and 60
other operations.  ${\rm E}_{in}$ and ${\rm E}_{out}$ define blocks of
code, which would compute the same exact values for the same exact
inputs, thus implicitly proving the correctness of the underlying
software.  Obviously the use of ${\rm E}_{out}$ saves a considerable
amount of execution time in comparison with the application of ${\rm
E}_{in}$.  Johnson et al~\cite{Johnson:79} suggest that such
transformations do not destabilize the computations.  However this is only
apparent after a careful error analysis of both ${\rm E}_{in}$ and ${\rm
E}_{out}$.  In view of the size of both ${\rm E}_{in}$ and ${\rm E}_{out}$
such an analysis has to be automatized as well.  Work in this direction is
in progress.

The current version of SCOPE, our Source-Code Optimization PackagE, is
written in RLISP. It can be used as an extension of {\REDUCE}.  It
allows to subject almost any set of proper {\REDUCE} assignment
\index{common subexpressions (cse)} \index{cse (common subexpressions)}
statements to a heuristic search for common (sub)expressions (cse's).
The output is obtained as a sequence of assignment statements, by
default given in {\REDUCE} syntax.

The first version of the package was designed to optimize the
description of {\REDUCE}-statements, generated by
NETFORM~\cite{Smit:81,Smit:82}. This
version was tailored to a restrictive class of problems, occurring
mainly in electrical network theory, thus implying that the right-hand
sides (rhs's) in the input were limited to elements of ${{\rm {\bf }}
Z}_2$[V], where V is a set of identifiers.  The second
version~\cite{vanHulzen:83}
allowed rhs's from {\bf Z}[V]. For both versions the validity of the
commutative and the associative law was assumed.  A third version
evolved from the latter package by allowing to apply the distributive
law, i.e. by replacing (sub)expressions like $a.b\ +\ a.c$ by $a.(b\
+\ c)$ whenever possible.  But the range of possible applications of
this version was really enlarged by redefining V as a set of kernels,
implying that, at least by that time, almost any proper {\REDUCE}
expression could function as a rhs.  The mathematical capabilities of
this version are shortly summarized in~\cite{Wang:84}, in the context of code
generation and optimization for finite-element analysis.  It is used
\index{GENTRAN ! with SCOPE package}
in combination with GENTRAN, for the construction of Jacobians and
Hessians~\cite{Heuvel:89} and also in experiments with strategies for code
vectorization~\cite{Goldman:89}. It still assumes constant coefficients to be
elements of {\bf Z}.  The user-interface of the present version relies
on some GENTRAN facilities.

In~\cite{vanHulzen:81,vanHulzen:83} we described the overall
optimization strategy used for
SCOPE as a composite function ${{\rm R}^{-1}}\ \circ\ {{\rm T}}\
\circ\ {{\rm R}}$.  The function R defines how to store the input
${{\rm E}}_{0}$ in an expression data base ${{\rm D}}_{0}$. This
${{\rm D}}_{0}$ is formed by two matrix structures and a function
table.  The incidence matrices represent ${{\rm E}}_{0}$, a set of
arithmetic expressions, in a two-dimensional structure where the rows
represent expression or subexpression references and the columns
represent identifier references such as variable and function names.
The function names are taken from the function table, consisting of a
list of pairs of function applications occurring in ${{\rm E}}_0$, and
system selected names functioning as their placeholders during the
optimization process. Arguments of functions are similarly entered in
the matrix structures when ever relevant.  A given subexpression will
be entered in one of two types of incidence matrices, one for sums and
one for products, depending on the nature of the arithmetic operation
at the top level of the expression.  The two matrices are correlated
by auxiliary predecessor-successor information at the row level for
every subexpression reference. The actual entries in the matrices are
either multiplicative numerical coefficients for the sums matrix or
powers for the products matrix.  The inverse function ${{\rm
R}}^{{-1}}$ defines the output production.  The function T defines the
optimization process itself. It essentially consists of a heuristic
remodeling of the (extendable) matrices in combination with storing
information required for a fast retrieval and correct insertion of the
detected cse's in the output.  This is accomplished by an iteratively
applied search, resulting in a stepwise reduction of the arithmetic
complexity of the input set, using an extended version of Breuer's
\index{Breuer's Algorithm}
grow factor algorithm~\cite{Breuer:69,vanHulzen:81,vanHulzen:83}.
It is applied until no further profit
is gained, i.e. until the reduction in arithmetic complexity stops.
Before producing output, a finishing touch can be performed to further
reduce the arithmetic complexity with some locally applied techniques.
The overall process can be summarized as follows: $$ {{\rm R}}\ :\
{{{\rm E}}_0}\ \to\ ({{{\rm D}}_0},{{{\rm profit}}_0}) $$ $$ {{{\rm
T}}_{\beta}}\ :\ ({{{\rm D}}_i},{{{\rm profit}}_i})\ \to\ ({{{\rm
D}}_{{i+1}}},{{{\rm profit}}_{{i+1}}})\ ,\ {{\rm i}}\ =\ 0,..., \lambda
- 1.  $$ $$ {{\rm F}}\ :\ ({{{\rm D}}_{\lambda}},{{{\rm
profit}}_{\lambda}})\ \to\ {D_{\lambda}} $$ $$ {{{\rm R}}^{{-1}}}\ :\
{D_{\lambda}}\ \to\ {{{\rm E}}_{\lambda}} $$ ${{\rm D}}_{0}$ is
created as a result of an R-application performed on input ${{\rm
E}}_{0}$.  The termination condition depends on some profit criterion
related to the arithmetic complexity of the latest version of the
input, ${{{\rm D}}_i}$. Hence we assume ${{{\rm profit}}_i}\ =\ true$
for $i\ =\ 0,..., \lambda -1$ and ${{{\rm profit}}_\lambda}\ =\
false$.  The function T is composite as well, and defined by ${{\rm
T}}\ =\ {{\rm F}}\ \circ\ {{{{\rm T}}_{\beta}}^{\lambda}}$. ${{\rm
T}}_{\beta}$ defines one iteration step, i.e. one application of the
extended version of Breuer's algorithm. The function F defines a
finishing touch, resulting in the final version $D_{\lambda}$ of
${{\rm D}}_{0}$, used to produce the output ${{\rm E}}_{\lambda}$. We
omit a further discussion of the different algorithms used for
optimization; this can be found in~\cite{vanHulzen:81,vanHulzen:83},
for instance.

The present version makes use of some GENTRAN facilities to translate
its input into LISP prefix forms. This approach can be seen as a form
of preprocessing, i.e. ${{\rm E}}_{0}$, the input for R can be
considered as a list of {\bf setq}-applications

The GENTRAN-SCOPE Interface, allows other preprocessing activities.
We introduced the optional use of GENTRAN's {\bf declare}-statement,
\index{DECLARE statement ! GENTRAN}
thus allowing specification of the type of some or all of the lhs's and of
the identifiers used to construct the rhs's. In addition to the
prefixlist, a list of declarations in the Target Language can be
produced, based on default assumptions concerning untyped lhs's and
identifiers in the input.  This facility is based on the use of
GENTRAN's symbol table.

Before optimizing rhs's it might be attractive to rewrite them using a
\index{Horner's Rule}
generalized form of Horner's Rule. We designed such a command, which
does not necessarily have to be used in the context of SCOPE. It can
operate on a set of assignment statements and it can deliver the
result in the form of a sequence of prefix forms, defining the
rewritten statements. Subjecting such a sequence of prefix forms to a
SCOPE application implies that the GENTRAN approach is not directly
applicable. The GENTRAN := and :=: assignment operators define literal
translation or rhs-simplification, respectively. Therefore we extended
our Interface with special facilities, allowing SCOPE to accept the
result of the application of such a command literally. Besides the
{\bf g}(eneralized) {\bf horner} (rule) we have a command,
generalizing the impact of the {\bf structr}-command to a set of
assignment statements.

We discuss and illustrate a straightforward use of SCOPE in
section~\ref{SCOPE:basic} In section~\ref{SCOPE:pre} we introduce the
special commands {\bf ghorner} and {\bf gstructr} and show how to use
them, also in combination with SCOPE.  We use section~\ref{SCOPE:decl} to
discuss the declaration facilities and section~\ref{SCOPE:files} to show
the different file-handling possibilities and modes of operation.
Section!\ref{SCOPE:future} discusses future work.  Guidelines for
installing the package are given in the final section.

\section{Source-Code Optimization : The Basic Facilities}\label{SCOPE:basic}
\subsection{The Strategy}

Before illustrating the effect of applying SCOPE, we shortly describe
the operations, covered by the functions ${{\rm T}}_{\beta}$ and F,
mentioned in the previous section.

The function R accepts assignment statements given in prefix form.  We
can divide these forms in three categories using their leading
operator. We distinguish between PLUS, TIMES and OTHER-operators.
Leaving aside the OTHER-operators for awhile, we reduce the structure
of possible rhs's to those of not necessarily expanded multivariate
polynomials with integer coefficients. Assuming the leading operator
\ttindex{PLUS}
is PLUS, the operands, being terms of a polinomial (for instance $3a\
+\ 2b\ +\ 3 {b^2} c (3a\ +\ 2b){(c\ +\ d)^2}$), can either be
primitive or composite.  A primitive term is an integer, an identifier
or the product of an integer and an identifier.  Hence the primitive
terms of a sum form an (eventually empty) linear expression ($3a\ +\
2b$).  Composite terms are products, which cannot be qualified as a
primitive term ($3 {b^2} c (3a\ +\ 2b) {(c\ +\ d)}^{2}$) Like sums,
\ttindex{TIMES}
prefix forms with a TIMES-operator, can have a primitive and/or
composite part. The primitive part of a product is an (eventually
empty) power product(${b^2} c$).  The composite part is a product of
sums and/or powers of sums ($(3a\ +\ 2b) {(c\ +\ d)^2}$).  Observe
that our expression-structure discussed so far is still too simple.
\ttindex{EXPT}
Powers of sums have EXPT as their leading operator (${(c\ +\
d)}^{2}$).  Similarly, a product can have a integer coefficient ($3
{b^2} c$).

This description suggests, as already indicated in section~\ref{SCOPE:intro},
that we
can consider any set of rhs's as being built with linear expressions
and power products only. This allows to map such a set onto two
incidence matrices: One defining the linear expressions, using the
coefficients, and another defining the power products, using the
exponents. The rows of these matrices can be associated with the
(sub)expressions under consideration and the columns with the
identifiers, used to construct these expressions. This is why we need
to assume the validity of the commutative and associative law. To be
able to retrieve the structure of the assignment statements forming
the input set, we need to combine additional information with the rows
and columns of these matrices. Essential is, for instance, storage of
the exponents of sums and of the coefficients of products.  Equally
important is storage of the lhs's, which are the rhs-recognizers.
Details are given in~\cite{vanHulzen:83}. Example~\ref{ex:2.2.1} on
page~\pageref{ex:2.2.1} and example~\ref{ex:2.2.2} on page~\pageref{ex:2.2.2}
provide illustrations of these data structures.

When introducing kernels, i.e. when assuming the set of
OTHER-operators to be not empty, we have to store lists of
non-commutable arguments.  Therefore a function table of pairs is
made, formed by the kernels and their internally created names. These
names are entered in the matrices as new identifiers. The arguments of
such a kernel can be arbitrary {\REDUCE}-expressions, which also have to
be incorporated in the matrices.  Hence the function table is created
recursively.

\index{cse (common subexpressions)}
What is a cse and how do we locate its occurrences?  A (sub)expression
is common when it occurs repeatedly in the input. The occurrences are,
as part of the input, distributed over the matrices, and shown as
equivalent integer (sub)patterns.  In fact, we repeatedly search for
completely dense (sub)matrices of rank 1.  The expression $2a\ +\ 3c$
is a cse of ${e_1} \ =\ 2a\ +\ 4b\ +\ 3c$ and ${e_2}\ =\ 4a\ +\ 6c\ +\
5d$, representable by (2,4,3,0) and (4,0,6,5), respectively.  We
indeed have to assume commutativity, so as to be able to produce new
patterns (2,0,3,0,0), (0,4,0,0,1) and (0,0,0,5,2), representing $s\ =\
2a\ +\ 3c$, ${e_1}\ =\ 4b\ +\ s$ and ${e_2}\ =\ 5d\ +\ 2s$,
respectivily, and thus saving one addition and one multiplication.
Such an additive cse can be a factor in a composite (sub)product,
which in turn can be reduced to a primitive product, when the cse is
replaced by a new symbol.  Therefore an essential part of an
optimization step is regrouping of information. This migration of
information between the matrices is performed if the Breuer-searches
are temporarily completed.  After this regrouping the distributive law
is applied, eventually also leading to a further regrouping. If at
least one of these actions leads to a rearrangement of information the
function ${\rm T} _{\beta}$ is again applied.  Observe that this
${{\rm T}}_{\beta}$ is also a composite function.  In view of the
iterative character of the optimization process we always accept
minimal profits.

A similar search is performed to detect multiplicative cse's, for
instance occuring in ${e_1}\ =\ {a^2} {b^4} {c^3}$ and ${e_2}\ =\
{a^4} {c^6} {d^5}$.  However, given a power product $\prod_{i=1}^m
{x_i}^{{a}_i}$, any product $\prod_{i=1}^m {x_i}^{{b}_i}$, such that
some ${b_i}\ \ {a_i}$, for i = 1(1)m, can function as a cse.  We
therefore extend the search for multiplicative cse's by employing this
property, and as indicated in~\cite{vanHulzen:83}.

The function F -defining the finishing touch- performs one-row and/or
one-column searches. Once the extended Breuer-searches do not lead to
further reduction in the arithmetic complexity we try -applying it- to
improve what is left.  The integer coefficients in (sub)sums can have,
possibly locally, a gcd, which can be factored out.  One-column
operations serve to discover and properly replace integer multiples of
identifiers.  As part of the output-process we subject all
exponentiations left - at most one for each identifier - to an
addition chain algorithm.  Another action, covered by F is therefore
replacement by a new symbol of those (sub)sums, which are raised to
some integer power.

\subsection{The Facilities}

{\REDUCE} allows, roughly speaking, two modes of operation: {\tt ON EXP}
or {\tt OFF EXP}.  The first alternative is the default setting leading to
expanded forms.  The latter gives unexpanded forms, as discussed by Hearn
in some detail~\cite{Hearn:85,Hearn:86}.  It is obvious that the {\tt OFF
EXP} setting is in \index{EXP switch} general preferable over the {\tt ON
EXP} setting when attempting to optimize the description of a set of
assignment statements.

Starting a {\REDUCE} session gives the initial state. All switches
have their initial value: {\tt ON EXP, PERIOD} and {\tt OFF FORT}, for
instance.  When loading SCOPE we create a new operating environment,
without disturbing the current state of the system.

The result of an application of SCOPE can be influenced by the use of
certain {\REDUCE}- or SCOPE-switches. The influence of {\tt EXP} is obvious.
\index{ACINFO switch} \index{echo ! in SCOPE}
By default the switch {\tt ACINFO} is turned on. This guarantees an echo of
the form in which the assignment statements are consumed by SCOPE. It
also guarantees tables with the numbers of arithmetic operations,
occuring in ${{{\rm E}}_0}$ and ${{\rm E}}_{\lambda}$, respectively,
to be printed.  Some switches are available to obtain information
about the process itself.  They were introduced to assist in debugging
\index{tracing ! SCOPE package} \index{PRIMAT switch}
and testing.  {\tt PRIMAT} can be used to visualize both ${{\rm D}}_{0}$ and
\index{PRIALL switch}
$D_{\lambda}$.  {\tt PRIALL} is a switch which combines not only the effect
of {\tt ACINFO} and {\tt PRIMAT}, but also allows to obtain timings of the
different sub-algorithms of SCOPE.

Output is by default given in {\REDUCE} syntax, but FORTRAN syntax is
\index{PREFIX switch}
possible in the usual way. The switch {\tt PREFIX} can be used to obtain the
prefixlist itself as output.

\index{OPTIMIZE command}
A SCOPE action is easily performed.  Either the command ``{\bf
optimize} $<$ object$>$;'' or the command ``{\bf optimize}
$<$object$>$ {\bf iname} $<$cse-prefix$>$;'' suffices.  The
$<$object$>$ to be elaborated is either one assignment statement or a
list of such statements, all obeying the GENTRAN rules.  The
$<$cse-prefix$>$ is an identifier, used to generate the cse-names, by
extending it with an integer part. The {\bf gensym}-function is
applied when the {\bf iname}-extension is omitted.

We now illustrate the use of SCOPE through some small examples, by
showing parts of {\REDUCE} sessions.

\example\label{ex:2.2.1}
\index{SCOPE package ! example}

The multivariate polynomial Z is a sum of 6 composite terms. These
terms, monomials, are constant multiples of primitive products.  A
picture of ${{\rm D}}_{0}$ is shown after the input echo. The
sums-matrix consists of only one row, identifiable by its Fa(the)r Z,
the lhs. Its exponent is given in the E(xponent or )C(oefficient)
field. The 6 monomials are stored in the products-matrix. The
coefficients are stored in the EC-fields and the predecessor row
index, 0, is given in the Far-field. Before the $D_{\lambda}$ picture
is given the effect of the optimization process, the output and the
operator counts are shown. The optimized form of Z is obtained by
applying the distributive law. The output also shows applications of
an addition chain algorithm (\cite{Knuth:80} 441-466) as part of ${{\rm
R}}^{{-1}}$, although its use in example~\ref{ex:2.2.3} is more apparent.

Observe that the output illustrates the heuristic character of the
optimization process: In this particular case the rhs can be written
as a polynomial in S3, thus saving one extra multiplication.

{\small
\begin{verbatim}
on primat$

optimize z:=a^2*b^2+10*a^2*m^6+a^2*m^2+2*a*b*m^4+
            2*b^2*m^6+b^2*m^2 iname s;

      2  2       2  6    2  2          4      2  6    2  2
Z := A *B  + 10*A *M  + A *M  + 2*A*B*M  + 2*B *M  + B *M



Sumscheme :

   || EC|Far
- ------------
  0||  1| Z
- ------------


Productscheme :

   |  0  1  2| EC|Far
- ---------------------
  1|     2  2|  1| 0
  2|  6     2| 10| 0
  3|  2     2|  1| 0
  4|  4  1  1|  2| 0
  5|  6  2   |  2| 0
  6|  2  2   |  1| 0
- ---------------------
0  : M
1  : B
2  : A


Number of operations in the input is:

Number of (+,-)-operations : 5
Number of (*)-operations : 10
Number of integer exponentiations : 11
Number of other operations : 0
S0 := B*A
S4 := M*M
S8 := B*B
S1 := S4*S8
S9 := A*A
S2 := S4*S9
S3 := S4*S4
Z := S1 + S2 + S0*(2*S3 + S0) + S3*(2*S1 + 10*S2)


Number of operations after optimization is:

Number of (+,-)-operations : 5
Number of (*)-operations : 12
Number of integer exponentiations : 0
Number of other operations : 0



Sumscheme :

   |  0  3  4  5| EC|Far
- ------------------------
  0|        1  1|  1| Z
 15|        2 10|  1| 14
 17|  2  1      |  1| 16
- ------------------------
0  : S3
3  : S0
4  : S1
5  : S2

Productscheme :

   |  8  9 10 11 17 18 19 20| EC|Far
- ------------------------------------
  7|                    1  1|  1| S0
  8|  1                 2   |  1| S1
  9|  1                    2|  1| S2
 10|  2                     |  1| S3
 11|                 2      |  1| S4
 14|     1                  |  1| 0
 16|              1         |  1| 0
- ------------------------------------
8  : S4
9  : S3
10 : S2
11 : S1
17 : S0
18 : M
19 : B
20 : A
\end{verbatim}}

\example\label{ex:2.2.2} \index{SCOPE package ! example}

The input echo below shows the literal copy of the first assignment,
in accordance with the GENTRAN := operator.  The second assignment,
again in accordance with the GENTRAN operator ::=:, has a rhs in
expanded form.
\newline
The ${{\rm D}}_{0}$ picture shows that during parsing string matching
of kernels in prefix form already contributes to optimization : S2 =
C*X + D and S3 =SIN(S2) are stored once.

Application of the distributive law gives the original structure of
A(1,1) back.

{\small
\begin{verbatim}
on primat$
operator a$
k:=j:=1$
u:=c*x+d$
v:=sin(u)$

optimize {a(k,j) := v*(v^2*cos(u)^2+u),
          a(k,j) ::=:v*(v^2*cos(u)^2+u)} iname s;


              2       2
A(K,J) := V*(V *COS(U)  + U)

                 2             3
A(1,1) := COS(C*X + D) *SIN(C*X + D)  + SIN(C*X + D)*C*X
          + SIN(C*X + D)*D
\end{verbatim}
\newpage
\begin{verbatim}
Sumscheme :

   |  7  8| EC|Far
- ------------------
  1|  1   |  1| 0
  3|      |  1| A(1,1)
  5|     1|  1| S2
- ------------------
7  : U
8  : D

Productscheme :

   |  0  1  2  3  4  5  6| EC|Far
- ---------------------------------
  0|                    1|  1| A(K,J)
  2|                 2  2|  1| 1
  4|     3  2            |  1| 3
  6|           1  1      |  1| 5
  7|     1     1  1      |  1| 3
  8|  1  1               |  1| 3
- ---------------------------------
0  : D
1  : S3=SIN(S2)
2  : S1=COS(S2)
3  : X
4  : C
5  : S0=COS(U)
6  : V

Number of operations in the input is:

Number of (+,-)-operations : 7
Number of (*)-operations : 10
Number of integer exponentiations : 4
Number of other operations : 5

S6 := COS(U)*V
S9 := S6*S6
A(K,J) := V*(U + S9)
S2 := D + X*C
S3 := SIN(S2)
S7 := S3*COS(S2)
S8 := S7*S7
A(1,1) := S3*(S2 + S8)

Number of operations after optimization is:

Number of (+,-)-operations : 3
Number of (*)-operations : 7
Number of integer exponentiations : 0
Number of other operations : 3

Sumscheme :

   |  2 12 13| EC|Far
- ---------------------
  1|     1   |  1| 0
  3|         |  1| A(1,1)
  5|        1|  1| S2
 11|  1      |  1| 10
- ---------------------
2  : S2
12 : U
13 : D

Productscheme :

   |  0  1  5  6  7  8  9 10 11| EC|Far
- ---------------------------------------
  0|                          1|  1| A(K,J)
  2|     2                     |  1| 1
  4|  2                        |  1| 11
  9|                 1  1      |  1| 5
 10|           1               |  1| 3
 13|                       1  1|  1| S6
 14|           1  1            |  1| S7
- ---------------------------------------
0  : S7
1  : S6
5  : D
6  : S3=SIN(S2)
7  : COS(S2)
8  : X
9  : C
10 : COS(U)
11 : V
\end{verbatim}}

\example\label{ex:2.2.3}
\index{SCOPE package ! example}

The effect is shown of a finishing touch application, in combination
with FORTRAN output.  During output preparation {\tt S0} is
rewritten, using the earlier mentioned addition chain algorithm.

{\small
\begin{verbatim}
on fort$
off acinfo,period$

optimize z:=96*a+18*b+9*c+3*d+6*e+18*f+6*g+5*h+5*k+3)^13
            iname s;

      S0=5*(H+K)+3*(3*C+D+1+6*(B+F)+2*(A+E+G))
      S4=S0*S0
      S3=S0*S4
      S2=S3*S3
      S1=S2*S2
      Z=S0*S1
\end{verbatim}}

\example\label{ex:2.2.4}
\index{SCOPE package ! example}

Recovery of repeatedly occurring integer multiples of identifiers,
as part of the finishing touch, is illustrated. The switch {\tt ACINFO}
is turned off.

\begin{verbatim}
optimize {x:=3*a*p,
          y:=3*a*q,
          z:=6*a*r+2*b*p,
          u:=6*a*d+2*b*q,
          v:=9*a*c+4*b*d,
          w:=4*b} iname s;

S1 := 3*A
X := S1*P
Y := S1*Q
S2 := 6*A
S3 := 2*B
Z := S3*P + S2*R
U := S3*Q + S2*D
S0 := 4*B
V := S0*D + 9*A*C
W := S0
\end{verbatim}

\example\label{ex:2.2.5}
\index{SCOPE package ! example}

The effect of {\tt ON EXP} or {\tt OFF EXP} on the result of a
SCOPE-application is now shown by optimizing the representation of the
determinant of a symmetric (3,3) matrix M.  Besides differences in
computing time we also observe that the arithmetic complexity of the
optimized version of the expanded representation of the determinant is
about the same as the not optimized form of the unexpanded representation.

{\small
\begin{verbatim}
matrix M(3,3)$

m(1,1):=18*cos(q3)*cos(q2)*m30*p^2-sin(q3)^2*j30y+sin(q3)^2*j30z-
        9*sin(q3)^2*m30*p^2+j1oy+j30y+m10*p^2+18*m30*p^2$
m(2,1):=
m(1,2):=9*cos(q3)*cos(q2)*m30*p^2-sin(q3)^2*j30y+sin(q3)^2*j30z-
        9*sin(q3)^2*m30*p^2+j30y+9*m30*p^2$
m(3,1):=
m(1,3):=-9*sin(q3)*sin(q2)*m30*p^2$
m(2,2):=-sin(q3)^2*j30y+sin(q3)^2*j30z-9*sin(q3)^2*m30*p^2+j30y+
        9*m30*p^2$
m(3,2):=
m(2,3):=0$
m(3,3):=9*m30*p^2+j30x$

optimize detm:=:det(M) iname s;

                   4        2  6    3             4        2  4    2
DETM := 729*SIN(Q3) *SIN(Q2) *P *M30  + 81*SIN(Q3) *SIN(Q2) *P *M30 *

                 4        2  4    2                   2        2  6
J30Y - 81*SIN(Q3) *SIN(Q2) *P *M30 *J30Z - 729*SIN(Q3) *SIN(Q2) *P *

   3             2        2  4    2                   2  6    3
M30  - 81*SIN(Q3) *SIN(Q2) *P *M30 *J30Y - 729*SIN(Q3) *P *M30  - 81*

       2  6    2                 2  4    2                  2  4    2
SIN(Q3) *P *M30 *M10 - 81*SIN(Q3) *P *M30 *J30Y + 81*SIN(Q3) *P *M30

                  2  4    2                  2  4    2
*J30Z - 81*SIN(Q3) *P *M30 *J1OY - 81*SIN(Q3) *P *M30 *J30X - 9*

       2  4                         2  4                         2  4
SIN(Q3) *P *M30*J30Y*M10 + 9*SIN(Q3) *P *M30*J30Z*M10 - 9*SIN(Q3) *P

                         2  2                          2  2
*M30*M10*J30X - 9*SIN(Q3) *P *M30*J30Y*J1OY - 9*SIN(Q3) *P *M30*J30Y*

                2  2                          2
J30X + 9*SIN(Q3) *P *M30*J30Z*J1OY + 9*SIN(Q3) *P *M30*J30Z*J30X - 9*

       2  2                        2  2                        2  2
SIN(Q3) *P *M30*J1OY*J30X - SIN(Q3) *P *J30Y*M10*J30X + SIN(Q3) *P *

                       2                         2
J30Z*M10*J30X - SIN(Q3) *J30Y*J1OY*J30X + SIN(Q3) *J30Z*J1OY*J30X - 

           2        2  6    3             2        2  4    2
729*COS(Q3) *COS(Q2) *P *M30  - 81*COS(Q3) *COS(Q2) *P *M30 *J30X + 

     6    3       6    2           4    2            4    2
729*P *M30  + 81*P *M30 *M10 + 81*P *M30 *J30Y + 81*P *M30 *J1OY + 81

  4    2           4                   4                   2
*P *M30 *J30X + 9*P *M30*J30Y*M10 + 9*P *M30*M10*J30X + 9*P *M30*J30Y

           2                    2                  2
*J1OY + 9*P *M30*J30Y*J30X + 9*P *M30*J1OY*J30X + P *J30Y*M10*J30X + 

J30Y*J1OY*J30X

Number of operations in the input is:

Number of (+,-)-operations : 36
Number of (*)-operations : 148
Number of integer exponentiations : 84
Number of other operations : 32
S0 := SIN(Q3)
S30 := S0*S0
S1 := SIN(Q2)
S34 := S1*S1
S35 := P*P
S7 := S35*M30
S33 := S7*S7
S5 := S33*J30Y
S6 := S30*S7
S8 := S30*M10
S49 := COS(Q2)*COS(Q3)
S9 := S49*S49
S11 := S34*S30*S30
S22 := S35*S7
S14 := S30*J30Z
S19 := S35*J30X
S23 := J30X*J10Y
S31 := S33*S7
S47 := 81*S33*J30X
S39 :=  - S47 - S23*J30Y - 81*S33*J1OY
S40 :=  - 81*S30*S5 - 729*S33*S6
S45 := 9*S6*J30Z
S46 := 9*S6
S48 := 81*S5
DETM := S48 + S40 - S39 + 729*S31 + ( - J1OY - J30X)*(9*(S6*J30Y - S7

      *J30Y) - S45) + (J30Z - J30Y)*(9*S22*S8 + S19*S8) + 9*(M10 - S8

   )*(S22*J30X + 9*S22*S7) + M10*J30Y*(9*S22 + S19) + S23*(S14 + 9*S7

    - S46) + S39*S30 + S31*(729*(S11 - S9)) + S34*(S40 - S46*S45) - 

S47*S9 + 81*S33*S14 + S48*S11


Number of operations after optimization is:

Number of (+,-)-operations : 29
Number of (*)-operations : 58
Number of integer exponentiations : 0
Number of other operations : 4


off exp$

optimize detm:=:det(M) iname s;

             2                           2                   2
DETM := ((9*P *M30 + J30Y - J30Z)*SIN(Q3)  - (18*M30 + M10)*P  - 18

                    2                         2
  *COS(Q3)*COS(Q2)*P *M30 - J30Y - J1OY)*((9*P *M30 + J30Y - 

                   2      2                 2
      J30Z)*SIN(Q3)  - 9*P *M30 - J30Y)*(9*P *M30 + J30X) - 

     2                            2                      2
((9*P  *M30 + J30Y - J30Z)*SIN(Q3)  - 9*COS(Q3)*COS(Q2)*P *M30 - 

   2             2     2                      2
9*P * M30 - J30Y) *(9*P *M30 +J30X) + 81*((9*P *M30+J30Y - J30Z)*

          2      2                    2        2  4    2
   SIN(Q3)  - 9*P *M30 - J30Y)*SIN(Q3) *SIN(Q2) *P *M30


Number of operations in the input is:

Number of (+,-)-operations : 24
Number of (*)-operations : 42
Number of integer exponentiations : 21
Number of other operations : 10

S0 := SIN(Q3)
S9 := S0*S0
S8 := P*P
S5 := S8*M30
S6 := S5*COS(Q2)*COS(Q3)
S15 := 9*S5
S13 := (S15 + J30Y - J30Z)*S9
S14 := S13 - S15 - J30Y
S3 := S14 - 9*S6
S4 := SIN(Q2)
DETM := (S15 + J30X)*(S14*(S13 - 18*S6 - J30Y - J1OY - S8*(18*M30 +

  M10)) - S3*S3) + 9*S15*S14*S9*S5*S4*S4


Number of operations after optimization is:

Number of (+,-)-operations : 13
Number of (*)-operations : 20
Number of integer exponentiations : 0
Number of other operations : 4
\end{verbatim}}

We can also use this example to show that correctness of the results
\index{NAT switch}
can easily be verified. When turning off the switch {\tt NAT} and storing
the result of a SCOPE application in a file, it is of course possible
to read the result in again. But we then operate in a normal
{\REDUCE}-like way. This implies that all cse-names are automatically
replaced by their values.  We show the ``correctness'' of SCOPE by
scoring the optimized version of the expanded form of the determinant
of M, called detm1 in file out1 and the result of a SCOPE-application
on the unexpanded form, detm2, in file out2, followed by reading both
files and by subtracting detm2 from detm1, resulting in the value 0.
This is of course an ad hoc correctness-proof for one specific
example. It is in fact another way of testing the code of the package.
So, assuming SCOPE is loaded and the matrix M is known to the system,
all we have to do is:
{\small
\begin{verbatim}
2: off acinfo,nat$

3: out out1$
4: optimize detm1:=:det(M) iname s;
5: write "end$"$
6: shut "out1"$

7: off exp$

8: out out2$
9: optimize detm2:=:det(M) iname t;
10: write "end$"$
11: shut out2$

12: on nat$

13: in out1;

S0 := SIN(Q3)$
S30 := S0*S0$
S1 := SIN(Q2)$
S34 := S1*S1$
S35 := P*P$
S7 := S35*M30$
S33 := S7*S7$
S5 := S33*J30Y$
S6 := S30*S7$
S8 := S30*M10$
S49 := COS(Q2)*COS(Q3)$
S9 := S49*S49$
S11 := S34*S30*S30$
S22 := S35*S7$
S14 := S30*J30Z$
S19 := S35*J30X$
S23 := J30X*J1OY$
S31 := S33*S7$
S47 := 81*S33*J30X$
S39 :=  - S47 - S23*J30Y - 81*S33*J1OY$
S40 :=  - 81*S30*S5 - 729*S33*S6$
S45 := 9*S6*J30Z$
S46 := 9*S6$
S48 := 81*S5$
DETM1 := 
S48 + S40 - S39 + 729*S31 + ( - J1OY - J30X)*(9*(S6*J30Y - S7*J30Y) -

S45) + (J30Z - J30Y)*(9*S22*S8 + S19*S8) + 9*(M10 - S8)*(S22*J30X + 9

*S22*S7) + M10*J30Y*(9*S22 + S19) + S23*(S14 + 9*S7 - S46) + S39*S30

+ S31*(729*(S11 - S9)) + S34*(S40 - S46*S45) - S47*S9 + 81*S33*S14 +

S48*S11$

end$

14: in out2;

T0 := SIN(Q3)$
T9 := T0*T0$
T8 := P*P$
T5 := T8*M30$
T6 := T5*COS(Q2)*COS(Q3)$
T15 := 9*T5$
T13 := (T15 + J30Y - J30Z)*T9$
T14 := T13 - T15 - J30Y$
T3 := T14 - 9*T6$
T4 := SIN(Q2)$
DETM2 := (T15 + J30X)*(T14*(T13 - 18*T6 - J30Y - J1OY - T8*(18*M30 +

 M10)) - T3*T3) + 9*T15*T14*T9*T5*T4*T4$

end$

15: detm1-detm2;

0
\end{verbatim}
}

\example\label{ex:2.2.6}
\index{SCOPE package ! example}

This example serves to show how SCOPE deals with rational exponents.
All rational exponents of a variable are collected. The least common
multiple lcm of the denominators of these rational exponents is
computed and the variable is replaced by a possibly newly selected
variable name, denoting the variable raised to the power 1/lcm. This
facility is only efficient for what we believe to be problems
occurring in computational practice. This is easily verified by
extending the sum we are elaborating here with some extra terms.

Producing FORTRAN-output shows an implied danger, due to a shortcoming
in GENTRAN. This rational exponent will in practice act as if it were
0.

This example is also used to show the effect of turning on the switch
{\tt PRIALL}.
{\small
\begin{verbatim}
on fort,priall$

optimize z:=:for j:=2:6 sum q^(1/j) iname s;


      1/6    1/5    1/4    1/3
Z := Q    + Q    + Q    + Q    + SQRT(Q)

Sumscheme :

   || EC|Far
- ------------
  0||  1| Z
- ------------

Productscheme :

   |  0| EC|Far
- ---------------
  1| 10|  1| 0
  2| 12|  1| 0
  3| 15|  1| 0
  4| 20|  1| 0
  5| 30|  1| 0
- ---------------
0  : Q


Number of operations in the input is:

Number of (+,-)-operations : 4
Number of (*)-operations : 0
Number of integer exponentiations : 0
Number of other operations : 5


Time: 2992 ms

Breuer search :
Time: 867 ms

Removal of different names for identical cse's :
Time: 17 ms

Change Scheme :
Time: 0 ms

Local Factorization :
Time: 34 ms

Breuer search :
Time: 204 ms

Removal of different names for identical cse's :
Time: 0 ms

Change Scheme :
Time: 17 ms

Local Factorization :
Time: 0 ms

Breuer search :
Time: 187 ms

Removal of different names for identical cse's :
Time: 0 ms

Change Scheme :
Time: 17 ms

Local Factorization :
Time: 0 ms

Breuer search :
Time: 119 ms

Removal of different names for identical cse's :
Time: 0 ms

Change Scheme :
Time: 17 ms

Local Factorization :
Time: 0 ms

Additional optimization during finishing touch :
Time: 34 ms


      Q=Q**(1/60)
      S7=Q*Q
      S6=S7*Q
      S4=S7*S6
      S2=S4*S4
      S1=S7*S2
      S0=S6*S1
      S3=S4*S0
      Z=S3+S0+S1+S2+S3*S2



Number of operations after optimization is:

Number of (+,-)-operations : 4
Number of (*)-operations : 8
Number of integer exponentiations : 0
Number of other operations : 1
\end{verbatim}
\newpage
\begin{verbatim}
Sumscheme :

   |  3  4  5  6| EC|Far
- ------------------------
  0|  1  1  1  1|  1| Z
- ------------------------
3  : S3
4  : S0
5  : S1
6  : S2


Productscheme :

   |  9 10 12 13 14 15 16 22| EC|Far
- ------------------------------------
  5|           1  1         |  1| 0
  6|     1           1      |  1| S0
  7|  1           1         |  1| S1
  8|        2               |  1| S2
  9|        1           1   |  1| S3
 10|  1  1                  |  1| S4
 12|  1                    1|  1| S6
 13|                       2|  1| S7
- ------------------------------------
9  : S7
10 : S6
12 : S4
13 : S3
14 : S2
15 : S1
16 : S0
22 : Q

Time: 459 ms
\end{verbatim}
}

\section{Preprocessing Possibilities}\label{SCOPE:pre}

It may happen that structure is obviously visible in the rhs's of a
set of assignment statements, which we want to optimize.  One can
think of a set of partial derivatives of products.  Or one may
consider the application of Horner-rules.  Such facilities may be
attractive, independent of the question if a SCOPE-application will be
performed on its result.  Therefore we first discuss these facilities
and show their effect, again by using simple examples, before we
continue with a combined use of SCOPE and these possibilities.

The first alternative demands a generalized {\bf structr}-command.  We
implemented such a facility. Its syntax is straightforward: ``{\bf
\index{GSTRUCTR command}
gstructr} $<$object$>$ {\bf name} $<$id$>$;'' The $<$object$>$ to be
elaborated is one assignment statement or a set of such statements,
separated by semicolons and grouped together between the special
symbols $<<$ and $>>$. Instead of a statement a matrix name is also
allowed. Then all non-zero matrix elements are incorporated in the
search for obvious cse's. The $<$id$>$ of the optional {\bf name}-part,
being an identifier, is used to identify the subexpressions, produced
via the application of a {\bf gstructr} command. When the switch
\index{ALGPRI switch}
{\tt ALGPRI} is on -the default setting- the output is given in {\REDUCE}
syntax, while turning it off leads to output in prefix form.  The
latter is employed by the function R, used to store SCOPE-input in
${{\rm D}}_{0}$.  It is also possible to get FORTRAN-output by turning
\index{PERIOD switch} \index{FORTRAN switch}
off the switch {\tt PERIOD} and turning on the switch {\tt FORTRAN}.  The input
\index{EXP switch}
remains unchanged when the switch {\tt EXP} is on.

\example\label{ex:3.1}
\index{SCOPE package ! example}

We show part of a {\REDUCE} session.
{\small
\begin{verbatim}
off exp$

matrix a(2,2)$

a(1,1) := x+y+z$
a(1,2) := x*y$
a(2,1) := (x+y)*x*y$
a(2,2) := (x+2*y+3)^3-x$

on fort$
off period$

load struct$

gstructr << a;
            b:=(x+y)^2;
            c:=(x+y)*(y+z);
            d:=(x+2*y)*(y+z)*(z+x)^2
         >> name v;

      V1=X+Y+Z
      A(1,1)=V1
      A(1,2)=X*Y
      V2=X+Y
      A(2,1)=V2*X*Y
      V3=X+2*Y+3
      V4=V3**3-X
      A(2,2)=V4
      B=V2**2
      V5=Y+Z
      C=V2*V5
      V6=X+2*Y
      V7=X+Z
      D=V6*V7**2*V5

\end{verbatim}
}

Observe that V1, V3, V4, V6 and V7 only occur once in this result of a
{\bf gstructr}-application. When applied as part of a SCOPE-operation
these redundancies will be removed before the actual optimization
process is performed, as shown in example~\ref{ex:3.3}.

\index{GHORNER command} \index{Horner's Rule}
The syntax for the {\bf ghorner}-command is very similar.  The
application of a Horner-rule assumes an ordering of the identifiers.
We allow instead of the {\bf name}-part of the {gstructr} command an
optional {\bf vorder} $<$list of id.s$>$ extension.  The $<$list of
id.s$>$ consists of at least one identifier. This list overrules, in
the order given, the current identifier ordering of the system. The
rhs's are considered as polynomials in the leftmost element of the
{\bf vorder}-list. The thus created coefficients are in turn
considered as polynomials in the second element of this list. And so
on. When the {\bf vorder}-extension is omitted the current system
identifier ordering is applied.  The internal switch {\tt ALGPRI} is again
\index{ALGPRI switch}
applicable and has the same meaning as for {\bf gstructr}.

Some optimizing compilers apply Horner-rules when possible. Our
optimization strategy is based on an all levels, all expressions
search. This contradicts the Horner-mechanism. To avoid destabilizing
side-effects of Horner-rule applications we decided to bring such a
facility under user-control.

\example\label{ex:3.2}
\index{SCOPE package ! example}

Some Taylor-expansions are shown.
\newpage
{\small
\begin{verbatim}
algebraic procedure taylor(fx,x,x0,n);
sub(x=x0,fx)+for k:=1:n sum
        (sub(x=x0,df(fx,x,k))*(x-x0)^k/
      (if k<3 then k else for j:=2:k product j))$
let x^4=0,y^7=0$

f1:=(taylor(e^x,x,0,4)*taylor(cos y,y,0,6))^2;


             3  6       3  4        3  2        3       2  6       2
F1 :=  - (8*X *Y  - 60*X *Y  + 180*X *Y  - 180*X  + 12*X *Y  - 90*X *

    4        2  2        2         6         4          2
   Y  + 270*X *Y  - 270*X  + 12*X*Y  - 90*X*Y  + 270*X*Y  -

              6       4        2
   270*X + 6*Y  - 45*Y  + 135*Y  - 135)/135

load horner$

ghorner << f1:=f1;
           g1:=taylor(e^x,x,0,4);
           h1:=taylor(cos y,y,0,6);
           f1:=(g1*h1)^2 >> vorder y,x;

                                            2
F1 := ((135 + X*(270 + X*(270 + X*180))) + Y *(( - 135 + X*( - 270 +

                             2
  X*( - 270 + X*(-180)))) + Y *((45 + X*(90 + X*(90 + X

                  2
        *60))) + Y *( - 6 + X*( - 12 + X*( - 12 + X*(-8

        )))))))/135

       6 + X*(6 + X*(3 + X))
G1 := -----------------------
                 6

              2            2        2
       720 + Y *( - 360 + Y *(30 + Y *(-1)))
H1 := ---------------------------------------
                    720


                             2            2         2           2   2
      (6 + X*(6 + X*(3 + X)))  * (-720 + Y *(360 + Y  ( - 30 + Y )))
F1 := ---------------------------------------------------------------
                                  18662400
\end{verbatim}
}

Both commands can be used inside an {\bf optimize}-command. We advise
to compile both facilities and SCOPE separately (see also
section~\ref{SCOPE:install} on page~\pageref{SCOPE:install}).

To be able to order the application of either a {\bf gstructr}-command or
a {\bf ghorner}-rewrite instruction inside the definition of a
SCOPE-operation we have to extend the rules given in
section~\label{SCOPE:2.2}.  The permissible structures for the
$<$object$>$'s to be elaborated by SCOPE are simply extended with
syntactically correct {\bf ghorner}-and {\bf gstructr}-commands.  Hence
the structure of an {\bf optimize}-command is not altered, as is shown by
the following two examples.

\example\label{ex:3.3}
\index{SCOPE package ! example}

We show the effect of an application of the {\bf optimize}-command on the
{\bf gstructr}-command of example~\ref{ex:3.1}.  Observe that the
cse-names produced during optimization begin with an S, while {\bf
gstructr} created names start with a V.
{\small
\begin{verbatim}
on fort,acinfo$
off exp,period$

optimize gstructr << a;
                     b:=(x+y)^2;
                     c:=(x+y)*(y+z);
                     d:=(x+2*y)*(y+z)*(z+x)^2
                  >> name v
  iname s;


A(1,1) := X + Y + Z

A(1,2) := X*Y

V2 := X + Y

A(2,1) := V2*X*Y

            3
A(2,2) := (X + 2*Y + 3)  - X

       2
B := V2

V5 := Y + Z

C := V2*V5

                      2
D := (X + 2*Y)*(X + Z) *V5

Number of operations in the input is:

Number of (+,-)-operations : 9
Number of (*)-operations : 8
Number of integer exponentiations : 3
Number of other operations : 0


      S5=X+Z
      A(1,1)=S5+Y
      S8=Y*X
      A(1,2)=S8
      V2=X+Y
      A(2,1)=S8*V2
      S6=X+2*Y
      S4=S6+3
      A(2,2)=S4*S4*S4-X
      B=V2*V2
      V5=Y+Z
      C=V5*V2
      D=S6*S5*S5*V5


Number of operations after optimization is:

Number of (+,-)-operations : 7
Number of (*)-operations : 10
Number of integer exponentiations : 0
Number of other operations : 0
\end{verbatim}
}

\example\label{ex:3.4}
\index{SCOPE package ! example}

For completeness we also show how to use the Horner facilities inside
an {\bf optimize} command. Due to the structure of the method, we
operate internally on expanded forms, both representations of h1, and
thus also of the corresponding prefix representations used to built
${{\rm D}}_{0}$ slightly differ. The consequences are visualized in
the results of the SCOPE application.
{\small
\begin{verbatim}
load scope$

optimize ghorner <<h1:=taylor(cos y,y,0,6);
       f1:=(taylor(e^x,x,0,4)*h1)^2>> vorder y,x
  iname s;


              2            2        2
       720 + Y *( - 360 + Y *(30 + Y *(-1)))
H1 := ---------------------------------------
                         720

                         2        2         2           2   2
      (6+X*(6 + X*(3+X))) *(-720+Y *(360 + Y *( - 30 + Y )))
F1 := -------------------------------------------------------
                           18662400

Number of operations in the input is: 

Number of (+,-)-operations : 9
Number of (*)-operations : 8
Number of integer exponentiations : 8
Number of other operations : 2


S6 := Y*Y
       720 + S6*(S6*(30 - 1*S6) - 360)
H1 := ---------------------------------
                    720

S7 := (S6*(360 + S6*(S6 - 30)) - 720)*(6 + X*(6 + X*(3 + X)))

         S7*S7
F1 := ----------
       18662400


Number of operations after optimization is:

Number of (+,-)-operations : 9
Number of (*)-operations : 10
Number of integer exponentiations : 0
Number of other operations : 2
\end{verbatim}
}

\section{Generation of Declarations}\label{SCOPE:decl}

The GENTRAN {\bf declare}-statement can also be used as an optional
extension of the {\bf optimize}-command.  An illustration of this facility
is given in example~\ref{ex:4.1}.  The syntax of such a statement is in
accordance with the GENTRAN-rules~\cite{Gates:85}
% (see page~\pageref{explicit:type}.
We also use the symbol table of GENTRAN.
During parsing, the declared identifiers and/or array- and matrix names
are entered in the symbol table.  Once optimization is finished all
relevant information for completing the declarations is known, and
collected in the prefixlist, which is used for output-production.  This
prefixlist is employed to decide which not yet typed identifiers and
system selected cse-names have to be entered in the symbol table.  We make
use of already known information, expression-structure and the normal
hierarchy in data types.  The strategy to achieve this is essentially
based on chapter 6 of~\cite{Aho:86}.  Once this table is completed a list
of declarations is produced if the \index{OPTDECS switch} switch {\tt
OPTDECS} is turned on.  SCOPE-output is by default given in {\REDUCE}
syntax.  Alternative output is obtained by assigning a \ttindex{Optlang*}
relevant value to the global identifier {\tt Optlang!*}.  This causes
GENTRAN to take over the output preparation, as shown in:

\example\label{ex:4.1}
\index{SCOPE package ! example}

{\small
\begin{verbatim}
on optdecs$
off acinfo$
optlang!*:='fortran$

optimize {x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)}
  iname s
  declare << a(4,4),x(4),y(5):real; b(5):integer >>;


      INTEGER B(5),I,S1,S3
      DOUBLE PRECISION A(4,4),S4,X(4),Y(5)
      S1=I+1
      S3=I-1
      S4=B(I)
      X(S1)=A(S1,S3)+S4
      Y(S3)=A(S3,S1)-S4

optlang!*:='c$
optimize {x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)}
  iname s
  declare << a(4,4),x(4),y(5):real; b(5):integer >>;


LONG B[6],I,S1,S3;
DOUBLE A[5][5],S4,X[5],Y[6];
{
    S1=I+1;
    S3=I-1;
    S4=B[I];
    X[S1]=A[S1][S3]+S4;
    Y[S3]=A[S3][S1]-S4;
}

optlang!*:='pascal$

optimize {x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)}
  iname s
  declare << a(4,4),x(4),y(5):real; b(5):integer >>;


VAR
    B[0..5],I,S1,S3: INTEGER;
    A[0..4,0..4],S4,X[0..4],Y[0..5]: REAL;
BEGIN
    S1:=I+1;
    S3:=I-1;
    S4:=B[I];
    X[S1]:=A[S1,S3]+S4;
    Y[S3]:=A[S3,S1]-S4
END;

optlang!*:='ratfor$

optimize {x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)}
  iname s
  declare << a(4,4),x(4),y(5):real; b(5):integer >>;


INTEGER B(5),I,S1,S3
DOUBLE PRECISION A(4,4),S4,X(4),Y(5)
{
    S1=I+1
    S3=I-1
    S4=B(I)
    X(S1)=A(S1,S3)+S4
    Y(S3)=A(S3,S1)-S4
}

%%% The following command restores the initial situation. %%%

optlang!*:='nil$
\end{verbatim}
}

\section{File Management and Optimization Strategies}\label{SCOPE:files}

Another alternative for the $<$object$>$'s to be optimized is formed
by the sequence {\bf in} ${{\rm file}}_{1}$, ${{\rm file}}_{2}$, ...,
${{\rm file}}_{n}$, $n\ \ge\ 1$.  Each of these files is assumed to
contain one or a list of more assignment statements, obeying the
GENTRAN-assignment rules.  A SCOPE application results in a unified
sequence of assignment statements in the target language. This is
illustrated by the following example, where each file $f_i$ contains one
assignment statement of the form $e_i$ := some expression.

\example\label{ex:5.1}
\index{SCOPE package ! example}
{\small
\begin{verbatim}

3: optimize in f1,f2,f3 iname s;


                               2
                2       (X + Y)            8      2     2
       2*(SIN(X) - COS(E        )+3*COS(X)) *(X+Y) + 4*Y + 4*Y
E1 := ---------------------------------------------------------
                          3*X + 2*Y

\end{verbatim}
\newpage
\begin{verbatim}
E2 := (4*

                          2
           2       (X + Y)            2      3     2
    (SIN(X) - COS(E        )+2*COS(X)) *(X+Y) +(4*X  - 4*Y)

              2
   - 6*X)/(8*X  + 3*Y - 2*X)

                         2
                  (X + Y)
E3 := (4*SIN(COS(E        )) + SIN(X + Y) +

           2           2
       (4*X  - X + 2*Y) )/(3*Y + F(X,G( - COS(X))))


Number of operations in the input is:

Number of (+,-)-operations : 21
Number of (*)-operations : 20
Number of integer exponentiations : 12
Number of other operations : 16


S3 := SIN(X)
S7 := X + Y
S6 := S7*S7
           S6
S4 := COS(E  )
S8 := COS(X)
S28 := S3*S3 - S4
S2 := S28 + 3*S8
S36 := S2*S2
S35 := S36*S36
S30 := 2*Y
S9 := S30 + 3*X
       2*(2*Y + S30*Y + S6*S35*S35)
E1 := ------------------------------
                   S9
S12 := S28 + 2*S8
S29 := 4*X*X
S27 := S29 - X
S31 := 3*Y
       S29 - 2*S9 + 4*S6*S12*S12*S7
E2 := ------------------------------
               S31 + 2*S27
S18 := S30 + S27
       4*SIN(S4) + SIN(S7) + S18*S18
E3 := -------------------------------
           S31 + F(X,G( - S8))



Number of operations after optimization is:

Number of (+,-)-operations : 15
Number of (*)-operations : 24
Number of integer exponentiations : 0
Number of other operations : 11

\end{verbatim}
}

However a switch is available for stepwise performing the optimization
of a set of assignment statements, distributed over different files.
When turning on this {\tt AGAIN} switch the finishing touch is not
\index{AGAIN switch}
done.  Moreover, the system is instructed to save relevant internal
information in combination with the result of the present optimization
run. The thus extended output is assumed to be stored in a file. When
the optimization task is continued during another session this file is
assumed to be read before all other remaining files.  This mode of
operation is illustrated in

\example\label{ex:5.2}
\index{SCOPE package ! example}

{\small
\begin{verbatim}
2: off acinfo$
3: in again$
4: out f5$
5: optimize in f1,f2 iname s;
6: write "end$"$
7: shut f5$

8: off again$
9: on acinfo$
10: optimize in f5,f3 iname t;

S7 := X + Y
\end{verbatim}
\newpage
\begin{verbatim}
        2
S6 := S7

S8 := COS(X)

             2        S6
S18 := SIN(X)  - COS(E  )

S9 := 3*X + 2*Y

                2                    8
       4*Y + 4*Y  + 2*S6*(S18 + 3*S8)
E1 := ---------------------------------
                   S9

        2
S15 := X

                                       2
       4*S15 - 2*S9 + 4*S6*(S18 + 2*S8) *S7
E2 := --------------------------------------
             8*S15 - 2*X + 3*Y

                         2
                  (X + Y)
E3 := (4*SIN(COS(E        )) + SIN(X + Y) +

           2           2
       (4*X  - X + 2*Y) )/(3*Y + F(X,G( - COS(X))))

Number of operations in the total input, i.e. in the 2 input sets is:

Number of (+,-)-operations : 22
Number of (*)-operations : 20
Number of integer exponentiations : 13
Number of other operations : 17


T17 := X + Y
T16 := T17*T17
S8 := COS(X)
T1 := SIN(X)
           T16
T2 := COS(E   )
S18 := T1*T1 - T2
T28 := 2*Y
S9 := T28 + 3*X
T6 := S18 + 3*S8
T36 := T6*T6
T35 := T36*T36
       2*(2*Y + T28*Y + T35*T35*T16)
E1 := -------------------------------
                   S9
S15 := X*X
T9 := S18 + 2*S8
T30 := 4*S15
T26 := T30 - X
T29 := 3*Y
       T30 - 2*S9 + 4*T17*T9*T9*T16
E2 := ------------------------------
               T29 + 2*T26
T19 := T28 + T26
       4*SIN(T2) + SIN(T17) + T19*T19
E3 := --------------------------------
             T29 + F(X,G( - S8))



Number of operations after optimization is:

Number of (+,-)-operations : 15
Number of (*)-operations : 24
Number of integer exponentiations : 0
Number of other operations : 11
\end{verbatim}
}

Since the construction of declarations in combination with some
optimization activity is based on a quite specific use of GENTRAN's
symbol table, one has to operate carefully when optimizing input in
different sessions. A correct list of declarations is only guaranteed,
when the last optimization-command is extended with the required
declaration-information.

\section{Some Possible Shortcomings and Future Versions}\label{SCOPE:future}

The present version of SCOPE may have some shortcomings and possibly also
some inefficiencies.  However, since we are working on a second version,
as stated in~\cite{vanHulzen:90}, we do not have the intention to largely
modify the present version.  However, we intend to improve one special
aspect of the present SCOPE-version:  The combined use of SCOPE and
GENTRAN.  This preliminary version of the manual will shortly be extended
with the description of these combined features.

Bugs and obvious deficiencies will of course be removed.

\section*{Acknowledgements}

The many discussions I had over the past years with Barbara L. Gates,
Victor V. Goldman, Anthony C. Hearn, Jaap Smit and Paul S. Wang about
the symbolic-numeric aspects of computer algebra have been very
stimulating and valuable. They also contributed to the present status
of SCOPE.

Completion of the code would have been impossible without the dedicated
assistance of my students and the frequent discussions we had.
I certainly want to mention Ben Hulshof, Pim van den Heuvel, Marcel van
Heerwaarden, Anco Smit, Johan de Boer and Jan Verheul.

\section*{How to install the Code}\label{SCOPE:install}
\index{SCOPE package ! installation}
The code consists of a number of modules, collected in five files. Two of
these modules play a special role and can best be compiled separately:
gstructr, defining the {\bf gstructr} facilities, and ghorner, containing
the code for the Horner-rules.

The other modules form SCOPE. Since ${{\rm D}}_{0}$ and all operations
on it and on its later versions ${{\rm D}}_{i}$ are defined using {\bf
smacros's} it is essential to read in the module cosmac, containing
these {\bf smacro's}, first. Since we also use part of the GENTRAN
code care have to be taken that GENTRAN is loaded when compiling the
code.
\bibliography{scope}
\bibliographystyle{plain}
\end{document}

Added r34.1/doc/sl.bib version [7a9ae19f9c].







































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
@String{SPE="Software---Practice and Experience"}

@ARTICLE{Hearn:69,
 AUTHOR = "A. C. Hearn",
 TITLE = "Standard {LISP}",
 JOURNAL = "SIGPLAN Notices",
 YEAR = 1969, VOLUME = 4, PAGES = "28-49",
 NOTE = "Reprinted in {SIGSAM} Bulletin, ACM, Vol. 13, 1969, p. 28-49"}

@ARTICLE{PLC,
 AUTHOR="M. L. Griss and A. C. Hearn",
 TITLE = "A Portable {LISP} Compiler",
 JOURNAL=SPE,
 MONTH = "June",
 YEAR=1981, VOLUME=11, PAGES="541-605",
 ANNOTE="Also as UUCS-79-113, and UCP-76"}

@MANUAL{CDC-LISP,
  KEY = "CDC",
  TITLE = "{LISP} Reference Manual, CDC-6000",
  AUTHOR = "Computation Center",
  ORGANIZATION= "The University of Texas at Austin"}
 
@MANUAL{LISP/360,
  KEY = "LISP/360",
  TITLE = "{LISP/360} Reference Manual",
  AUTHOR = "Stanford Center for Information Processing",
  ORGANIZATION = "Stanford University"}
 
@BOOK{LISP1.5,
  AUTHOR = "John McCarthy and Paul W. Abrahams and Daniel J. Edwards and
            Timothy P. Hart and  Michael I. Levin",
  TITLE = "{LISP} 1.5 Programmers Manual",
  ORGANIZATION = "The Computation Center and Research Laboratory of
                  Electronics, Massachusettes Institute of Technology",
  PUBLISHER = "The {M.I.T.} Press",
  ADDRESS = "Cambridge, Massachusettes", YEAR = 1965}
 
@MANUAL{MACLISP,
  KEY = "MACLISP",
  TITLE = "{MACLISP} Reference Manual",
  MONTH = "March", YEAR = 1976}

@MANUAL{LISPF1,
  AUTHOR = "Mats Nordstrom and Erik Sandewall and Diz Breslow",
  TITLE = "{LISP F1}: A {FORTRAN} Implementation of {LISP} 1.5",
  ORGANIZATION = "Uppsala University, Department of Computer Sciences"}
 
@MANUAL{LISP1.6,
  AUTHOR = "Lynn H. Quam and Whitfield Diffie",
  TITLE = "Stanford {LISP} 1.6 Manual",
  ORGANIZATION = "Stanford Artificial Intelligence Laboratory",
  EDITION ="Operating Note 28.7"}
 
@TECHREPORT{REDUCE3.3,
  AUTHOR = "A. C. Hearn",
  TITLE = "{REDUCE} User's Manual: Version 3.3",
  INSTITUTION = "{RAND}",
  TYPE = "Publication", NUMBER = "CP78 (Rev 1/88)", YEAR = 1988}

@MANUAL{Interlisp,
  AUTHOR = "Warren Teitelman",
  TITLE = "{INTERLISP} Reference Manual",
  ORGANIZATION = "{XEROX}",
  ADDRESS = "Palo Alto Research Centers, 3333 Coyote Road, Palo Alto,
California 94304",
  YEAR = 1978}

Added r34.1/doc/sl.tex version [1b7e99234c].













































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
\documentstyle[11pt,reduce]{article}
\title{The Standard Lisp Report}
\date{}
\author{Jed Marti \\ A. C. Hearn \\ M. L. Griss \\ C. Griss}

%%% Function/method definition.
%%% de{fname}{arglist}{type}{text}          For short arg lists.
%%% DE{fname}{arglist}{type}{text}          For long arg lists.
\newlength{\argwidth}                  % Width of argument box.
\setlength{\argwidth}{4in}
\newlength{\dewidth}
\setlength{\dewidth}{4.5in}             % Width of text box.

\newcommand{\de}[4]
{\vspace{.25in} \noindent
\begin{minipage}[t]{\textwidth} \index{#1} {\f{#1}}{#2}\hfill{\em #3} \\
\hspace*{.25in}\begin{minipage}[t]{\dewidth} #4 \end{minipage}
\end{minipage} }

%%% Global/fluid variable description.
%%% variable{name}{initial value}{type}{text}
\newcommand{\variable}[4]
{\vspace{.25in} \noindent
\begin{minipage}[t]{\textwidth} \index{#1 (#3)} {\bf #1} = #2 \hfill {\em #3}
 \\
\hspace*{.25in} \ \begin{minipage}[t]{\dewidth} #4 \end{minipage}
\end{minipage}}

%%% Command to display an error or warning message in teletype format. Also
%%% leaves blank vertical space around it.
\newcommand{\errormessage}[1]
{\vspace{.1in} \noindent {\tt #1} \\ \vspace{.1in}}


%%% \p is a parameter name (or argument). Just do this as bf.
\newcommand{\p}[1] {{\bf #1}}
%%% \ty is a type - do as italics.
\newcommand{\ty}[1] {{\em #1}}
\begin{document}
\maketitle

\section{Introduction}
Although the programming language LISP was first formulated in
1960~\cite{LISP1.5}, a widely accepted standard has never appeared. As
a result, various dialects of LISP were
produced~\cite{CDC-LISP,LISP/360,MACLISP,Interlisp,LISPF1,LISP1.6} in
some cases several on the same machine! Consequently, a user often
faces considerable difficulty in moving programs from one system to
another. In addition, it is difficult to write and use programs which
depend on the structure of the source code such as translators,
editors and cross-reference programs.

In 1969, a model for such a standard was produced~\cite{Hearn:69} as
part of a general effort to make a large LISP based algebraic
manipulation program, REDUCE~\cite{REDUCE3.3}, as portable as
possible.  The goal of this work was to define a uniform subset of
LISP 1.5 and its variants so that programs written in this subset
could run on any reasonable LISP system.

In the intervening years, two deficiencies in the approach taken in
Ref.~\cite{Hearn:69} have emerged. First in order to be as general as
possible, the specific semantics and values of several key functions
were left undefined. Consequently, programs built on this subset could
not make any assumptions about the form of the values of such
functions. The second deficiency related to the proposed method of
implementation of this language. The model considered in effect two
versions of LISP on any given machine, namely Standard LISP and the
LISP of the host machine (which we shall refer to as Target LISP).
This meant that if any definition was stored in interpretive form, it
would vary from implementation to implementation, and consequently one
could not write programs in Standard LISP which needed to assume any
knowledge about the structure of such forms. This deficiency became
apparent during recent work on the development of a portable compiler
for LISP~\cite{PLC}. Clearly a compiler has to know precisely the
structure of its source code; we concluded that the appropriate source
was Standard LISP and not Target LISP.

With these thoughts in mind we decided to attempt again a definition
of Standard LISP. However, our approach this time is more aggressive.
In this document we define a standard for a reasonably large subset of
LISP with as precise as possible a statement about the semantics of
each function. Secondly, we now require that the target machine
interpreter be modified or written to support this standard, rather
than mapping Standard LISP onto Target LISP as previously.

We have spent countless hours in discussion over many of the
definitions given in this report. We have also drawn on the help and
advice of a lot of friends whose names are given in the
Acknowledgements. Wherever possible, we have used the definition of a
function as given in the LISP 1.5 Programmer's Manual~\cite{LISP1.5}
and have only deviated where we felt it desirable in the light of LISP
programming experience since that time. In particular, we have given
considerable thought to the question of variable bindings and the
definition of the evaluator functions EVAL and APPLY. We have also
abandoned the previous definition of LISP arrays in favor of the more
accepted idea of a vector which most modern LISP systems support.
These are the places where we have strayed furthest from the
conventional definitions, but we feel that the consistency which
results from our approach is worth the redefinition.

We have avoided entirely in this report problems which arise from
environment passing, such as those represented by the FUNARG problem.
We do not necessarily exclude these considerations from our standard,
but in this report have decided to avoid the controversy which they
create. The semantic differences between compiled and interpreted
functions is the topic of another paper~\cite{PLC}. Only functions
which affect the compiler in a general way make reference to it.

This document is not intended as an introduction to LISP rather it is
assumed that the reader is already familiar with some version.  The
document is thus intended as an arbiter of the syntax and semantics of
Standard LISP. However, since it is not intended as an implementation
description, we deliberately leave unspecified many of the details on
which an actual implementation depends. For example, while we assume
the existence of a symbol table for atoms (the "object list" in LISP
terminology), we do not specify its structure, since conventional LISP
programming does not require this information. Our ultimate goal,
however, is to remedy this by defining an interpreter for Standard
LISP which is sufficiently complete that its implementation on any
given computer will be straightforward and precise. At that time, we
shall produce an implementation level specification for Standard LISP
which will extend the description of the primitive functions defined
herein by introducing a new set of lower level primitive functions in
which the structure of the symbol table, heap and so on may be
defined.

The plan of this chapter is as follows. In Section~\ref{dtypes} we
describe the various data types used in Standard LISP. In
Section~\ref{slfns}, a description of all Standard LISP functions is
presented, organized by type. These functions are defined in an RLISP
syntax which is easier to read than LISP S-expressions.
Section~\ref{slglobals} describes global variables which control the
operation of Standard LISP.


\section{Preliminaries}
\label{dtypes}
\subsection{Primitive Data Types}
\label{pdat}
\begin{description}
\item[integer] Integers are also called "fixed" numbers. The magnitude of
an integer is unrestricted. Integers in the LISP input stream are
\index{integer ! input} \index{integer ! magnitude}
recognized by the grammar:

\begin{tabbing}
\s{digit} ::= 0$\mid$1$\mid$2$\mid$3$\mid$4$\mid$5$\mid$6$\mid$7$\mid$8$\mid$9
\\
\s{unsigned-integer} ::= \s{digit}$\mid$\s{unsigned-integer}\s{digit} \\
\s{integer} ::= \= \s{unsigned-integer} $\mid$ \\
\> +\s{unsigned-integer} $\mid$ \\
\> ---\s{unsigned-integer}
\end{tabbing}

\item[floating] - Any floating point number. The precision of floating point
\index{floating ! input}
numbers is determined solely by the implementation. In BNF floating
point numbers are recognized by the grammar:

\begin{tabbing}
\s{base} ::=  \= \s{unsigned-integer}.$\mid$.\s{unsigned-integer}$\mid$ \\
\> \s{unsigned-integer}.\s{unsigned-integer} \\
\> \s{unsigned-floating} ::= \s{base}$\mid$ \\
\> \s{base}E\s{unsigned-integer}$\mid$ \\
\> \s{base}E-\s{unsigned-integer}$\mid$ \\
\> \s{base}E+\s{unsigned-integer} \\
\s{floating} ::= \= \s{unsigned-floating}$\mid$ \\
\> +\s{unsigned-floating}$\mid$-\s{unsigned-floating}
\end{tabbing}

\item[id] An identifier is a string of characters which may have the
\index{id ! input} \index{identifier (see id)}
following items associated with it.

\begin{description}
\item[print name] \index{print name} The characters of the identifier.

\item[flags] An identifier may be tagged with a flag. Access is by the
FLAG, REMFLAG, and FLAGP functions defined in section~\ref{plist} on
page~\pageref{plist}. \index{FLAG} \index{REMFLAG} \index{FLAGP}

\item[properties] \index{properties} An identifier may have an
indicator-value pair associated with it. Access is by the PUT, GET,
and REMPROP functions defined in section~\ref{plist} on
page~\pageref{plist}.
\index{PUT} \index{GET} \index{REMPROP}

\item[values/functions] An identifier may have a value associated with
\index{values} \index{functions} it. Access to values is by SET and SETQ
defined in \index{SET} \index{SETQ} section~\ref{varsandbinds} on
page~\pageref{varsandbinds}. The method by which the value is attached
to the identifier is known as the binding type, being one of LOCAL,
GLOBAL, or FLUID. Access to the binding type is by the GLOBAL,
GLOBALP, FLUID, FLUIDP, and UNFLUID functions.
\index{GLOBAL} \index{GLOBALP} \index{FLUID} \index{FUIDP} \index{UNFLUID}

An identifier may have a function or macro associated with it. Access
is by the PUTD, GETD, and REMD functions (see ``Function Definition'',
section~\ref{fdef}, on page~\pageref{fdef}). \index{PUTD} \index{GETD}
\index{REMD} An identifier may not have both a function and a value
associated with it.

\item[OBLIST entry] \index{OBLIST entry} An identifier may be entered and
removed from a structure called the OBLIST. Its presence on the OBLIST
does not directly affect the other properties. Access to the OBLIST is
by the INTERN, REMOB, and READ functions. \index{INTERN} \index{REMOB}
\index{READ}
\end{description}

The maximum length of a Standard LISP identifier is 24 characters
\index{id ! maximum length}
(excluding occurrences of the escape character !) but an
\index{id ! escape character}
implementation may allow more. Special characters (digits in the first
position and punctuation) must be prefixed with an escape character,
an ! in Standard LISP. In BNF identifiers are recognized by the
grammar:


\begin{tabbing}
\s{special-character} ::= !\s{any-character} \\
\s{alphabetic} ::= \\
\hspace*{.25in} \= A$\mid$B$\mid$C$\mid$D$\mid$E$\mid$F$\mid$G$\mid$H$
\mid$I$\mid$J$\mid$K$\mid$L$\mid$M$\mid$N$\mid$O$\mid$P$\mid$Q$\mid$R$
\mid$S$\mid$T$\mid$U$\mid$V$\mid$W$\mid$X$\mid$Y$\mid$Z$\mid$ \\
\> a$\mid$b$\mid$c$\mid$d$\mid$e$\mid$f$\mid$g$\mid$h$\mid$i$\mid$j$
\mid$k$\mid$l$\mid$m$\mid$n$\mid$o$\mid$p$\mid$q$\mid$r$\mid$s$\mid$t$
\mid$u$\mid$v$\mid$w$\mid$x$\mid$y$\mid$z \\
\s{lead-character} ::= \s{special-character}$\mid$\s{alphabetic} \\
\s{regular-character} ::= \s{lead-character}$\mid$\s{digit} \\
\s{last-part} ::= \= \s{regular-character} $\mid$ \\
\> \s{last-part}\s{regular-character} \\
\s{id} ::= \s{lead-character}$\mid$\s{lead-character}\s{last-part}
\end{tabbing}

Note: Using lower case letters in identifiers may cause portability
problems. Lower case letters are automatically converted to upper case
when the !*RAISE flag is T. \index{*RAISE (global)}


\item[string] \index{string} A set of characters enclosed in double quotes as
in "THIS IS A STRING". A quote is included by doubling it as in "HE
SAID, ""LISP""". The maximum size of strings is 80 characters but an
implementation may allow more. Strings are not part of the OBLIST and
are considered constants like numbers, vectors, and function-pointers.

\item[dotted-pair] A primitive structure which has a left and right part.
\index{dotted-pair} \index{dot-notation}
A notation called {\em dot-notation} is used for dotted pairs and
takes the form:

\begin{tabbing}
(\s{left-part} . \s{right-part})
\end{tabbing}

The \s{left-part} is known as the CAR portion and the \s{right-part}
as the CDR portion. The left and right parts may be of any type.
Spaces are used to resolve ambiguity with floating point numbers.


\item[vector] \index{vector} A primitive uniform structure in which
an integer index is used to access random values in the structure. The
individual elements of a vector may be of any type. Access to vectors
is restricted to functions defined in ``Vectors''
section~\ref{vectors} on page~\pageref{vectors}. A notation for
vectors, {\em vector-notation}, has the elements of a vector
surrounded
\index{vector-notation}
by square brackets\footnote{Vector elements are not separated by
commas as in the published version of this document.}


\begin{tabbing}
\s{elements} ::= \s{any}$\mid$\s{any} \s{elements} \\
\s{vector} ::= [\s{elements}]
\end{tabbing}

\item[function-pointer] \index{function-pointer} An implementation may have
functions which deal with specific data types other than those listed.
The use of these entities is to be avoided with the exception of a
restricted use of the function-pointer, an access method to compiled
EXPRs and FEXPRs. A particular function-pointer must remain valid
\index{EXPR} \index{FEXPR}
throughout execution. Systems which change the location of a function
must use either an indirect reference or change all occurrences of the
associated value. There are two classes of use of function-pointers,
those which are supported by Standard LISP but are not well defined,
and those which are well defined.

\begin{description}
\item[Not well defined] Function pointers may be displayed by the print
functions or expanded by EXPLODE. \index{EXPLODE} The value appears in
the convention of the implementation site. The value is not defined in
Standard LISP. Function pointers may be created by COMPRESS
\index{COMPRESS} in the format used for printing but the value used is
not defined in Standard LISP. Function pointers may be created by
functions which deal with compiled function loading. Again, the values
created are not well defined in Standard LISP.

\item[Well defined] The function pointer associated with an EXPR or
FEXPR may be retrieved by GETD \index{GETD} and is valid as long as
Standard LISP is in execution. Function pointers may be stored using
\index{PUTD} \index{PUT} \index{SETQ} PUTD, PUT, SETQ and the like or by
being bound to variables.  Function pointers may be checked for
equivalence by EQ. \index{EQ ! of function-pointers} The value may be
checked for being a function pointer by the CODEP function.
\index{CODEP}
\end{description}
\end{description}


\subsection{Classes of Primitive Data Types}
\label{pclasses}
The classes of primitive types are a notational convenience for
describing the properties of functions.


\begin{description}
\item[boolean] \index{boolean} The set of global variables \{T,NIL\},
or their respective values, \{T, NIL\}. \index{T (global)} \index{NIL
(global)}

\item[extra-boolean] \index{extra-boolean} Any value in the system.
Anything that is not NIL \index{NIL (global)} has the boolean
interpretation T. \index{T (global)}

\item[ftype] \index{ftype} The class of definable function types. The
set of ids \{EXPR, FEXPR, MACRO\}. \index{EXPR} \index{FEXPR}
\index{MACRO}

\item[number] \index{number} The set of \{integer, floating\}.

\item[constant] \index{constant} The set of \{integer, floating,
string, vector, function-pointer\}. Constants evaluate to themselves
(see the definition of EVAL in ``The Interpreter'',
section~\ref{interpreter} on page~\pageref{interpreter}). \index{EVAL
! of constants}


\item[any] \index{any} The set of \{integer, floating, string, id,
dotted-pair, vector, function-pointer\}. An S-expression is another
term for any. All Standard LISP entities have some value unless an
ERROR occurs during evaluation or the function causes transfer of
control (such as GO and RETURN).


\item[atom] \index{atom} The set \{any\}-\{dotted-pair\}.
\end{description}

\subsection{Structures}
\index{data structures} \index{structures}
Structures are entities created out of the primitive types by the use
of dotted-pairs. Lists are structures very commonly required as actual
parameters to functions. Where a list of homogeneous entities is
required by a function this class will be denoted by
\s{{\bf xxx}-list} where {\bf \em xxx} is the name of a class of primitives
or structures. Thus a list of ids is an {\em id-list}, a list of
integers an {\em integer-list} and so on. \index{id-list}
\index{integer-list}
\index{-list}

\begin{description}
\item[list] \index{list} A list is recursively defined as NIL or the
\index{list-notation} \index{NIL (global)}
dotted-pair (any~.~list). A special notation called {\em
list-notation} is used to represent lists. List-notation eliminates
extra parentheses and dots. The list (a . (b . (c . NIL))) in list
notation is (a b c).
\index{dot-notation}
List-notation and dot-notation may be mixed as in (a b . c) or (a (b .
c) d) which are (a . (b . c)) and (a . ((b . c) . (d .  NIL))). In BNF
lists are recognized by the grammar:

\begin{tabbing}
\s{left-part} ::= ( $\mid$ \s{left-part} \s{any} \\
\s{list} ::= \s{left-part}) $\mid$ \s{left-part} . \s{any})
\end{tabbing}

Note: () is an alternate input representation of NIL. \index{()}


\item[alist] \index{alist} An association list; each element of the list
is a dotted-pair, the CAR part being a key associated with the value
in the CDR part. \index{association list}


\item[cond-form] \index{cond-form} A cond-form is a list of 2 element lists
of the form:

(\p{ANTECEDENT}:{\em any} \p{CONSEQUENT}:{\em any})

The first element will henceforth be known as the antecedent and
\index{antecedent (cond-form)} \index{consequent (cond-form)}
the second as the consequent. The antecedent must have a value.  The
consequent may have a value or an occurrence of GO or RETURN
\index{GO} \index{RETURN}
as described in the ``Program Feature Functions'', section~\ref{prog}
on page~\pageref{prog}.


\item[lambda] \index{LAMBDA} A LAMBDA expression which must have the form
(in list notation): (LAMBDA parameters body). ``parameters'' is a list
of formal parameters for ``body'' an S-expression to be evaluated. The
semantics of the evaluation are defined with the EVAL function (see
``The Interpreter'', section~\ref{interpreter} on \index{EVAL ! lambda
expressions} page~\pageref{interpreter}). \index{lambda expression}

\item[function] \index{function} A LAMBDA expression or a function-pointer
to a function. A function is always evaluated as an EVAL, SPREAD form.
\index{EVAL ! function}
\end{description} 


\subsection{Function Descriptions}

Each function is provided with a prototypical header line. Each formal
parameter is given a name and suffixed with its allowed type.  Lower
case, italic tokens are names of classes and upper case, bold face,
tokens are parameter names referred to in the definition. The type of
the value returned by the function (if any) is suffixed to the
parameter list.  If it is not commonly used the parameter type may be
a specific set enclosed in brackets \{\ldots\}. \index{\{\ldots\} ! as
syntax} For example:


\vspace{.1in}
\noindent \f{PUTD}(\p{FNAME}:\ty{id}, \p{TYPE}:\ty{ftype},
\p{BODY}:\{\ty{lambda, function-pointer}\}):\ty{id}
\vspace{.1in}

PUTD is a function with three parameters. The parameter FNAME is an id
to be the name of the function being defined. TYPE is the type of the
function being defined and BODY is a lambda expression or a
function-pointer. PUTD returns the name of the function being defined.



Functions which accept formal parameter lists of arbitrary length have
the type class and parameter enclosed in square brackets indicating
that zero or more occurrences of that argument are permitted.
\index{[\ldots] syntax} For example:

\vspace{.1in}
\noindent \f{AND}([\p{U}:\ty{any}]):\ty{extra-boolean}
\vspace{.1in}

AND is a function which accepts zero or more arguments which may be of
any type.

\subsection{Function Types}

EVAL type functions are those which are invoked with evaluated
\index{EVAL ! function type}
arguments. NOEVAL functions are invoked with unevaluated arguments.
\index{NOEVAL ! function type}
SPREAD type functions have their arguments passed in one-to-one
\index{SPREAD ! function type}
correspondence with their formal parameters. NOSPREAD functions
\index{NOSPREAD ! function type}
receive their arguments as a single list. EVAL, SPREAD functions are
\index{FEXPR}
associated with EXPRs and NO\-EVAL, NO\-SPREAD functions with FEXPRs.
EVAL, NO\-SPREAD and NOEVAL, SPREAD functions can be simulated using
NOEVAL, NO\-SPREAD functions or MACROs. \index{MACRO}

EVAL, SPREAD type functions may have a maximum of 15 parameters.
\index{formal parameter limit}
There is no limit on the number of parameters a NOEVAL, NOSPREAD
function or MACRO may have.

In the context of the description of an EVAL, SPREAD function, then we
speak of the formal parameters we mean their actual values.  However,
in a NOEVAL, NOSPREAD function it is the unevaluated actual
parameters.

A third function type, the MACRO, implements functions which
\index{MACRO}
create S-expressions based on actual parameters. When a macro
invocation is encountered, the body of the macro, a lambda expression,
is invoked as a NOEVAL, NOSPREAD function with the macro's invocation
bound as a list to the macros single formal parameter. When the macro
has been evaluated the resulting S-expression is reevaluated. The
description of the EVAL and EXPAND
\index{EVAL ! MACRO functions}
functions provide precise details.


\subsection{Error and Warning Messages}
\index{error messages}
Many functions detect errors. The description of such functions will
include these error conditions and suggested formats for display
\index{ERROR}
of the generated error messages. A call on the ERROR function is
implied but the error number is not specified by Standard LISP. In
some cases a warning message is sufficient. To distinguish between
\index{warning messages} \index{***** (error message)}
\index{*** (warning message)}
errors and warnings, errors are prefixed with five asterisks and
warnings with only three.

Primitive functions check arguments that must be of a certain
primitive type for being of that type and display an error message if
the argument is not correct. The type mismatch error always takes the
form:
\index{error ! type mismatch error}

\errormessage{***** PARAMETER not TYPE for FN}

Here PARAMETER is the unacceptable actual parameter, TYPE is the type
that PARAMETER was supposed to be. FN is the name of the function that
detected the error.

\subsection{Comments}

\index{comments} \index{\%}
The character \% signals the start of a comment, text to be ignored
during parsing.  A comment is terminated by the end of the line it
\index{READCH} \index{READ}
is on.  The function READCH must be able to read a comment one
character at a time.  Comments are transparent to the function READ.
\% may occur as a character in identifiers by preceding it with the
\index{escape character}
escape character !.


\section{Functions}
\label{slfns}

\subsection{Elementary Predicates}
\label{elpreds}
\index{predicate !}
\index{T (global)} \index{NIL (global)}
Functions in this section return T when the condition defined is met
and NIL when it is not. Defined are type checking functions and
elementary comparisons.


\de{ATOM}{(\p{U}:\ty{any}):{\ty boolean}}{eval, spread}
{Returns T if U is not a pair.

{\tt \begin{tabbing} EXPR PROCEDURE ATOM(U); \\
\hspace*{1em} NULL PAIRP U;
\end{tabbing}}}


\de{CODEP}{(\p{U}:\f{any}):{\ty boolean}}{eval, spread}
{Returns T if U is a function-pointer.}


\de{CONSTANTP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is a constant (a number, string, function-pointer, or
vector).

{\tt \begin{tabbing} EXPR PROCEDURE CONSTANTP(U); \\
\hspace*{1em} NULL OR(PAIRP U, IDP U);
\end{tabbing}}
}



\de{EQ}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U points to the same object as V. EQ is \underline{not}
a reliable comparison between numeric arguments. }


\de{EQN}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U and V are EQ or if U and V are numbers and have the
same value and type. }


\de{EQUAL}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U and V are the same. Dotted-pairs are compared
recursively to the bottom levels of their trees. Vectors must have
identical dimensions and EQUAL values in all positions. Strings must
\index{EQ ! of function-pointers} \index{EQN} have identical characters.
Function pointers must have EQ values. Other atoms must be EQN equal. }


\de{FIXP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is an integer (a fixed number).}


\de{FLOATP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is a floating point number. }


\de{IDP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is an id.}


\de{MINUSP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is a number and less than 0.  If U is not a number or
is a positive number, NIL is returned.

{\tt \begin{tabbing} EXPR PROCEDURE MINUSP(U); \\
\hspace*{1em} IF NUMBERP U THEN LESSP(U, 0) ELSE NIL;
\end{tabbing}}}


\de{NULL}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is NIL.

{\tt \begin{tabbing} EXPR PROCEDURE NULL(U); \\
\hspace*{1em} U EQ NIL;
\end{tabbing}}}


\de{NUMBERP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is a number (integer or floating).

{\tt \begin{tabbing} EXPR PROCEDURE NUMBERP(U); \\
\hspace*{1em} IF OR(FIXP U, FLOATP U) THEN T ELSE NIL;
\end{tabbing}}}


\de{ONEP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread.}
{Returns T if U is a number and has the value 1 or 1.0.  Returns NIL
otherwise. \footnote{The definition in the published report is
incorrect as it does not return T for \p{U} of 1.0.}

{\tt \begin{tabbing} EXPR PROCEDURE ONEP(U); \\
\hspace*{1em} OR(EQN(U, 1), EQN(U, 1.0));
\end{tabbing}}}


\de{PAIRP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is a dotted-pair. }


\de{STRINGP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is a string. }


\de{VECTORP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is a vector. }


\de{ZEROP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread.}
{Returns T if U is a number and has the value 0 or 0.0.  Returns NIL
otherwise.\footnote{The definition in the published report is
incorrect as it does not return T for \p{U} of 0.0.}

{\tt \begin{tabbing} EXPR PROCEDURE ZEROP(U); \\
\hspace*{1em} OR(EQN(U, 0), EQN(U, 0.0));
\end{tabbing}}}


\subsection{Functions on Dotted-Pairs}

\index{dotted-pair}
The following are elementary functions on dotted-pairs. All functions
in this section which require dotted-pairs as parameters detect a type
mismatch error if the actual parameter is not a dotted-pair.



\de{CAR}{(\p{U}:\ty{dotted-pair}):\ty{any}}{eval, spread}
{CAR(CONS(a, b)) $\rightarrow$ a. The left part of U is returned. The
type
\index{CONS}
mismatch error occurs if U is not a dotted-pair.}


\de{CDR}{(\p{U}:\ty{dotted-pair}):\ty{any}}{eval, spread}
{CDR(CONS(a, b)) $\rightarrow$ b. The right part of U is returned. The
type
\index{CONS}
mismatch error occurs if U is not a dotted-pair.}


The composites of CAR and CDR are supported up to 4 levels, namely:
\index{CAR ! composite forms} \index{CDR ! composite forms}

\hspace*{1in}\begin{tabular}{l l l}
CAAAAR & CAAAR & CAAR \\ CAAADR & CAADR & CADR \\ CAADAR & CADAR &
CDAR \\ CAADDR & CADDR & CDDR \\ CADAAR & CDAAR & \\ CADADR & CDADR &
\\ CADDAR & CDDAR & \\ CADDDR & CDDDR & \\ CDAAAR & & \\ CDAADR & & \\
CDADAR & & \\ CDADDR & & \\ CDDAAR & & \\ CDDADR & & \\ CDDDAR & & \\
CDDDDR & &
\end{tabular}

\de{CONS}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{dotted-pair}}{eval, spread}
{Returns a dotted-pair which is not EQ to anything and has U as its
\index{EQ ! of dotted-pairs} \index{dotted-pair}
CAR part and V as its CDR part.}


\de{LIST}{([\p{U}:\ty{any}]):\ty{list}}{noeval, nospread, or macro}
{A list of the evaluation of each element of U is returned. The order
of evaluation need not be first to last as the following definition
implies.\footnote{The published report's definition implies a specific
ordering.}

{\tt \begin{tabbing} FEXPR PROCEDURE LIST(U); \\
\hspace*{1em} EVLIS U;
\end{tabbing}}}


\de{RPLACA}{(\p{U}:\ty{dotted-pair},
\p{V}:\ty{any}):\ty{dotted-pair}}{eval, spread}
{The CAR portion of the dotted-pair U is replaced by V. If dotted-pair
U is (a . b) then (V . b) is returned. The type mismatch error occurs
if U is not a dotted-pair. }


\de{RPLACD}{(\p{U}:\ty{dotted-pair},
\p{V}:\ty{any}):\ty{dotted-pair}}{eval, spread}
{The CDR portion of the dotted-pair U is replaced by V. If dotted-pair
U is (a . b) then (a . V) is returned. The type mismatch error occurs
if U is not a dotted-pair.}


\subsection{Identifiers}
\label{identifiers}
The following functions deal with identifiers and the OBLIST,
\index{OBLIST}
the structure of which is not defined. The function of the OBLIST is
to provide a symbol table for identifiers created during input.
Identifiers created by READ which have the same characters will
\index{READ} \index{EQ ! of identifiers}
therefore refer to the same object (see the EQ function in
``Elementary Predicates'', section~\ref{elpreds} on
page~\pageref{elpreds}).



\de{COMPRESS}{(\p{U}:\ty{id-list}):\{\ty{atom}-\ty{vector}\}}{eval, spread}
{U is a list of single character identifiers which is built into a
Standard LISP entity and returned. Recognized are numbers, strings,
and identifiers with the escape character prefixing special
characters. The formats of these items appear in ``Primitive Data
Types'' section~\ref{pdat} on page~\pageref{pdat}. Identifiers are not
interned on the OBLIST. Function pointers may be compressed but this
is an undefined use. If an entity cannot be parsed out of U or
characters are left over after parsing an error occurs:

\errormessage{***** Poorly formed atom in COMPRESS}
}


\de{EXPLODE}{(\p{U}:\{\ty{atom}\}-\{\ty{vector}\}):\ty{id-list}}{eval, spread}
{Returned is a list of interned characters representing the characters
to print of the value of U. The primitive data types have these
formats:

\begin{description}
\item[integer] \index{integer ! output} Leading zeroes are suppressed and
a minus sign prefixes the digits if the integer is negative.

\item[floating] \index{floating ! output} The value appears in the format
[-]0.nn...nnE[-]mm if the magnitude of the number is too large or
small to display in [-]nnnn.nnnn format. The crossover point is
determined by the implementation.

\item[id] \index{id ! output} The characters of the print name of the
identifier are produced with special characters prefixed with the
escape character.

\item[string] \index{string ! output} The characters of the string are
produced surrounded by double quotes "\ldots".

\item[function-pointer] \index{function-pointer ! output} The value of the
function-pointer is created as a list of characters conforming to the
conventions of the system site.
\end{description}

The type mismatch error occurs if U is not a number, identifier,
string, or function-pointer. }


\de{GENSYM}{():\ty{identifier}}{eval, spread}
{Creates an identifier which is not interned on the OBLIST and
consequently not EQ to anything else. \index{OBLIST entry} \index{EQ !
of GENSYMs}}


\de{INTERN}{(\p{U}:\{\ty{id,string}\}):\ty{id}}{eval, spread}
{INTERN searches the OBLIST for an identifier with the same print name
\index{OBLIST entry}
as U and returns the identifier on the OBLIST if a match is found.
Any properties and global values associated with U may be lost. If U
does not match any entry, a new one is created and returned. If U has
more than the maximum number of characters permitted by the
implementation (the minimum number is 24) an error occurs:
\index{id ! minimum size}

\errormessage{***** Too many characters to INTERN}
}


\de{REMOB}{(\p{U}:\ty{id}):\ty{id}}{eval, spread}
{If U is present on the OBLIST it is removed. This does not affect U
\index{OBLIST entry}
having properties, flags, functions and the like. U is returned.}


\subsection{Property List Functions}
\label{plist}
\index{property list}
With each id in the system is a ``property list'', a set of entities
which are associated with the id for fast access. These entities are
called ``flags'' if their use gives the id a single valued
\index{flags}
property, and ``properties'' if the id is to have a multivalued
\index{properties}
attribute: an indicator with a property.

Flags and indicators may clash, consequently care should be taken to
avoid this occurrence. Flagging X with an id which already is an
indicator for X may result in that indicator and associated property
being lost. Likewise, adding an indicator which is the same id as a
flag may result in the flag being destroyed.



\de{FLAG}{(\p{U}:\ty{id-list}, \p{V}:\ty{id}):\ty{NIL}}{eval, spread}
{U is a list of ids which are flagged with V. The effect of FLAG is
that FLAGP will have the value T for those ids of U which were
flagged. Both V and all the elements of U must be identifiers or the
type mismatch error occurs.}


\de{FLAGP}{(\p{U}:\ty{any}, \p{V}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U has been previously flagged with V, else NIL. Returns
NIL if either U or V is not an id.}


\de{GET}{(\p{U}:\ty{any}, \p{IND}:\ty{any}):\ty{any}}{eval, spread}
{Returns the property associated with indicator IND from the property
list of U. If U does not have indicator IND, NIL is returned. GET
cannot be used to access functions (use GETD instead).
\index{GET ! not for functions}}


\de{PUT}{(\p{U}:\ty{id}, \p{IND}:\ty{id},
\p{PROP}:\ty{any}):\ty{any}}{eval, spread}
{The indicator IND with the property PROP is placed on the property
list of the id U. If the action of PUT occurs, the value of PROP is
returned. If either of U and IND are not ids the type mismatch error
will occur and no property will be placed. PUT cannot be used to
define functions (use PUTD instead).
\index{PUT ! not for functions}}


\de{REMFLAG}{(\p{U}:\ty{any-list}, \p{V}:\ty{id}):\ty{NIL}}{eval, spread}
{Removes the flag V from the property list of each member of the list
U. Both V and all the elements of U must be ids or the type mismatch
error will occur.}


\de{REMPROP}{(\p{U}:\ty{any}, \p{IND}:\ty{any}):\ty{any}}{eval, spread}
{Removes the property with indicator IND from the property list of U.
Returns the removed property or NIL if there was no such indicator.}



\subsection{Function Definition}
\label{fdef}
Functions in Standard LISP are global entities. To avoid
function-variable naming clashes no variable may have the same name as
a function. \index{function ! as GLOBAL}


\de{DE}{(\p{FNAME}:\ty{id}, \p{PARAMS}:\ty{id-list},
\p{FN}:\ty{any}):\ty{id}}{noeval, nospread}
{The function FN with the formal parameter list PARAMS is added to the
set of defined functions with the name FNAME. Any previous definitions
of the function are lost. The function created is of type
\index{*COMP (fluid)} 
EXPR.  If the !*COMP variable is non-NIL, the EXPR is first
\index{EXPR}
compiled. The name of the defined function is returned.

{\tt \begin{tabbing} FEXPR PROCEDURE DE(U); \\
\hspace*{1em} PUTD(CAR U, 'EXPR, LIST('LAMBDA, CADR U, CADDR U));
\end{tabbing}}}


\de{DF}{(\p{FNAME}:\ty{id}, \p{PARAM}:\ty{id-list},
\p{FN}:\ty{any}):\ty{id}}{noeval, nospread}
{The function FN with formal parameter PARAM is added to the set of
defined functions with the name FNAME. Any previous definitions of the
function are lost. The function created is of type FEXPR.
\index{*COMP variable} \index{FEXPR}
If the !*COMP variable is T the FEXPR is first compiled. The name of
the defined function is returned.

{\tt \begin{tabbing} FEXPR PROCEDURE DF(U); \\
\hspace*{1em} PUTD(CAR U, 'FEXPR, LIST('LAMBDA, CADR U, CADDR U)); \\
\end{tabbing} }}


\de{DM}{(\p{MNAME}:\ty{id}, \p{PARAM}:\ty{id-list},
\p{FN}:\ty{any}):\ty{id}}{noeval, nospread}
{The macro FN with the formal parameter PARAM is added to the set of
defined functions with the name MNAME. Any previous definitions of the
function are overwritten. The function created is of type MACRO.
\index{MACRO}
The name of the macro is returned.

{\tt \begin{tabbing} FEXPR PROCEDURE DM(U); \\
\hspace*{1em} PUTD(CAR U, 'MACRO, LIST('LAMBDA, CADR U, CADDR U));
\end{tabbing} }
}


\de{GETD}{(\p{FNAME}:\ty{any}):\{NIL, \ty{dotted-pair}\}}{eval, spread}
{If FNAME is not the name of a defined function, NIL is returned. If
FNAME is a defined function then the dotted-pair

\vspace{.15in}
(\p{TYPE}:\ty{ftype} . \p{DEF}:\{\ty{function-pointer, lambda}\})
\vspace{.15in}

is returned.}


\de{PUTD}{(\p{FNAME}:\ty{id}, \p{TYPE}:\ty{ftype},
\p{BODY}:\ty{function}):\ty{id}}{eval, spread}
{Creates a function with name FNAME and definition BODY of type TYPE.
If PUTD succeeds the name of the defined function is returned. The
effect of PUTD is that GETD will return a dotted-pair with the
functions type and definition. Likewise the GLOBALP predicate will
\index{GLOBALP} \index{function ! as global}
return T when queried with the function name.

If the function FNAME has already been declared as a GLOBAL or FLUID
variable the error:

\errormessage{***** FNAME is a non-local variable}

occurs and the function will not be defined. If function FNAME already
exists a warning message will appear:

\errormessage{*** FNAME redefined}

The function defined by PUTD will be compiled before definition
\index{*COMP (fluid)} if the !*COMP global variable is non-NIL.}


\de{REMD}{(\p{FNAME}:\ty{id}):\{NIL, \ty{dotted-pair}\}}{eval, spread}
{Removes the function named FNAME from the set of defined functions.
Returns the (ftype . function) dotted-pair or NIL as does GETD. The
global/function attribute of FNAME is removed and the name may be used
subsequently as a variable.}



\subsection{Variables and Bindings}
\label{varsandbinds}
\index{variable scope} \index{scope}
A variable is a place holder for a Standard LISP entity which is said
to be bound to the variable. The scope of a variable is the range over
which the variable has a defined value. There are three different
binding mechanisms in Standard LISP.

\begin{description}
\item[Local Binding] \index{local binding} This type of binding occurs
\index{scope ! local}
only in compiled functions. Local variables occur as formal parameters
in lambda expressions and as PROG form variables. The binding occurs
when a lambda expression is evaluated or when a PROG form is executed.
The scope of a local variable is the body of the function in which it
is defined.

\item[Global Binding] \index{global binding} Only one binding of a
\index{scope ! global}
global variable exists at any time allowing direct access to the value
bound to the variable.  The scope of a global variable is universal.
Variables declared GLOBAL may not appear as parameters in lambda
expressions or as PROG form variables. A variable must be declared
GLOBAL prior to its use as a global variable since the default type
for undeclared variables is FLUID.


\item[Fluid Binding] \index{fluid binding}
\index{fluid binding ! as default} Fluid variables are global
in scope but may occur as \index{scope ! fluid} formal parameters or
PROG form variables. In interpreted functions all formal parameters
and PROG form variables are considered to have fluid binding until
changed to local binding by compilation.  When fluid variables are
used as parameters they are rebound in such a way that the previous
binding may be restored. All references to fluid variables are to the
currently active binding.
\end{description}


\de{FLUID}{(\p{IDLIST}:\ty{id-list}):\p{NIL}}{eval, spread}
{The ids in IDLIST are declared as FLUID type variables (ids not
previously declared are initialized to NIL). Variables in IDLIST
already declared FLUID are ignored. Changing a variable's type from
GLOBAL to FLUID is not permissible and results in the error:

\errormessage{***** ID cannot be changed to FLUID}
}

\de{FLUIDP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{If U has been declared FLUID (by declaration only) T is returned,
otherwise NIL is returned.}


\de{GLOBAL}{(\p{IDLIST}:\ty{id-list}):\p{NIL}}{eval, spread}
{The ids of IDLIST are declared global type variables. If an id has
not been declared previously it is initialized to NIL. Variables
already declared GLOBAL are ignored. Changing a variables type from
FLUID to GLOBAL is not permissible and results in the error:

\errormessage{***** ID cannot be changed to GLOBAL}
}


\de{GLOBALP}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{If U has been declared GLOBAL or is the name of a defined function, T
is returned, else NIL is returned.}


\de{SET}{(\p{EXP}:\ty{id}, \p{VALUE}:\ty{any}):\ty{any}}{eval, spread}
{EXP must be an identifier or a type mismatch error occurs. The effect
of SET is replacement of the item bound to the identifier by VALUE.
If the identifier is not a local variable or has not been declared
GLOBAL it is automatically declared FLUID with the resulting warning
message:

\errormessage{*** EXP declared FLUID}

EXP must not evaluate to T or NIL or an error occurs:
\index{T ! cannot be changed} \index{NIL ! cannot be changed}

\errormessage{***** Cannot change T or NIL}
}

\de{SETQ}{(\p{VARIABLE}:\ty{id}, \p{VALUE}:\ty{any}):\ty{any}}{noeval,
nospread}
{If VARIABLE is not local or GLOBAL it is by default declared FLUID
and the warning message:

\errormessage{*** VARIABLE declared FLUID}

appears. The value of the current binding of VARIABLE is replaced by
the value of VALUE. VARIABLE must not be T or NIL or an error occurs:
\index{T ! cannot be changed} \index{NIL ! cannot be changed}

\errormessage{***** Cannot change T or NIL}

{\tt \begin{tabbing} MACRO PROCEDURE SETQ(X); \\
\hspace*{1em} LIST('SET, LIST('QUOTE, CADR X), CADDR X);
\end{tabbing}}
}

\de{UNFLUID}{(\p{IDLIST}:\ty{id-list}):\ty{NIL}}{eval, spread}
{The variables in IDLIST that have been declared as FLUID variables
are no longer considered as fluid variables. Others are ignored. This
affects only compiled functions as free variables in interpreted
functions are automatically considered fluid~\cite{PLC}.
\index{scope ! fluid and compiled}}


\subsection{Program Feature Functions}
\label{prog}
These functions provide for explicit control sequencing, and the
definition of blocks altering the scope of local variables.


\de{GO}{(\p{LABEL}:\ty{id})}{noeval, nospread}
{GO alters the normal flow of control within a PROG function. The next
statement of a PROG function to be evaluated is immediately preceded
by LABEL. A GO may only appear in the following situations:


\begin{enumerate}
\item At the top level of a PROG referencing a label which also
appears at the top level of the same PROG.

\item As the consequent of a COND item of a COND appearing on the top
level of a PROG.
\index{GO ! in COND}
\index{RETURN ! in COND}
\item As the consequent of a COND item which appears as the
consequent of a COND item to any level.

\item As the last statement of a PROGN which appears at the top level
of a PROG or in a PROGN appearing in the consequent of a COND to any
level subject to the restrictions of 2 and 3.

\item As the last statement of a PROGN within a PROGN or as the
consequent of a COND in a PROGN to any level subject to the
restrictions of 2, 3 and 4.
\end{enumerate}

If LABEL does not appear at the top level of the PROG in which the GO
appears, an error occurs:

\errormessage{***** LABEL is not a known label}

If the GO has been placed in a position not defined by rules 1-5,
another error is detected:

\errormessage{***** Illegal use of GO to LABEL}
}

\de{PROG}{(\p{VARS}:\ty{id-list},
[\p{PROGRAM}:\{\ty{id, any}\}]):\ty{any}}{noeval, nospread}
{VARS is a list of ids which are considered fluid when the PROG is
interpreted and local when compiled (see ``Variables and Bindings'',
section~\ref{varsandbinds} on page~\pageref{varsandbinds}). The PROGs
variables are allocated space when the PROG form is invoked and are
deallocated when the PROG is exited. PROG variables are initialized to
\index{PROG ! variables}
NIL. The PROGRAM is a set of expressions to be evaluated in order of
their appearance in the PROG function.  Identifiers appearing in the
top level of the PROGRAM are labels which can be referenced by GO. The
value returned by the PROG function is determined by a RETURN function
\index{PROG ! default value}
or NIL if the PROG ``falls through''.}


\de{PROGN}{([\p{U}:\ty{any}]):\ty{any}}{noeval, nospread}
{U is a set of expressions which are executed sequentially. The value
returned is the value of the last expression.}


\de{PROG2}{(A:any, B:any)\ty{any}}{eval, spread}
{Returns the value of B.

{\tt \begin{tabbing} EXPR PROCEDURE PROG2(A, B);\\
\hspace*{1em} B;
\end{tabbing}}}


\de{RETURN}{(\p{U}:\ty{any})}{eval, spread}
{Within a PROG, RETURN terminates the evaluation of a PROG and returns
U as the value of the PROG. The restrictions on the placement of
RETURN are exactly those of GO. Improper placement of RETURN results
in the error:

\errormessage{***** Illegal use of RETURN}
}


\subsection{Error Handling}
\label{errors}

\de{ERROR}{(\p{NUMBER}:\ty{integer}, \p{MESSAGE}:\ty{any})}{eval, spread}
{NUMBER and MESSAGE are passed back to a surrounding ERRORSET (the
Standard LISP reader has an ERRORSET). MESSAGE is placed in the
\index{EMSG* (global)}
global variable EMSG!* and the error number becomes the value of the
surrounding ERRORSET. FLUID variables and local bindings are unbound
\index{fluid ! unbinding by ERROR}
to return to the environment of the ERRORSET. Global variables are not
affected by the process.}


\de{ERRORSET}{(\p{U}:\ty{any}, \p{MSGP}:\ty{boolean},
\p{TR}:\ty{boolean}):\ty{any}}{eval, spread}
{If an error occurs during the evaluation of U, the value of NUMBER
from the ERROR call is returned as the value of ERRORSET. In addition,
if the value of MSGP is non-NIL, the MESSAGE from the ERROR call is
displayed upon both the standard output device and the currently
selected output device unless the standard output device is not open.
The message appears prefixed with 5 asterisks. The MESSAGE
\index{***** (error message)}
list is displayed without top level parentheses. The MESSAGE from the
\index{EMSG* (global)}
ERROR call will be available in the global variable EMSG!*. The exact
format of error messages generated by Standard LISP functions
described in this document are not fixed and should not be relied upon
to be in any particular form. Likewise, error numbers generated by
Standard LISP functions are implementation dependent.

If no error occurs during the evaluation of U, the value of (LIST
(EVAL U)) is returned.

If an error has been signaled and the value of TR is non-NIL a
traceback sequence will be initiated on the selected output device.
The traceback will display information such as unbindings of FLUID
\index{fluid ! in traceback}
variables, argument lists and so on in an implementation dependent
format.}


\subsection{Vectors}
\label{vectors}
\index{vector}
Vectors are structured entities in which random elements may be
accessed with an integer index. A vector has a single dimension. Its
maximum size is determined by the implementation and available space.
A suggested input ``vector notation'' is defined in ``Classes of
Primitive Data Types'', section~\ref{pclasses} on
page~\pageref{pclasses} and output with EXPLODE, ``Identifiers''
section~\ref{identifiers} on page~\pageref{identifiers}.
\index{EXPLODE}


\de{GETV}{(\p{V}:\ty{vector}, \p{INDEX}:\ty{integer}):\ty{any}}{eval, spread}
{Returns the value stored at position INDEX of the vector V. The type
mismatch error may occur. An error occurs if the INDEX does not lie
within 0\ldots UPBV(V) inclusive:

\errormessage{***** INDEX subscript is out of range}
}


\de{MKVECT}{(\p{UPLIM}:\ty{integer}):\ty{vector}}{eval, spread}
{Defines and allocates space for a vector with UPLIM+1 elements
accessed as 0\ldots UPLIM. Each element is initialized to NIL. An
error will occur if UPLIM is $<$ 0 or there is not enough space for a
vector of this size:

\errormessage{***** A vector of size UPLIM cannot be allocated}
}


\de{PUTV}{(\p{V}:\ty{vector}, \p{INDEX}:\ty{integer},
\p{VALUE}:\ty{any}):\ty{any}}{eval, spread}
{Stores VALUE into the vector V at position INDEX. VALUE is returned.
The type mismatch error may occur. If INDEX does not lie in 0\ldots
UPBV(V) an error occurs:

\errormessage{***** INDEX subscript is out of range}
}


\de{UPBV}{(\p{U}:\ty{any}):{NIL,\ty{integer}}}{eval, spread}
{Returns the upper limit of U if U is a vector, or NIL if it is not.}


\subsection{Boolean Functions and Conditionals}


\de{AND}{([\p{U}:\ty{any}]):\ty{extra-boolean}}{noeval, nospread}
{AND evaluates each U until a value of NIL is found or the end of the
list is encountered. If a non-NIL value is the last value it is
returned, or NIL is returned.

{\tt \begin{tabbing} FEXPR PROCEDURE AND(U); \\ BEGIN \\
\hspace*{1em} IF NULL U THEN RETURN NIL; \\
LOOP: IF \= NULL CDR U THEN RETURN EVAL CAR U \\
\> ELSE IF NULL EVAL CAR U THEN RETURN NIL; \\
\hspace*{2em} \= U := CDR U; \\
\> GO LOOP \\
END;
\end{tabbing} }}


\de{COND}{([\p{U}:\ty{cond-form}]):\ty{any}}{noeval, nospread}
{The antecedents of all U's are evaluated in order of their appearance
until a non-NIL value is encountered. The consequent of the selected U
is evaluated and becomes the value of the COND. The consequent may
also contain the special functions GO and RETURN subject to the
restraints given for these functions in ``Program Feature Functions'',
section~\ref{prog} on page~\pageref{prog}.
\index{GO ! in COND} \index{RETUNR ! in CODE} In these cases COND does
not have a defined value, but rather an effect. If no antecedent is
non-NIL the value of COND is NIL. An error is detected if a U is
improperly formed:

\errormessage{***** Improper cond-form as argument of COND}
}


\de{NOT}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{If U is NIL, return T else return NIL (same as function NULL).

{\tt \begin{tabbing} EXPR PROCEDURE NOT(U); \\
\hspace*{1em} U EQ NIL;
\end{tabbing}}
}


\de{OR}{([\p{U}:\ty{any}]):\ty{extra-boolean}}{noeval, nospread}
{U is any number of expressions which are evaluated in order of their
appearance. When one is found to be non-NIL it is returned as the
value of OR. If all are NIL, NIL is returned.

{\tt \begin{tabbing} FEXPR PROCEDURE OR(U); \\ BEGIN SCALAR X; \\
LOOP: IF \= NULL U THEN RETURN NIL \\
\> ELSE IF (X := EVAL CAR U) THEN RETURN X; \\
\hspace*{2em} \= U := CDR U; \\
\> GO LOOP \\
END;
\end{tabbing} }}


\subsection{Arithmetic Functions}

Conversions between numeric types are provided explicitly by the
\index{FIX} \index{FLOAT}
FIX and FLOAT functions and implicitly by any multi-parameter
\index{mixed-mode arithmetic}
arithmetic function which receives mixed types of arguments. A
conversion from fixed to floating point numbers may result in a loss
of precision without a warning message being generated. Since
\index{integer ! magnitude}
integers may have a greater magnitude that that permitted for floating
numbers, an error may be signaled when the attempted conversion cannot
be done. Because the magnitude of integers is unlimited the conversion
of a floating point number to a fixed number is always possible, the
only loss of precision being the digits to the right of the decimal
point which are truncated. If a function receives mixed types of
arguments the general rule will have the fixed numbers converted to
floating before arithmetic operations are performed. In all cases an
error occurs if the parameter to an arithmetic function is not a
number:

\errormessage{***** XXX parameter to FUNCTION is not a number}

XXX is the value of the parameter at fault and FUNCTION is the name of
the function that detected the error. Exceptions to the rule are noted
where they occur.




\de{ABS}{(\p{U}:\ty{number}):\ty{number}}{eval, spread}
{Returns the absolute value of its argument.

{\tt \begin{tabbing} EXPR PROCEDURE ABS(U); \\
\hspace*{1em} IF LESSP(U, 0) THEN MINUS(U) ELSE U;
\end{tabbing}}}

\de{ADD1}{(\p{U}:\ty{number}):\ty{number}}{eval, spread}
{Returns the value of U plus 1 of the same type as U (fixed or
floating).

{\tt \begin{tabbing} EXPR PROCEDURE ADD1(U); \\
% God knows why, but hspace* isn't accepted here.
\hspace{1em} PLUS2(U, 1);
\end{tabbing}}
}

\de{DIFFERENCE}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval,
spread}
{The value U - V is returned.}


\de{DIVIDE}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{dotted-pair}}{eval,
spread}
{The dotted-pair (quotient . remainder) is returned. The quotient part
is computed the same as by QUOTIENT and the remainder the same as by
REMAINDER. An error occurs if division by zero is attempted:
\index{division by zero}

\errormessage{***** Attempt to divide by 0 in DIVIDE}

{\tt \begin{tabbing} EXPR PROCEDURE DIVIDE(U, V); \\
\hspace*{1em} (QUOTIENT(U, V) . REMAINDER(U, V));
\end{tabbing}}}


\de{EXPT}{(\p{U}:\ty{number}, \p{V}:\ty{integer}):\ty{number}}{eval, spread}
{Returns U raised to the V power. A floating point U to an integer
power V does \underline{not} have V changed to a floating number
before exponentiation.}


\de{FIX}{(\p{U}:\ty{number}):\ty{integer}}{eval, spread}
{Returns an integer which corresponds to the truncated value of U. The
result of conversion must retain all significant portions of U. If U
is an integer it is returned unchanged. }


\de{FLOAT}{(\p{U}:\ty{number}):\ty{floating}}{eval, spread}
{The floating point number corresponding to the value of the argument
U is returned. Some of the least significant digits of an integer may
be lost do to the implementation of floating point numbers. FLOAT of a
floating point number returns the number unchanged. If U is too large
to represent in floating point an error occurs:

\errormessage{***** Argument to FLOAT is too large}
}

\de{GREATERP}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{boolean}}{eval,
spread}
{Returns T if U is strictly greater than V, otherwise returns NIL.}


\de{LESSP}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{boolean}}{eval, spread}
{Returns T if U is strictly less than V, otherwise returns NIL. }


\de{MAX}{([\p{U}:\ty{number}]):\ty{number}}{noeval, nospread, or macro}
{Returns the largest of the values in U. If two or more values are the
same the first is returned.

{\tt \begin{tabbing} MACRO PROCEDURE MAX(U); \\
\hspace*{1em} EXPAND(CDR U, 'MAX2);
\end{tabbing}}}


\de{MAX2}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread}
{Returns the larger of U and V. If U and V are the same value U is
returned (U and V might be of different types).

{\tt \begin{tabbing} EXPR PROCEDURE MAX2(U, V); \\
\hspace*{1em} IF LESSP(U, V) THEN V ELSE U;
\end{tabbing}}}


\de{MIN}{([\p{U}:\ty{number}]):\ty{number}}{noeval, nospread, or macro}
{Returns the smallest of the values in U. If two or more values are
the same the first of these is returned.

{\tt \begin{tabbing} MACRO PROCEDURE MIN(U); \\
\hspace*{1em} EXPAND(CDR U, 'MIN2);
\end{tabbing}}}


\de{MIN2}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread}
{Returns the smaller of its arguments. If U and V are the same value,
U is returned (U and V might be of different types).

{\tt \begin{tabbing} EXPR PROCEDURE MIN2(U, V); \\
\hspace*{1em} IF GREATERP(U, V) THEN V ELSE U;
\end{tabbing}}}


\de{MINUS}{(\p{U}:\ty{number}):\ty{number}}{eval, spread}
{Returns -U.

{\tt \begin{tabbing} EXPR PROCEDURE MINUS(U); \\
\hspace*{1em} DIFFERENCE(0, U);
\end{tabbing}}}


\de{PLUS}{([\p{U}:\ty{number}]):\ty{number}}{noeval, nospread, or macro}
{Forms the sum of all its arguments.

{\tt \begin{tabbing} MACRO PROCEDURE PLUS(U); \\
\hspace*{1em} EXPAND(CDR U, 'PLUS2);
\end{tabbing}}}

\de{PLUS2}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread}
{Returns the sum of U and V.}


\de{QUOTIENT}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread}
{The quotient of U divided by V is returned. Division of two positive
or two negative integers is conventional. When both U and V are
integers and exactly one of them is negative the value returned is the
negative truncation of the absolute value of U divided by the absolute
value of V. An error occurs if division by zero is attempted:
\index{division by zero}

\errormessage{***** Attempt to divide by 0 in QUOTIENT}
}

\de{REMAINDER}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval,
spread}
{If both U and V are integers the result is the integer remainder of U
divided by V. If either parameter is floating point, the result is the
difference between U and V*(U/V) all in floating point. If either
number is negative the remainder is negative. If both are positive or
both are negative the remainder is positive. An error occurs if V is
zero: \index{division by zero}

\errormessage{***** Attempt to divide by 0 in REMAINDER}

{\tt \begin{tabbing} EXPR PROCEDURE REMAINDER(U, V); \\
\hspace*{1em} DIFFERENCE(U, TIMES2(QUOTIENT(U, V), V));
\end{tabbing}}}


\de{SUB1}{(\p{U}:\ty{number}):\ty{number}}{eval, spread}
{Returns the value of U less 1.  If U is a FLOAT type number, the
value returned is U less 1.0.

{\tt \begin{tabbing} EXPR PROCEDURE SUB1(U); \\
\hspace*{1em} DIFFERENCE(U, 1);
\end{tabbing}}}


\de{TIMES}{([\p{U}:\ty{number}]):\ty{number}}{noeval, nospread, or macro}
{Returns the product of all its arguments.

{\tt \begin{tabbing} MACRO PROCEDURE TIMES(U); \\
\hspace*{1em} EXPAND(CDR U, 'TIMES2);
\end{tabbing}}}


\de{TIMES2}{(\p{U}:\ty{number}, \p{V}:\ty{number}):\ty{number}}{eval, spread}
{Returns the product of U and V.}


\subsection{MAP Composite Functions}


\de{MAP}{(\p{X}:\ty{list}, F\p{N}:\ty{function}):\ty{any}}{eval, spread}
{Applies FN to successive CDR segments of X. NIL is returned.

{\tt \begin{tabbing} EXPR PROCEDURE MAP(X, FN); \\
\hspace*{1em} WHILE X DO $<<$ FN X; X := CDR X $>>$;
\end{tabbing}}}


\de{MAPC}{(X:list, FN:function):\ty{any}}{eval, spread}
{FN is applied to successive CAR segments of list X. NIL is returned.

{\tt \begin{tabbing} EXPR PROCEDURE MAPC(X, FN); \\
\hspace*{1em} WHILE X DO $<<$ FN CAR X; X := CDR X $>>$;
\end{tabbing}}}


\de{MAPCAN}{(X:list, FN:function):\ty{any}}{eval, spread}
{A concatenated list of FN applied to successive CAR elements of X is
returned.

{\tt \begin{tabbing} EXPR PROCEDURE MAPCAN(X, FN); \\
\hspace*{1em} IF\= NULL X THEN NIL \\
\> ELSE NCONC(FN CAR X, MAPCAN(CDR X, FN));
\end{tabbing}}}


\de{MAPCAR}{(X:list, FN:function):\ty{any}}{eval, spread}
{Returned is a constructed list of FN applied to each CAR of list X.

{\tt \begin{tabbing} EXPR PROCEDURE MAPCAR(X, FN); \\
\hspace*{1em} IF\= NULL X THEN NIL \\
\> ELSE FN CAR X . MAPCAR(CDR X, FN);
\end{tabbing}}}


\de{MAPCON}{(X:list, FN:function):\ty{any}}{eval, spread}
{Returned is a concatenated list of FN applied to successive CDR
segments of X.

{\tt \begin{tabbing} EXPR PROCEDURE MAPCON(X, FN); \\
\hspace*{1em} IF\= NULL X THEN NIL \\
\> ELSE NCONC(FN X, MAPCON(CDR X, FN));
\end{tabbing}}}


\de{MAPLIST}{(X:list, FN:function):\ty{any}}{eval, spread}
{Returns a constructed list of FN applied to successive CDR segments
of X.

{\tt \begin{tabbing} EXPR PROCEDURE MAPLIST(X, FN); \\
\hspace*{1em} IF\= NULL X THEN NIL \\
\> ELSE FN X . MAPLIST(CDR X, FN);
\end{tabbing}}}


\subsection{Composite Functions}

\de{APPEND}{(\p{U}:\ty{list}, \p{V}:\ty{list}):\ty{list}}{eval, spread}
{Returns a constructed list in which the last element of U is followed
by the first element of V. The list U is copied, V is not.

{\tt \begin{tabbing} EXPR PROCEDURE APPEND(U, V); \\
\hspace*{1em} IF\= NULL U THEN V \\
\> ELSE CAR U . APPEND(CDR U, V);
\end{tabbing}}}

\de{ASSOC}{(\p{U}:\ty{any}, \p{V}:\ty{alist}):\{\ty{dotted-pair},
NIL\}}{eval, spread}
{If U occurs as the CAR portion of an element of the alist V, the
dotted-pair in which U occurred is returned, else NIL is returned.
ASSOC might not detect a poorly formed alist so an invalid
\index{EQUAL ! in ASSOC} \index{alist ! in ASSOC}
construction may be detected by CAR or CDR.

{\tt \begin{tabbing} EXPR PROCEDURE ASSOC(U, V); \\
\hspace*{1em} IF \= NULL V THEN NIL \\
\> ELSE \= IF ATOM CAR V THEN \\
\> \> ERROR(000, LIST(V, "is a poorly formed alist")) \\
\> ELSE IF U = CAAR V THEN CAR V \\
\> ELSE ASSOC(U, CDR V);
\end{tabbing}}
}

\de{DEFLIST}{(\p{U}:\ty{dlist}, \p{IND}:\ty{id}):\ty{list}}{eval, spread}
{A "dlist" is a list in which each element is a two element list:
\index{dlist}
(ID:id PROP:any). Each ID in U has the indicator IND with property
PROP placed on its property list by the PUT function. The value of
DEFLIST is a list of the first elements of each two element list.
Like PUT, DEFLIST may not be used to define functions.

{\tt \begin{tabbing} EXPR PROCEDURE DEFLIST(U, IND); \\
\hspace*{1em} IF NULL U THEN NIL \\
\hspace*{2em} ELSE $<<$ \= PUT(CAAR U, IND, CADAR U); \\
\> CAAR U $>>$ . DEFLIST(CDR U, IND);
\end{tabbing}}
}

\de{DELETE}{(\p{U}:\ty{any}, \p{V}:\ty{list}):\ty{list}}{eval, spread}
{Returns V with the first top level occurrence of U removed from it.
\index{EQUAL ! in DELETE}

{\tt \begin{tabbing} EXPR PROCEDURE DELETE(U, V); \\
\hspace*{1em} IF NULL V THEN NIL \\
\hspace*{2em} ELSE IF CAR V = U THEN CDR V \\
\hspace*{2em} ELSE CAR V . DELETE(U, CDR V);
\end{tabbing}}}

\de{DIGIT}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is a digit, otherwise NIL.

{\tt \begin{tabbing} EXPR PROCEDURE DIGIT(U); \\
\hspace*{1em} IF MEMQ(U, '(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9)) \\
\hspace*{2em} THEN T ELSE NIL;
\end{tabbing}}}

\de{LENGTH}{(\p{X}:\ty{any}):\ty{integer}}{eval, spread}
{The top level length of the list X is returned.

{\tt \begin{tabbing} EXPR PROCEDURE LENGTH(X); \\
\hspace*{1em} IF ATOM X THEN 0 \\
\hspace*{2em} ELSE PLUS(1, LENGTH CDR X);
\end{tabbing}}}

\de{LITER}{(\p{U}:\ty{any}):\ty{boolean}}{eval, spread}
{Returns T if U is a character of the alphabet, NIL
otherwise.\footnote{The published report omits escape characters.
These are required for both upper and lower case as some systems
default to lower.}

{\tt \begin{tabbing} EXPR PROCEDURE LITER(U); \\
\hspace*{1em} IF \= MEMQ(U, '(\=!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 \\
\> \> !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)) \\
\> THEN T ELSE NIL;
\end{tabbing}}}

\de{MEMBER}{(\p{A}:\ty{any}, \p{B}:\ty{list}):\ty{extra-boolean}}{eval, spread}
{Returns NIL if A is not a member of list B, returns the remainder of
B whose first element is A. \index{EQUAL ! in MEMBER}

{\tt \begin{tabbing} EXPR PROCEDURE MEMBER(A, B); \\
\hspace*{1em} IF NULL B THEN NIL \\
\hspace*{2em} ELSE IF A = CAR B THEN B \\
\hspace*{2em} ELSE MEMBER(A, CDR B);
\end{tabbing}}}


\de{MEMQ}{(\p{A}:\ty{any}, \p{B}:\ty{list}):\ty{extra-boolean}}{eval, spread}
{Same as MEMBER but an EQ check is used for comparison. \index{EQ ! in
MEMQ}

{\tt \begin{tabbing} EXPR PROCEDURE MEMQ(A, B); \\
\hspace*{1em} IF \= NULL B THEN NIL \\
\> ELSE IF A EQ CAR B THEN B \\
\> ELSE MEMQ(A, CDR B);
\end{tabbing}}}

\de{NCONC}{(\p{U}:\ty{list}, \p{V}:\ty{list}):\ty{list}}{eval, spread}
{Concatenates V to U without copying U. The last CDR of U is modified
to point to V.

{\tt \begin{tabbing} EXPR PROCEDURE NCONC(U, V); \\ BEGIN SCALAR W; \\
\hspace*{2em} \= IF NULL U THEN RETURN V; \\
\> W := U; \\
\> WHILE CDR W DO W := CDR W; \\
\> RPLACD(W, V); \\
\> RETURN U \\
END;
\end{tabbing}}}

\de{PAIR}{(\p{U}:\ty{list}, \p{V}:\ty{list}):\ty{alist}}{eval, spread}
{U and V are lists which must have an identical number of elements. If
not, an error occurs (the 000 used in the ERROR call is arbitrary and
need not be adhered to). Returned is a list where each element is a
dotted-pair, the CAR of the pair being from U, and the CDR the
corresponding element from V.

{\tt \begin{tabbing} EXPR PROCEDURE PAIR(U, V); \\
\hspace*{1em} IF AND(U, V) THEN (CAR U . CAR V) . PAIR(CDR U, CDR V) \\
\hspace*{2em} \= ELSE IF OR(U, V) THEN ERROR(000, \\
\hspace*{4em} "Different length lists in PAIR") \\
\> ELSE NIL;
\end{tabbing}}}


\de{REVERSE}{(\p{U}:\ty{list}):\ty{list}}{eval, spread}
{Returns a copy of the top level of U in reverse order.

{\tt \begin{tabbing} EXPR PROCEDURE REVERSE(U); \\ BEGIN SCALAR W; \\
\hspace*{2em} \= WHILE U DO $<<$ \= W := CAR U . W; \\
\> \> U := CDR U $>>$; \\
\>  RETURN W \\
END;
\end{tabbing}}}

\de{SASSOC}{(\p{U}:\ty{any}, \p{V}:\ty{alist},
\p{FN}:\ty{function}):\ty{any}}{eval, spread}
{Searches the alist V for an occurrence of U. If U is not in the alist
the evaluation of function FN is returned. \index{EQUAL ! in SASSOC}
\index{alist ! in SASSOC}

{\tt \begin{tabbing} EXPR PROCEDURE SASSOC(U, V, FN); \\
\hspace*{1em} IF NULL V THEN FN() \\
\hspace*{2em} \= ELSE IF U = CAAR V THEN CAR V \\
\> ELSE SASSOC(U, CDR V, FN);
\end{tabbing}}}

\de{SUBLIS}{(\p{X}:\ty{alist}, \p{Y}:\ty{any}):\ty{any}}{eval, spread}
{The value returned is the result of substituting the CDR of each
element of the alist X for every occurrence of the CAR part of that
element in Y. \index{alist ! in SUBLIS}

{\tt \begin{tabbing} EXPR PROCEDURE SUBLIS(X, Y); \\
\hspace*{1em}IF NULL X THEN Y \\
\hspace*{2em} ELSE BEGIN \= SCALAR U; \\
\> U := ASSOC(Y, X); \\
\> RETURN \= IF U THEN CDR U \\
\> \> ELSE IF ATOM Y THEN Y \\
\> \> ELSE \= SUBLIS(X, CAR Y) . \\
\> \> \> SUBLIS(X, CDR Y) \\
\> END;
\end{tabbing}}}

\de{SUBST}{(\p{U}:\ty{any}, \p{V}:\ty{any}, \p{W}:\ty{any}):\ty{any}}{eval,
spread}
{The value returned is the result of substituting U for all
occurrences of V in W. \index{EQUAL ! in SUBST}

{\tt \begin{tabbing} EXPR PROCEDURE SUBST(U, V, W); \\
\hspace*{1em} IF NULL W THEN NIL \\
\hspace*{2em} \= ELSE IF V = W THEN U \\
\> ELSE IF ATOM W THEN W \\
\> ELSE SUBST(U, V, CAR W) . SUBST(U, V, CDR W);
\end{tabbing}}}


\subsection{The Interpreter}
\label{interpreter}
\de{APPLY}{(\p{FN}:\{\ty{id,function}\},
\p{ARGS}:\ty{any-list}):\ty{any}}{eval, spread}
{APPLY returns the value of FN with actual parameters ARGS. The actual
parameters in ARGS are already in the form required for binding to the
formal parameters of FN. Implementation specific portions described in
English are enclosed in boxes.

{\tt \begin{tabbing} EXPR PROCEDURE APPLY(FN, ARGS); \\ BEGIN SCALAR
DEFN; \\
\hspace*{2em}\= IF CODEP FN THEN RETURN \\
\> \hspace{1em} \framebox[3.25in]{\parbox{3.25in}{Spread the actual
parameters in ARGS
following the conventions: for calling functions, transfer to the
entry point of the function, and return the value returned by the
function.}}; \\
\> IF \= IDP FN THEN RETURN \\
\> \> IF \= NULL(DEFN := GETD FN) THEN \\
\> \> \> ERROR(000, LIST(FN, "is an undefined function")) \\
\> \> ELSE IF CAR DEFN EQ 'EXPR THEN \\
\> \> \> APPLY(CDR DEFN, ARGS) \\
\> \> ELSE ERROR(000, \\
\> \> \> LIST(FN, "cannot be evaluated by APPLY")); \\
\> IF OR(ATOM FN, NOT(CAR FN EQ 'LAMBDA)) THEN \\
\> \> ERROR(000, \\
\> \> LIST(FN, "cannot be evaluated by APPLY")); \\
\> RETURN \\
\> \> \framebox[3.25in]{\parbox{3.25in}{Bind the actual parameters in ARGS to
the formal
parameters of the lambda expression. If the two lists are not of equal
length then ERROR(000, "Number of parameters do not match"); The value
returned is EVAL CADDR FN.}} \\ END;
\end{tabbing}}}

\de{EVAL}{(\p{U}:\ty{any}):\ty{any}}{eval, spread}
{The value of the expression U is computed. Error numbers are
arbitrary. Portions of EVAL involving machine specific coding are
expressed in English enclosed in boxes.

{\tt \begin{tabbing} EXPR PROCEDURE EVAL(U); \\ BEGIN SCALAR FN; \\
\hspace*{2em} \= IF CONSTANTP U THEN RETURN U; \\
\> IF IDP U THEN RETURN \\
\> \hspace{1em} \framebox[3.25in]{\parbox{3.25in}{U is an id. Return the
value most currently
bound to U or if there is no such binding: ERROR(000, LIST("Unbound:",
U));}} \\
\> IF \= PAIRP CAR U THEN RETURN \\
\> \> IF CAAR U EQ 'LAMBDA THEN APPLY(CAR U, EVLIS CDR U) \\
\> \> ELSE ERROR(\= 000, LIST(CAR U, \\
\> \> \> "improperly formed LAMBDA expression")) \\
\> \> ELSE IF CODEP CAR U THEN \\
\> \> \> RETURN APPLY(CAR U, EVLIS CDR U); \\
\> FN := GETD CAR U; \\
\> IF NULL FN THEN \\
\> \> ERROR(000, LIST(CAR U, "is an undefined function")) \\
\> ELSE IF CAR FN EQ 'EXPR THEN \\
\> \> RETURN APPLY(CDR FN, EVLIS CDR U) \\
\> ELSE IF CAR FN EQ 'FEXPR THEN \\
\> \> RETURN APPLY(CDR FN, LIST CDR U) \\
\> ELSE IF CAR FN EQ 'MACRO THEN \\
\> \> RETURN EVAL APPLY(CDR FN, LIST U) \\
END;
\end{tabbing}}}

\de{EVLIS}{(\p{U}:\ty{any-list}):\ty{any-list}}{eval, spread}
{EVLIS returns a list of the evaluation of each element of U.

{\tt \begin{tabbing} EXPR PROCEDURE EVLIS(U); \\
\hspace*{1em} IF NULL U THEN NIL \\
\hspace*{2em} ELSE EVAL CAR U . EVLIS CDR U;
\end{tabbing}}}

\de{EXPAND}{(\p{L}:\ty{list}, \p{FN}:\ty{function}):\ty{list}}{eval, spread}
{FN is a defined function of two arguments to be used in the expansion
of a MACRO. EXPAND returns a list in the form:

\vspace{.15in}
(FN L$_0$ (FN L$_1$ \ldots (FN L$_{n-1}$ L$_n$) \ldots ))
\vspace{.15in}

where $n$ is the number of elements in L, L$_i$ is the $i$th element
of L.

{\tt \begin{tabbing} EXPR PROCEDURE EXPAND(L,FN); \\
\hspace*{1em} IF NULL CDR L THEN CAR L \\
\hspace*{2em} ELSE LIST(FN, CAR L, EXPAND(CDR L, FN));
\end{tabbing}}}

\de{FUNCTION}{(\p{FN}:\ty{function}):\ty{function}}{noeval, nospread}
{The function FN is to be passed to another function. If FN is to have
side effects its free variables must be fluid or global. FUNCTION is
like QUOTE but its argument may be affected by compilation. We do not
\index{FUNARGs not supported}
consider FUNARGs in this report.}


\de{QUOTE}{(U:any):\ty{any}}{noeval, nospread}
{Stops evaluation and returns U unevaluated.

{\tt \begin{tabbing} FEXPR PROCEDURE QUOTE(U); \\
\hspace*{2em}CAR U;
\end{tabbing}}}

\subsection{Input and Output}
\label{IO}
The user normally communicates with Standard LISP through
\index{standard devices}
``standard devices''. The default devices are selected in accordance
with the conventions of the implementation site. Other input and
output devices or files may be selected for reading and writing using
the functions described herein.



\de{CLOSE}{(\p{FILEHANDLE}:\ty{any}):\ty{any}}{eval, spread}
{Closes the file with the internal name FILEHANDLE writing any
necessary end of file marks and such. The value of FILEHANDLE is that
returned by the corresponding OPEN. \index{OPEN} The value returned is
the value of FILEHANDLE. An error occurs if the file can not be
\index{file handle} \index{files}
closed.

\errormessage{   ***** FILEHANDLE could not be closed}
}

\de{EJECT}{():NIL}{eval, spread}
{Skip to the top of the next output page. Automatic EJECTs are
executed by the print functions when the length set by the PAGELENGTH
\index{PAGELENGTH} function is exceeded.}


\de{LINELENGTH}{(\p{LEN}:\{\ty{integer}, NIL\}):\ty{integer}}{eval, spread}
{If LEN is an integer the maximum line length to be printed before the
print functions initiate an automatic TERPRI is set to the value LEN.
\index{TERPRI}
No initial Standard LISP line length is assumed. The previous line
length is returned except when LEN is NIL. This special case returns
the current line length and does not cause it to be reset. An error
occurs if the requested line length is too large for the currently
selected output file or LEN is negative or zero.

\errormessage{   ***** LEN is an invalid line length}
}


\de{LPOSN}{():\ty{integer}}{eval, spread}
{Returns the number of lines printed on the current page. At the top
of a page, 0 is returned. }


\de{OPEN}{(\p{FILE}:\ty{any}, \p{HOW}:\ty{id}):\ty{any}}{eval, spread}
{Open the file with the system dependent name FILE for output if HOW
is EQ to OUTPUT, or input if HOW is EQ to INPUT. If the file is
\index{file handle} \index{files} \index{OUTPUT} \index{INPUT}
opened successfully, a value which is internally associated with the
file is returned. This value must be saved for use by RDS and WRS. An
error occurs if HOW is something other than INPUT or OUTPUT or the
file can't be opened.

\errormessage{***** HOW is not option for OPEN}
\errormessage{***** FILE could not be opened}
}


\de{PAGELENGTH}{(\p{LEN}:\{\ty{integer}, NIL\}):\ty{integer}}{eval, spread}
{Sets the vertical length (in lines) of an output page. Automatic page
EJECTs are executed by the print functions when this length is
\index{EJECT}
reached. The initial vertical length is implementation specific. The
previous page length is returned. If LEN is 0, no automatic page
ejects will occur. }


\de{POSN}{():\ty{integer}}{eval, spread}
{Returns the number of characters in the output buffer. When the
buffer is empty, 0 is returned.}


\de{PRINC}{(\p{U}:\ty{id}):\ty{id}}{eval, spread}
{U must be a single character id such as produced by EXPLODE or read
by READCH or the value of !\$EOL!\$. The effect is the character U
\index{\$EOL\$ (global)}
displayed upon the currently selected output device. The value of
!\$EOL!\$ causes termination of the current line like a call to
TERPRI.}


\de{PRINT}{(\p{U}:\ty{any}):\ty{any}}{eval, spread}
{Displays U in READ readable format and terminates the print line. The
value of U is returned.

{\tt \begin{tabbing} EXPR PROCEDURE PRINT(U); \\
\hspace*{2em} $<<$ PRIN1 U; TERPRI(); U $>>$;
\end{tabbing}}}


\de{PRIN1}{(\p{U}:\ty{any}):\ty{any}}{eval, spread}
{U is displayed in a READ readable form. The format of display is the
result of EXPLODE expansion; special characters are prefixed with the
escape character !, and strings are enclosed in "\ldots ". Lists are
displayed in list-notation and vectors in vector-notation. }


\de{PRIN2}{(\p{U}:\ty{any}):\ty{any}}{eval, spread}
{U is displayed upon the currently selected print device but output is
not READ readable. The value of U is returned. Items are displayed as
described in the EXPLODE function with the exceptions that the escape
character does not prefix special characters and strings are not
enclosed in "\ldots ". Lists are displayed in list-notation and
vectors in vector-notation. The value of U is returned. }


\de{RDS}{(\p{FILEHANDLE}:\ty{any}):\ty{any}}{eval, spread}
{Input from the currently selected input file is suspended and further
input comes from the file named. FILEHANDLE is a system dependent
\index{file handle}
internal name which is a value returned by OPEN. If FILEHANDLE is NIL
the standard input device is selected. When end of file is reached on
a non-standard input device, the standard input device is reselected.
When end of file occurs on the standard input device the Standard LISP
reader terminates. RDS returns the internal name of the previously
selected input file.
\index{standard input}

\errormessage{***** FILEHANDLE could not be selected for input}
}


\de{READ}{():\ty{any}}{}
{The next expression from the file currently selected for input. Valid
input forms are: vector-notation, dot-notation, list-notation,
numbers, function-pointers, strings, and identifiers with escape
characters. Identifiers are interned onW the OBLIST (see
\index{INTERN} \index{OBLIST entry}
the INTERN function in "Identifiers", section~\ref{identifiers} on
page~\pageref{identifiers}). READ returns the
\index{\$EOF\$ (global)}
value of !\$EOF!\$ when the end of the currently selected input file
is reached. }


\de{READCH}{():\ty{id}}{}
{Returns the next interned character from the file currently selected
for input. Two special cases occur. If all the characters in an input
\index{\$EOL\$ (global)} \index{\$EOF\$ (global)} record have been read,
the value of !\$EOL!\$ is returned. If the file selected for input has
all been read the value of !\$EOF!\$ is returned. Comments delimited
by \% and end-of-line are not transparent to READCH. \index{\% ! read
by READCH} }


\de{TERPRI}{():\p{NIL}}{}
{The current print line is terminated.}


\de{WRS}{(\p{FILEHANDLE}:\ty{any}):\ty{any}}{eval, spread}
{Output to the currently active output file is suspended and further
output is directed to the file named. FILEHANDLE is an internal name
which is returned by OPEN. The file named must have been opened for
output. If FILEHANDLE is NIL the standard output device is selected.
\index{file handle} \index{standard output}
WRS returns the internal name of the previously selected output file.

\errormessage{***** FILEHANDLE could not be selected for output}
}

\subsection{LISP Reader}

An EVAL read loop has been chosen to drive a Standard LISP system to
provide a continuity in functional syntax. Choices of messages and the
amount of extra information displayed are decisions left to the
implementor.

\index{STANDARD-LISP}
{\tt \begin{tabbing} EXPR PROCEDURE STANDARD!-LISP(); \\ BEGIN SCALAR
VALUE; \\
\hspace*{2em} \= RDS NIL;  WRS NIL; \\
\> PRIN2 "Standard LISP"; TERPRI(); \\
\> WHILE T DO \\
\> \hspace*{1em} $<<$ \= PRIN2 "EVAL:"; TERPRI(); \\
\> \> VALUE := ERRORSET(QUOTE EVAL READ(), T, T); \\
\> \> IF NOT ATOM VALUE THEN PRINT CAR VALUE; \\
\> \> TERPRI() $>>$; \\
END;
\end{tabbing}}

\de{QUIT}{()}{}
{Causes termination of the LISP reader and control to be transferred
to the operating system.}

\section{System GLOBAL Variables}
\label{slglobals}

These variables provide global control of the LISP system, or
implement values which are constant throughout execution.\footnote{The
published document does not specify that all these are GLOBAL.}


\variable{*COMP}{NIL}{global}
{The value of !*COMP controls whether or not PUTD compiles the
function defined in its arguments before defining it. If !*COMP is NIL
the function is defined as an xEXPR. If !*COMP is something else the
function is first compiled. Compilation will produce certain changes
in the semantics of functions particularly FLUID type access.}


\variable{EMSG*}{NIL}{global}
{Will contain the MESSAGE generated by the last ERROR call (see
\index{ERROR}
``Error Handling'' section~\ref{errors} on page~\pageref{errors}).}


\variable{\$EOF\$}{\s{an uninterned identifier}}{global}
{The value of !\$EOF!\$ is returned by all input functions when the
end
\index{end of file}
of the currently selected input file is reached.}


\variable{\$EOL\$}{\s{an uninterned identifier}}{global}
{The value of !\$EOL!\$ is returned by READCH when it reaches the end
of
\index{READCH} \index{end of line} \index{PRINC}
a logical input record. Likewise PRINC will terminate its current line
(like a call to TERPRI) when !\$EOL!\$ is its argument.}

\variable{*GC}{NIL}{global}
{!*GC controls the printing of garbage collector messages.  If NIL no
\index{garbage collector}
indication of garbage collection may occur.  If non-NIL various system
dependent messages may be displayed.}


\variable{NIL}{NIL}{global}
{NIL is a special global variable. It is protected from being modified
by SET or SETQ.
\index{NIL ! cannot be changed}}


\variable{*RAISE}{NIL}{global}
{If !*RAISE is non-NIL all characters input through Standard LISP
input/output functions will be raised to upper case. If !*RAISE is NIL
characters will be input as is.}


\variable{T}{T}{global}
{T is a special global variable. It is protected from being modified
by SET or SETQ. \index{T ! cannot be changed}}


\section{The Extended Syntax}

Whenever it is possible to define Standard LISP functions in LISP the
text of the function will appear in an extended syntax.  These
definitions are supplied as an aid to understanding the behavior of
functions and not as a strict implementation guide.  A formal scheme
for the translation of extended syntax to Standard LISP is presented
to eliminate misinterpretation of the definitions.

\subsection{Definition}
The goal of the transformation scheme is to produce a PUTD invocation
which has the function translated from the extended syntax as its
actual parameter.  A rule has a name in brackets
\s{\ldots} by which it is known and is defined by what follows the meta 
symbol ::=.  Each rule of the set consists of one or more
``alternatives'' separated by the $\mid$ meta symbol, being the
different ways in which the rule will be matched by source text.  Each
alternative is composed of a ``recognizer'' and a ``generator''
separated by the $\Longrightarrow$ meta symbol.  The recognizer is a
concatenation of any of three different forms.  1) Terminals - Upper
case lexemes and punctuation which is not part of the meta syntax
represent items which must appear as is in the source text for the
rule to succeed.  2) Rules - Lower case lexemes enclosed in \s{\ldots}
are names of other rules.  The source text is matched if the named
rule succeeds.  3) Primitives - Lower case singletons not in brackets
are names of primitives or primitive classes of Standard LISP.  The
syntax and semantics of the primitives are given in Part I.

The recognizer portion of the following rule matches an extended
syntax procedure:
 

\s{function} ::= ftype PROCEDURE id (\s{id list});  \\
\hspace*{2em} \s{statement}; $\Longrightarrow$
 
A function is recognized as an ``ftype'' (one of the tokens EXPR,
FEXPR, etc.) followed by the keyword PROCEDURE, followed by an ``id''
(the name of the function), followed by an \s{id list} (the formal
parameter names) enclosed in parentheses.  A semicolon terminates the
title line.  The body of the function is a
\s{statement} followed by a semicolon.  For example: 
 
\begin{verbatim}
EXPR PROCEDURE NULL(X); EQ(X, NIL);
\end{verbatim}

\noindent satisfies the recognizer, causes the generator to be activated and 
the rule to be matched successfully.

The generator is a template into which generated items are
substituted.  The three syntactic entities have corresponding meanings
when they appear in the generator portion.  1) Terminals - These
lexemes are copied as is to the generated text.  2) Rules - If a rule
has succeeded in the recognizer section then the value of the rule is
the result of the generator portion of that rule.  3) Primitives -
When primitives are matched the primitive lexeme replaces its
occurrence in the generator.
 
If more than one occurrence of an item would cause ambiguity in the
generator portion this entity appears with a bracketed subscript.
Thus:
 
\begin{tabbing}
\s{conditional} ::= \\
\hspace*{2em} IF \s{expression} \= THEN \s{statement$_1$} \\ 
\> ELSE \s{statement$_2$} \ldots
\end{tabbing}
 
\noindent has occurrences of two different \s{statement}s.  The generator 
portion uses the subscripted entities to reference the proper
generated value.

The \s{function} rule appears in its entirety as:

\begin{tabbing}
\s{function} ::= ftype PROCEDURE id (\s{id list});\s{statement};
$\Longrightarrow$ \\
\hspace*{2em} \=(PUTD \= (QUOTE id) \\
\> \> (QUOTE ftype) \\
\> \>(QUOTE (LAMBDA (\s{id list}) \s{statement})))
\end{tabbing}
 
If the recognizer succeeds (as it would in the case of the NULL
procedure example) the generator returns:

\begin{verbatim}
(PUTD (QUOTE NULL) (QUOTE EXPR) (QUOTE (LAMBDA (X) (EQ X NIL))))
\end{verbatim}
 
The identifier in the template is replaced by the procedure name NULL,
\s{id list} by the single formal parameter X, the \s{statement} by (EQ
X NIL) which is the result of the \s{statement} generator.  EXPR
replaces ftype, the type of the defined procedure.
 
 
\subsection{The Extended Syntax Rules}

\begin{tabbing}
\s{function} ::= ftype \k{PROCEDURE} id (\s{id list}); \s{statement};
$\Longrightarrow$ \\
\hspace*{2em} \= (PUTD \= (QUOTE id) \\
\> \> (QUOTE ftype) \\
\> \> (QUOTE (LAMBDA (\s{id list}) \s{statement}))) \\ \\

\s{id list} ::= id $\Longrightarrow$ id $\mid$ \\
\> id, \s{id list} $\Longrightarrow$ id \s{id list} $\mid$ \\
\> $\Longrightarrow$ NIL \\

\s{statement} ::= \s{expression} $\Longrightarrow$ \s{expression} $\mid$ \\
\> \s{proper statement} $\Longrightarrow$ \s{proper statement} \\ \\

\s{proper statement} ::=  \\
\> \s{assignment statement} $\Longrightarrow$ \s{assignment statement}
$\mid$ \\
\> \s{conditional statement} $\Longrightarrow$ \s{conditional statement}
$\mid$ \\
\> \s{while statement} $\Longrightarrow$ \s{while statement} $\mid$ \\
\> \s{compound statement} $\Longrightarrow$ \s{compound statement} \\ \\

\s{assignment statement} ::= id := \s{expression} $\Longrightarrow$ \\
\> \> (SETQ id \s{expression}) \\ \\

\s{conditional statement} ::= \\
\> \k{IF} \s{expression} \k{THEN} \s{statement$_1$} \k{ELSE}
\s{statement$_2$} $\Longrightarrow$ \\
\> \hspace{2em} \= (COND (\s{expression} \s{statement$_1$})(T
\s{statement$_2$})) $\mid$ \\
\> \k{IF} \s{expression} \k{THEN} \s{statement} $\Longrightarrow$ \\
\> \> (COND (\s{expression} \s{statement})) \\ \\

\s{while statement} ::= \k{WHILE} \s{expression} \k{DO} \s{statement}
$\Longrightarrow$ \\
\> \> (PROG NIL \\
\> \> LBL \= (COND ((NULL \s{expression}) (RETURN NIL))) \\
\> \> \> \s{statement} \\
\> \> \> (GO LBL))  \\ \\

\s{compound statement} ::= \\
\> \k{BEGIN} \k{SCALAR} \s{id list}; \s{program list} \k{END}
$\Longrightarrow$ \\
\> \> (PROG (\s{id list}) \s{program list}) $\mid$ \\
\> \k{BEGIN} \s{program list} \k{END} $\Longrightarrow$ \\
\> \> (PROG NIL \s{program list}) $\mid$ \\
\> \k{$<<$} \s{statement list} \k{$>>$} $\Longrightarrow$ (PROGN
\s{statement list}) \\ \\

\s{program list} ::= \s{full statement} $\Longrightarrow$ \s{full statement}
 $\mid$ \\
\> \s{full statement} \s{program list} $\Longrightarrow$ \\
\> \> \s{full statement} \s{program list} \\ \\

\s{full statement} ::= \s{statement} $\Longrightarrow$ \s{statement} $\mid$
id: $\Longrightarrow$ id  \\ \\

\s{statement list} ::= \s{statement} $\Longrightarrow$ \s{statement} $\mid$ \\
\> \s{statement}; \s{statement list} $\Longrightarrow$ \\
\> \> \s{statement} \s{statement list}  \\ \\

\s{expression} ::= \\
\> \s{expression$_1$} \k{.} \s{expression$_2$} $\Longrightarrow$ \\
\> \> (CONS \s{expression$_1$} \s{expression$_2$} $\mid$ \\
\> \s{expression$_1$} \k{=}  \s{expression$_2$} $\Longrightarrow$ \\
\> \> (EQUAL \s{expression$_1$} \s{expression$_2$}) $\mid$ \\
\> \s{expression$_1$} \k{EQ} \s{expression$_2$} $\Longrightarrow$ \\
\> \> (EQ \s{expression$_1$} \s{expression$_2$}) $\mid$ \\
\> '\s{expression} $\Longrightarrow$ (QUOTE \s{expression}) $\mid$ \\
\> function \s{expression} $\Longrightarrow$ (function \s{expression})
$\mid$ \\
\> function(\s{argument list}) $\Longrightarrow$ (function \s{argument list})
$\mid$ \\
\>  number $\Longrightarrow$ number $\mid$ \\
\> id $\Longrightarrow$ id \\ \\

\s{argument list} ::= () $\Longrightarrow$ $\mid$ \\
\> \s{expression} $\Longrightarrow$ \s{expression} $\mid$ \\
\> \s{expression}, \s{argument list} $\Longrightarrow$ \s{expression}
\s{argument list}
\end{tabbing}
 
Notice the three infix operators .  EQ and = which are translated into
calls on CONS, EQ, and EQUAL respectively.  Note also that a call on a
function which has no formal parameters must have () as an argument
list.  The QUOTE function is abbreviated by '.
\bibliography{sl}
\bibliographystyle{plain}
\end{document}

Added r34.1/doc/spde.tex version [5db21286ea].













































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
\documentstyle[11pt,reduce]{article}
\title{The Package SPDE for Determining Symmetries of Partial
Differential Equations}
\date{}
\author{Fritz Schwarz \\ GMD, Institut F1 \\
Postfach 1240 \\ 5205 St. Augustin \\
GERMANY \\[0.05in]
Telephone: +49-2241-142782 \\
Email: gf1002@dbngmd21.bitnet}
\begin{document}
\maketitle

The package SPDE provides a set of functions which may be applied
to determine the symmetry group of Lie-or point-symmetries of a
given system of partial differential equations.  Preferably it is
used interactively on a computer terminal. In many cases the
determining system is solved completely automatically. In some
other cases the user has to provide some additional input
information for the solution algorithm to terminate. The package
should only be used in compiled form.

For all theoretical questions, a description of the algorithm and
numerous examples the following articles should be consulted:
``Automatically Determining Symmetries of Partial Differential
Equations'', Computing vol. 34, page 91-106(1985) and vol. 36, page
279-280(1986), ``Symmetries of Differential Equations: From Sophus
Lie to Computer Algebra'', SIAM Review, to appear, and Chapter 2
of the Lecture Notes ``Computer Algebra and Differential Equations
of Mathematical Physics'', to appear.


\section{Description of the System Functions and Variables}

The symmetry analysis of partial differential equations logically
falls into three parts. Accordingly the most important functions
provided by the package are:

\begin{table}
\begin{center}
\begin{tabular}{| c | c | }\hline 
Function name & Operation \\ \hline \hline
\ttindex{CRESYS}
CRESYS(\s{arguments}) & Constructs determining system \\ \hline
\ttindex{SIMPSYS}
SIMPSYS() & Solves determining system \\ \hline
\ttindex{RESULT}
RESULT() & Prints infinitesimal generators \\
&  and commutator table \\ \hline
\end{tabular}
\end{center}
\caption{SPDE Functions}
\end{table}

Some other useful functions for obtaining various kinds of output
are:

\begin{table}
\begin{center}
\begin{tabular}{| c | c |} \hline
Function name & Operation \\ \hline \hline
\ttindex{PRSYS}
PRSYS() & Prints determining system \\ \hline
\ttindex{PRGEN}
PRGEN() & Prints infinitesimal generators \\ \hline
\ttindex{COMM}
COMM(U,V) & Prints commutator of generators U and V \\ \hline
\end{tabular}
\end{center}
\caption{SPDE Useful Output Functions}\label{spde:useful}
\end{table}

There are several global variables defined by the system which should
not be used for any other purpose than that given in
Table~\ref{spde:intt} and~\ref{spde:op}. The three globals of the type
integer are:

\begin{table}
\begin{center}
\begin{tabular}{| c | c |}\hline
Variable name & Meaning \\ \hline \hline
\ttindex{NN}
NN & Number of independent variables \\ \hline
\ttindex{MM}
MM & Number of dependent variables \\ \hline
\ttindex{PCLASS}
PCLASS=0, 1 or 2 & Controls amount of output \\ \hline
\end{tabular}
\end{center}
\caption{SPDE Integer valued globals}\label{spde:intt}
\end{table}

In addition there are the following global variables of type
operator:

\begin{table}
\begin{center}
\begin{tabular}{| c | c |}\hline
Variable name & Meaning \\ \hline \hline
\ttindex{X(I)}
X(I) & Independent variable $x_i$ \\ \hline
\ttindex{U(ALFA)}
U(ALFA) & Dependent variable $u^{alfa}$ \\ \hline
\ttindex{U(ALFA,I)}
U(ALFA,I) & Derivative of $u^{alfa}$ w.r.t. $x_i$ \\ \hline
\ttindex{DEQ(I)}
DEQ(I) & i-th differential equation \\ \hline
\ttindex{SDER(I)}
SDER(I) & Derivative w.r.t. which DEQ(I) is resolved \\ \hline
\ttindex{GL(I)}
GL(I) & i-th equation of determining system \\ \hline
\ttindex{GEN(I)}
GEN(I) & i-th infinitesimal generator \\ \hline
\ttindex{XI(I)} \ttindex{ETA(ALFA)} \ttindex{ZETA(ALFA,I)}
XI(I), ETA(ALFA)  & See definition given in the \\
ZETA(ALFA,I) & references quoted in the introduction. \\ \hline
\ttindex{C(I)}
C(I) & i-th function used for substitution \\ \hline
\end{tabular}
\end{center}
\caption{SPDE Operator type global variables}\label{spde:op}
\end{table}


The differential equations of the system at issue have to be assigned
as values to the operator deq i applying the notation which is defined
in Table~\ref{spde:op}. The entries in the third and the last line of
that Table have obvious extensions to higher derivatives.

The derivative w.r.t. which the i-th differential equation deq i is
resolved has to be assigned to sder i. Exception: If there is a single
differential equation and no assignment has been made by the user, the
highest derivative is taken by default.

When the appropriate assignments are made to the variable deq, the
values of NN and MM (Table~\ref{spde:useful}) are determined
automatically, i.e. they have not to be assigned by the user.

\ttindex{CRESYS}
The function CRESYS may be called with any number of arguments, i.e.

\begin{verbatim}
  CRESYS(); or CRESYS(deq 1,deq 2,... );
\end{verbatim}

 are legal calls. If it is called without any argument, all current
assignments to deq are taken into account. Example: If deq 1, deq 2
and deq 3 have been assigned a differential equation and the symmetry
group of the full system comprising all three equations is desired,
equivalent calls are

\begin{verbatim}
  CRESYS();   or   CRESYS(deq 1,deq 2,deq 3);
\end{verbatim}

The first alternative saves some typing. If later in the session the
symmetry group of deq 1 alone has to be determined, the correct call
is

\begin{verbatim}
  CRESYS deq 1;
\end{verbatim}

\ttindex{SIMPSYS}
After the determining system has bee created, SIMPSYS which has no
arguments may be called for solving it. The amount of intermediate
output produced by SIMPSYS is controlled by the global variable PCLASS
with the default value 0. \ttindex{PCLASS} With PCLASS equal to 0, no
intermediate steps are shown. With PCLASS equal to 1, all intermediate
steps are displayed so that the solution algorithm may be followed
\index{tracing ! SPDE package} through in detail. Each time the algorithm
passes through the top of the main solution loop the message

\begin{verbatim}
  Entering main loop
\end{verbatim}

is written. PCLASS equal 2 produces a lot of LISP output and is of no
interest for the normal user.

If with PCLASS=0 the procedure SIMPSYS terminates without any
response, the determining system is completely solved.  In some cases
SIMPSYS does not solve the determining system completely in a single
run. In general this is true if there are only genuine differential
equations left which the algorithm cannot handle at present. If a case
like this occurs, SIMPSYS returns the remaining equations of the
determining system. To proceed with the solution algorithm,
appropriate assignments have to be transmitted by the user, e.g. the
explicit solution for one of the returned differential equations. Any
new functions which are introduced thereby must be operators of the
form c(k) with the correct dependencies generated by a depend
statement (see the ``REDUCE User's Guide''). Its enumeration has to be
chosen in agreement with the current number of functions which have
alreday been introduced.  This value is returned by SIMPSYS too.

After the determining system has been solved, the procedure RESULT,
which has no arguments, may be called. It displays the infinitesimal
generators and its non-vanishing commutators.


\section{How to Use the Package}

In this Section it is explained by way of several examples how the
package SPDE is used interactively to determine the symmetry group of
partial differential equations. Consider first the diffusion equation
which in the notation given above may be written as

\begin{verbatim}
  deq 1:=u(1,1)+u(1,2,2);
\end{verbatim}

It has been assigned as the value of deq 1 by this statement.  There
is no need to assign a value to sder 1 here because the system
comprises only a single equation.

The determining system is constructed by calling

\begin{verbatim}
  CRESYS(); or CRESYS deq 1;
\end{verbatim}

The latter call is compulsory if there are other assignments to the
operator deq i than for i=1.

The error message

\begin{verbatim}
  ***** Differential equations not defined
\end{verbatim}

appears if there are no differential equations assigned to any deq.

If the user wants the determining system displayed for inspection
before starting the solution algorithm he may call

\ttindex{PRSYS}
\begin{verbatim}
  PRSYS();
\end{verbatim}

and gets the answer

\begin{verbatim}
  GL(1):=2*DF(ETA(1),U(1),X(2)) - DF(XI(2),X(2),2) - 
         DF(XI(2),X(1))

  GL(2):=DF(ETA(1),U(1),2) - 2*DF(XI(2),U(1),X(2))

  GL(3):=DF(ETA(1),X(2),2) + DF(ETA(1),X(1))

  GL(4):=DF(XI(2),U(1),2)

  GL(5):=DF(XI(2),U(1)) - DF(XI(1),U(1),X(2))

  GL(6):=2*DF(XI(2),X(2)) - DF(XI(1),X(2),2) - DF(XI(1),X(1))

  GL(7):=DF(XI(1),U(1),2)

  GL(8):=DF(XI(1),U(1))

  GL(9):=DF(XI(1),X(2))

The remaining dependencies

  XI(2) depends on U(1),X(2),X(1)

  XI(1) depends on U(1),X(2),X(1)

  ETA(1) depends on U(1),X(2),X(1)
\end{verbatim}

The last message means that all three functions XI(1), XI(2) and
ETA(1) depend on X(1), X(2) and U(1). Without this information the
nine equations GL(1) to GL(9) forming the determining system are
meaningless. Now the solution algorithm may be activated by calling

\ttindex{SIMPSYS}
\begin{verbatim}
   SIMPSYS();
\end{verbatim}

\ttindex{PCLASS}
If the print flag PCLASS has its default value which is 0 no
intermediate output is produced and the answer is

\begin{verbatim}
  Determining system is not completely solved

  The remaining equations are

  GL(1):=DF(C(1),X(2),2) + DF(C(1),X(1))

  Number of functions is 16

  The remaining dependencies

  C(1) depends on X(2),X(1)
\end{verbatim}

With PCLASS equal to 1 about 6 pages of intermediate output are
obtained. It allows the user to follow through each step of the
solution algorithm.

In this example the algorithm did not solve the determining system
completely as it is shown by the last message. This was to be expected
because the diffusion equation is linear and therefore the symmetry
group contains a generator depending on a function which solves the
original differential equation. In cases like this the user has to
provide some additional information to the system so that the solution
algorithm may continue. In the example under consideration the
appropriate input is

\begin{verbatim}
   DF(C(1),X(1)) := - DF(C(1),X(2),2);
\end{verbatim}

If now the solution algorithm is activated again by

\begin{verbatim}
  SIMPSYS();
\end{verbatim}

the solution algorithm terminates without any further message, i.e.
there are no equations of the determining system left unsolved. To
obtain the symmetry generators one has to say finally

\begin{verbatim}
  RESULT();
\end{verbatim}

and obtains the answer

\begin{verbatim}
  The differential equation

  DEQ(1):=U(1,2,2) + U(1,1)


  The symmetry generators are

  GEN(1):= DX(1)

  GEN(2):= DX(2)

  GEN(3):= 2*DX(2)*X(1) + DU(1)*U(1)*X(2)

  GEN(4):= DU(1)*U(1)

  GEN(5):= 2*DX(1)*X(1) + DX(2)*X(2)

                       2
  GEN(6):= 4*DX(1)*X(1)

         + 4*DX(2)*X(2)*X(1)

                           2
           + DU(1)*U(1)*(X(2)  - 2*X(1))

  GEN(7):= DU(1)*C(1)

  The remaining dependencies

  C(1) depends on X(2),X(1)


  Constraints

  DF(C(1),X(1)):= - DF(C(1),X(2),2)


  The non-vanishing commutators of the finite subgroup


  COMM(1,3):= 2*DX(2)

  COMM(1,5):= 2*DX(1)

  COMM(1,6):= 8*DX(1)*X(1) + 4*DX(2)*X(2) - 2*DU(1)*U(1)

  COMM(2,3):= DU(1)*U(1)

  COMM(2,5):= DX(2)

  COMM(2,6):= 4*DX(2)*X(1) + 2*DU(1)*U(1)*X(2)

  COMM(3,5):=  - (2*DX(2)*X(1) + DU(1)*U(1)*X(2))

                          2
  COMM(5,6):= 8*DX(1)*X(1)

            + 8*DX(2)*X(2)*X(1)

                                2
            + 2*DU(1)*U(1)*(X(2)  - 2*X(1))
\end{verbatim}

The message ``Constraints'' which appears after the symmetry generators
are displayed means that the function c(1) depends on x(1) and x(2)
and satisfies the diffusion equation.

More examples which may used for test runs are given in the final
section.

\index{ansatz of symmetry generator}
If the user wants to test a certain ansatz of a symmetry generator for
given differential equations, the correct proceeding is as follows.
Create the determining system as described above. Make the appropriate
assignments for the generator and call PRSYS() after that.  The
determining system with this ansatz substituted is returned.  Example:
Assume again that the determining system for the diffusion equation
has been created. To check the correctness for example of generator GEN
3 which has been obtained above, the assignments

\begin{verbatim}
  XI(1):=0;  XI(2):=2*X(1);  ETA(1):=X(2)*U(1);
\end{verbatim}

have to be made. If now PRSYS() is called all GL(K) are zero
proving the correctness of this generator.

Sometimes a user only wants to know some of the functions ZETA for for
various values of its possible arguments and given values of MM and
NN. In these cases the user has to assign the desired values of MM and
NN and may call the ZETA's after that. Example:

\begin{verbatim}
  MM:=1;  NN:=2;

  FACTOR U(1,2),U(1,1),U(1,1,2),U(1,1,1);

  ON LIST;

  ZETA(1,1);

  -U(1,2)*U(1,1)*DF(XI(2),U(1))

  -U(1,2)*DF(XI(2),X(1))

         2
  -U(1,1) *DF(XI(1),U(1))

  +U(1,1)*(DF(ETA(1),U(1)) -DF(XI(1),X(1)))

  +DF(ETA(1),X(1))


  ZETA(1,1,1);

  -2*U(1,1,2)*U(1,1)*DF(XI(2),U(1))

  -2*U(1,1,2)*DF(XI(2),X(1))

  -U(1,1,1)*U(1,2)*DF(XI(2),U(1))

  -3*U(1,1,1)*U(1,1)*DF(XI(1),U(1))

  +U(1,1,1)*(DF(ETA(1),U(1)) -2*DF(XI(1),X(1)))

                2
  -U(1,2)*U(1,1) *DF(XI(2),U(1),2)

  -2*U(1,2)*U(1,1)*DF(XI(2),U(1),X(1))

  -U(1,2)*DF(XI(2),X(1),2)

         3
  -U(1,1) *DF(XI(1),U(1),2)

         2
  +U(1,1) *(DF(ETA(1),U(1),2) -2*DF(XI(1),U(1),X(1)))

  +U(1,1)*(2*DF(ETA(1),U(1),X(1)) -DF(XI(1),X(1),2))

  +DF(ETA(1),X(1),2)
\end{verbatim}

If by error no values to MM or NN and have been assigned the message

\begin{verbatim}
  ***** Number of variables not defined
\end{verbatim}

is returned. Often the functions ZETA are desired for special values
of its arguments ETA(ALFA) and XI(K). To this end they have to be
assigned first to some other variable. After that they may be
evaluated for the special arguments. In the previous example this may
be achieved by

\begin{verbatim}
  Z11:=ZETA(1,1)$   Z111:=ZETA(1,1,1)$
\end{verbatim}

Now assign the following values to XI 1, XI 2 and ETA 1:

\begin{verbatim}
  XI 1:=4*X(1)**2; XI 2:=4*X(2)*X(1);

  ETA 1:=U(1)*(X(2)**2  - 2*X(1));
\end{verbatim}

They correspond to the generator GEN 6 of the diffusion equation which
has been obtained above. Now the desired expressions are obtained by
calling

\begin{verbatim}
  Z11;

                               2
 - (4*U(1,2)*X(2) - U(1,1)*X(2)  + 10*U(1,1)*X(1) + 2*U(1))

  Z111;

                                   2
 - (8*U(1,1,2)*X(2) - U(1,1,1)*X(2)  + 18*U(1,1,1)*X(1) +
   12*U(1,1))
\end{verbatim}


\section{Test File}

This appendix is a test file. The symmetry groups for various
equations or systems of equations are determined. The variable PCLASS
has the default value 0 and may be changed by the user before running
it. The output may be compared with the results which are given in the
references.

\begin{verbatim}
%The Burgers equations

deq 1:=u(1,1)+u 1*u(1,2)+u(1,2,2)$

cresys deq 1$ simpsys()$ result()$

%The Kadomtsev-Petviashvili equation

deq 1:=3*u(1,3,3)+u(1,2,2,2,2)+6*u(1,2,2)*u 1

       +6*u(1,2)**2+4*u(1,1,2)$

cresys deq 1$ simpsys()$ result()$

%The modified Kadomtsev-Petviashvili equation

deq 1:=u(1,1,2)-u(1,2,2,2,2)-3*u(1,3,3)

       +6*u(1,2)**2*u(1,2,2)+6*u(1,3)*u(1,2,2)$

cresys deq 1$ simpsys()$ result()$

%The real- and the imaginary part of the nonlinear
%Schroedinger equation

deq 1:= u(1,1)+u(2,2,2)+2*u 1**2*u 2+2*u 2**3$

deq 2:=-u(2,1)+u(1,2,2)+2*u 1*u 2**2+2*u 1**3$

%Because this is not a single equation the two assignments

sder 1:=u(2,2,2)$  sder 2:=u(1,2,2)$

%are necessary.

cresys()$ simpsys()$ result()$

%The symmetries of the system comprising the four equations

deq 1:=u(1,1)+u 1*u(1,2)+u(1,2,2)$

deq 2:=u(2,1)+u(2,2,2)$

deq 3:=u 1*u 2-2*u(2,2)$

deq 4:=4*u(2,1)+u 2*(u 1**2+2*u(1,2))$

sder 1:=u(1,2,2)$ sder 2:=u(2,2,2)$ sder 3:=u(2,2)$
sder 4:=u(2,1)$

%is obtained by calling

cresys()$ simpsys()$

df(c 5,x 1):=-df(c 5,x 2,2)$

df(c 5,x 2,x 1):=-df(c 5,x 2,3)$

simpsys()$  result()$

% The symmetries of the subsystem comprising equation 1
%  and 3 are obtained by

cresys(deq 1,deq 3)$ simpsys()$ result()$

% The result for all possible subsystems is discussed in
% detail in ``Symmetries and Involution Systems: Some
% Experiments in Computer Algebra'', contribution to the
% Proceedings of the Oberwolfach Meeting on Nonlinear
% Evolution Equations, Summer 1986, to appear.
\end{verbatim}
\end{document}

Added r34.1/doc/sum.tex version [e1895bb9f1].













































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
\documentstyle[11pt,reduce]{article}
\title{The REDUCE Sum Package \\ Ver 1.0 9 Oct 1989}
\date{}
\author{Fujio Kako \\ Department of Mathematics \\ Faculty of Science \\
Hiroshima University \\ Hiroshima 730, JAPAN \\
E-mail: kako@kako.math.sci.hiroshima-u.ac.jp \\ or \\
D52789@JPNKUDPC.BITNET}
\begin{document}
\maketitle
\index{Gosper's Algorithm} \index{SUM operator} \index{PROD operator}
This package implements the Gosper algorithm for the summation of series.
It defines operators SUM and PROD.  The operator SUM returns the indefinite
or definite summation of a given expression, and the operator PROD returns
the product of the given expression.  These are used with the syntax:

\vspace{.1in}
\noindent {\tt SUM}(EXPR:{\em expression}, K:{\em kernel},
[LOLIM:{\em expression} [, UPLIM:{\em expression}]])
\vspace{.1in}
\noindent {\tt PROD}(EXPR:{\em expression}, K:{\em kernel},
[LOLIM:{\em expression} [, UPLIM:{\em expression}]])

If there is no closed form solution, these operators return the input
unchanged.  UPLIM and LOLIM are optional parameters specifying the lower
limit and upper limit of the summation (or product), respectively.  If UPLIM
is not supplied, the upper limit is taken as K (the summation variable
itself).

For example:

\begin{verbatim}
     sum(n**3,n);

     sum(a+k*r,k,0,n-1);

     sum(1/((p+(k-1)*q)*(p+k*q)),k,1,n+1);

     prod(k/(k-2),k);
\end{verbatim}

Gosper's algorithm succeeds whenever the ratio of

\[ \frac{\sum_{k=n_0}^n f(k)}{\sum_{k=n_0}^{n-1} f(k)} \]

\noindent is a rational function of $n$.  The function SUM!-SQ
handles basic functions such as polynomials, rational functions and
exponentials. \ttindex{SUM-SQ}

The trigonometric functions sin, cos, etc. are converted to exponentials
and then Gosper's algorithm is applied.  The result is converted back into
sin, cos, sinh and cosh.

Summations of logarithms or products of exponentials are treated by the
formula:

\vspace{.1in}
\hspace*{2em} \[ \sum_{k=n_0}^{n} \log f(k) = \log \prod_{k=n_0}^n f(k) \]
\vspace{.1in}
\hspace*{2em} \[ \prod_{k=n_0}^n \exp f(k) = \exp \sum_{k=n_0}^n f(k) \]
\vspace{.1in}

Other functions, as shown in the test file for the case of binomials and
formal products, can be summed by providing LET rules which must relate the
functions evaluated at $k$ and $k - 1$ ($k$ being the summation variable).

\index{tracing ! SUM package} \ttindex{TRSUM}
There is a switch TRSUM (default OFF).  If this switch is on, trace
messages are printed out during the course of Gosper's algorithm.

\end{document}

Added r34.1/doc/taylor.tex version [c59d58e114].































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
\documentstyle[11pt,reduce]{article}
\newcommand{\MACSYMA}{{\sf MACSYMA}}
\newcommand{\MAPLE}{{\sf MAPLE}}
\newcommand{\Mathematica}{{\sf Mathematica}}
\newcommand{\PSL}{{\sf PSL}}
\title{A \REDUCE{} package for manipulation of Taylor series}
\date{}
\author{Rainer Sch\"opf\\
        Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin\\
        Heilbronner Str.\ 10\\
        W-1000 Berlin 31\\
        Federal Republic of Germany\\
        Email: {\tt Schoepf@sc.ZIB-Berlin.de}}
\begin{document}
\maketitle
\index{Taylor Series} \index{TAYLOR package}
\index{Laurent series}

This short note describes a package of \REDUCE{} procedures that allow
Taylor expansion in one or more variables and efficient manipulation
of the resulting Taylor series. Capabilities include basic operations
(addition, subtraction, multiplication and division) and also
application of certain algebraic and transcendental functions. To a
certain extent, Laurent expansion can be performed as well.

\section{Introduction}

The Taylor package was written to provide \REDUCE{} with some of
the facilities
that \MACSYMA's \verb+TAYLOR+ function offers,
but most of all I needed it to be faster and
more space-efficient.
Especially I wanted procedures that would return the logarithm or
arc tangent of a Taylor series, again as a Taylor series.
This turned out be more work than expected. The features absolutely
required were (as usual) those that were hardest to implement,
e.g., arc tangent applied to a Taylor expansion in more than
one variable.

This package is still undergoing development.
I'll be happy if it is of any use for you.
Tell me if you think that there is something missing.
I invite everybody to criticize and comment and will eagerly try to
correct any errors found.

\section{How to use it}

The most important operator is `\verb+TAYLOR+'. \index{TAYLOR operator}
It is used as follows:

\noindent {\tt TAYLOR}(EXP:{\em exprn}[,VAR:{\em kernel},
            VAR$_0$:{\em exprn},ORDER:{\em integer}]\ldots):{\em exprn}

where EXP is the expression to be expanded. It can be any \REDUCE{}
object, even an expression containing other Taylor kernels.  VAR is
the kernel with respect to which EXP is to be expanded. VAR$_0$
denotes the point about which and ORDER the order up to which
expansion is to take place. If more than one (VAR, VAR0, ORDER) triple
is specified {\tt TAYLOR} will expand its first argument independently
with respect to all the variables. For example,

\begin{verbatim}
  taylor(e^(x^2+y^2),x,0,2,y,0,2);
\end{verbatim}

will calculate the Taylor expansion up to order $X^{2}*Y^{2}$.
Note that once the expansion has been done it is not possible to 
calculate higher orders.
Instead of a kernel, VAR may also
be a list of kernels. In this case expansion will take place in a way
so that the {\em sum\/} of the degrees of the kernels does not exceed
ORDER.
If VAR$_0$ evaluates to the special identifier \verb|INFINITY|
{\tt TAYLOR} tries to expand EXP in a series in 1/VAR.

The expansion is performed variable per variable, i.e.\ in the example
above by first expanding $\exp(x^{2}+y^{2})$ with respect to $x$ and
then expanding every coefficient with respect to $y$.

\index{TAYLORPRINTTERMS variable}
Only a certain number of (non-zero) coefficients are printed. If there
are more, \verb|...| is printed as part of the expression to indicate
this. The number of terms printed is given by the value of the shared
algebraic variable \verb|TAYLORPRINTTERMS|.  Allowed values are
integers and the special identifier \verb|ALL|. The latter setting
specifies that all terms are to be printed. The default setting is
$5$.


\index{TAYLORKEEPORIGINAL switch}
If the switch \verb|TAYLORKEEPORIGINAL| is set to \verb|ON| the
original expression EXP is kept for later reference.
It can be recovered by means of the operator

\hspace*{2em} {\tt TAYLORORIGINAL}(EXP:{\em exprn}):{\em exprn}

An error is signalled if EXP is not a Taylor kernel or if the original
expression was not kept, i.e.\ if \verb|TAYLORKEEPORIGINAL| was
\verb|OFF| during expansion.  The template of a Taylor kernel, i.e.\
the list of all variables with respect to which expansion took place
together with expansion point and order can be extracted using
\ttindex{TAYLORTEMPLATE}

\hspace*{2em} {\tt TAYLORTEMPLATE}(EXP:{\em exprn}):{\em list}

This returns a list of lists with the three elements (VAR,VAR0,ORDER)
as with \verb|TAYLORORIGINAL|,
an error is signalled if EXP is not a Taylor kernel.

\hspace*{2em} {\tt TAYLORTOSTANDARD}(EXP:{\em exprn}):{\em exprn}

converts all Taylor kernels in EXP into standard form and
\ttindex{TAYLORTOSTANDARD} resimplifies the result.

\hspace*{2em} {\tt TAYLORSERIESP}(EXP:{\em exprn}):{\em boolean}

may be used to determine if EXP is a Taylor kernel.
\ttindex{TAYLORSERIESP} Note that this operator is subject to the same
restrictions as, e.g., ORDP or NUMBERP, i.e.\ it may only be used in
boolean expressions in \verb|IF| or \verb|LET| statements.  Finally
there is

\hspace*{2em} {\tt TAYLORCOMBINE}(EXP:{\em exprn}):{\em exprn}

which tries to combine all Taylor kernels found in EXP into one.
\ttindex{TAYLORCOMBINE}
Operations currently possible are:
\index{Taylor series ! arithmetic} 
\begin{itemize}
  \item Addition, subtraction, multiplication, and division.
  \item Roots, exponentials, and logarithms.
  \item Trigonometric and hyperbolic functions and their inverses.
\end{itemize}
Application of unary operators like \verb|LOG| and \verb|ATAN| will
nearly always succeed. For binary operations their arguments have to be
Taylor kernels with the same template. This means that the expansion
variable and the expansion point must match. Expansion order is not so
important, different order usually means that one of them is truncated
before doing the operation.

\ttindex{TAYLORKEEPORIGINAL} \ttindex{TAYLORCOMBINE}
If \verb|TAYLORKEEPORIGINAL| is set to \verb|ON| and if all Taylor
kernels in \verb|exp| have their original expressions kept
\verb|TAYLORCOMBINE| will also combine these and store the result
as the original expression of the resulting Taylor kernel.
\index{TAYLORAUTOEXPAND switch}
There is also the switch \verb|TAYLORAUTOEXPAND| (see below).

There are a few restrictions to avoid mathematically undefined
expressions: it is not possible to take the logarithm of a Taylor
kernel whose constant term is zero, or to divide by a Taylor kernel
that consists only of the constant zero.  There are, however, some
provisions made to detect singularities during expansion: poles that
arise because the denominator has zeros at the expansion point are
detected and properly treated, i.e.\ the Taylor kernel will start with
a negative power.  (This is accomplished by expanding numerator and
denominator separately and combining the results.)  It has been
observed, however, that this does {\em not\/} work if the \verb|MCD|
switch is set to \verb|OFF|.  This seems to be a limitation of
\REDUCE{} version 3.4.  Essential singularities are not handled at all
which means that usually some sort of error will be signalled. Maybe I
can improve this later.

\index{Taylor series ! differentiation}
Differentiation of a Taylor expression is possible.  If you
differentiate with respect to one of the Taylor variables the order
will decrease by one. 

\index{Taylor series ! substitution}
Substitution is a bit restricted: Taylor variables can only be replaced
by other kernels.  There is one exception to this rule: you can always
substitute a Taylor variable by an expression that evaluates to a
constant.  Note that \REDUCE{} will not always be able to determine
that an expression is constant:  an example is \verb|SIN(ACOS(4))|.

\index{Taylor series ! integration}
Only simple taylor kernels can be integrated. More complicated
expressions that contain Taylor kernels as parts of themselves are
automatically converted into a standard representation by means of the
TAYLORTOSTANDARD operator. In this case a suitable warning is printed.

\index{Taylor series ! reversion} It is possible to revert a Taylor
series of a function $f$, i.e., to compute the first terms of the
expansion of the inverse of $f$ from the expansion of $f$. This is
done by the operator

\hspace*{2em} {\tt TAYLORREVERT}(EXP:{\em exprn},OLDVAR:{\em kernel},
                                 NEWVAR:{\em kernel}):{\em exprn}

EXP must evaluate to a Taylor kernel with OLDVAR being one of its
expansion variables. Example:

\begin{verbatim}
  taylor (u - u**2, u, 0, 5);
  taylorrevert (ws, u, x);
\end{verbatim}

This packages introduces a number of new switches:
\begin{itemize}

\index{TAYLORAUTOCOMBINE switch}
\item If you set \verb|TAYLORAUTOCOMBINE| to \verb|ON| \REDUCE{}
    automatically combines Taylor expressions during the simplification
    process.  This is equivalent to applying \verb|TAYLORCOMBINE| to
    every expression that contains Taylor kernels.
    Default is \verb|OFF|.

\index{TAYLORAUTOEXPAND switch}
\item \verb|TAYLORAUTOEXPAND| makes Taylor expressions ``contagious''
    in the sense that \verb|TAYLORCOMBINE| tries to Taylor expand
    all non-Taylor subexpressions and to combine the result with the
    rest. Default is \verb|OFF|.

\index{TAYLORKEEPORIGINAL switch}
\item \verb|TAYLORKEEPORIGINAL|, if set to \verb|ON|, forces the
    package to keep the original expression, i.e.\ the expression
    that was Taylor expanded.  All operations performed on the
    Taylor kernels are also applied to this expression  which can
    be recovered using the operator \verb|TAYLORORIGINAL|.
    Default is \verb|OFF|.

\index{TAYLORPRINTORDER switch}
\item \verb|TAYLORPRINTORDER|, if set to \verb|ON|, causes the
    remainder to be printed in big-$O$ notation.  Otherwise, three
    dots are printed. Default is \verb|ON|.

\index{VERBOSELOAD switch}
\item There is also the switch \verb|VERBOSELOAD|.  If it is set to
    \verb|ON|
    \REDUCE{} will print some information when the Taylor package is
    loaded.  This switch is already present in \PSL{} systems.
    Default is \verb|OFF|.

\end{itemize}
\index{defaults ! TAYLOR package}

\section{Caveats}
\index{caveats ! TAYLOR package}

\verb|TAYLOR| does not always detect non-analytical expressions in
its first argument.
In this case a wrong result will be given that depends on the order
of Taylor variables in the call to \verb|TAYLOR|.
An example for this behavior is given by the function $xy/(x+y)$ that is
not analytical in the neighborhood of $(x,y) = (0,0)$:
Trying to calculate
\begin{verbatim}
  taylor(x*y/(x+y),x,0,2,y,0,2);
\end{verbatim}
we get as result $X-X^{2}/Y$.
The reason for this is as follows:
\verb|TAYLOR| first expands it with respect to $X$ about $0$
up to order $2$ giving $X - X^{2}/Y$.
This has only a simple pole in $Y$ at $0$ and is therefore returned as
result.
If we interchange \verb|X| and \verb|Y| in the call to \verb|TAYLOR|
they are also interchanged in the result.
At the moment I don't know a general method to detect non-analytical
expressions in the argument to \verb|TAYLOR|.

Note that it is not generally possible to apply the standard \REDUCE{}
operators to a Taylor kernel. For example, \verb|PART|, \verb|COEFF|,
or \verb|COEFFN| cannot be used. Instead, the expression at hand has
to be converted to standard form first using the \verb|TAYLORTOSTANDARD|
operator.

\section{Warnings and error messages}
\index{errors ! TAYLOR package}
\begin{itemize}

\item \verb|Branch point detected in ...|\\
    This occurs if you take a rational power of a Taylor kernel
    and raising the lowest order term of the kernel to this
    power yields a non analytical term (i.e.\ a fractional power).

\item \verb|Cannot expand further... truncation done|\\
    You will get this warning if you try to expand a Taylor kernel to
    a higher order.

\item \verb|Converting Taylor kernels to standard representation|\\
    This warning appears if you try to integrate an expression that
    contains Taylor kernels.

\item \verb|Error during expansion (possible singularity)|\\
    The expression you are trying to expand caused an error.
    As far as I know this can only happen if it contains a function
    with a pole or an essential singularity at the expansion point.
    (But one can never be sure.)

\item \verb|Essential singularity in ...|\\
    An essential singularity was detected while applying a
    special function to a Taylor kernel.
    This error occurs, for example, if you try to take
    the logarithm of a Taylor kernel that starts with a negative
    power in one of its variables, i.e.\ that has a pole
    at the expansion point.

\item \verb|Expansion point lies on branch cut in ...|\\
    The only functions with branch cuts this package knows of are
    (natural) logarithm, inverse circular and hyperbolic tangent and
    cotangent.  The branch cut of the logarithm is assumed to lie on
    the negative real axis.  Those of the arc tangent and arc
    cotangent functions are chosen to be compatible with this: both
    have essential singularities at the points $\pm i$.  The branch
    cut of arc tangent is the straight line along the imaginary axis
    connecting $+1$ to $-1$ going through $\infty$ whereas that of arc
    cotangent goes through the origin.  Consequently, the branch cut
    of the inverse hyperbolic tangent resp.\ cotangent lies on the
    real axis and goes from $-1$ to $+1$, that of the latter across
    $0$, the other across $\infty$.
    
    The error message can currently only appear when you try to
    calculate the inverse tangent or cotangent of a Taylor
    kernel that starts with a negative degree.
    The case of a logarithm of a Taylor kernel whose constant term
    is a negative real number is not caught since it is
    difficult to detect this in general.

\item \verb|Integration of Taylor kernel yields non-analytical term|\\
    Since it is assumed that a Taylor kernel can be integrated term-wise
    to yield another Taylor kernel,
    it is an error if a logarithmic term would appear in the result.

\item \verb|Not a unity in ...|\\
    This will happen if you try to divide by or take the logarithm of 
    a Taylor series whose constant term vanishes.

\item \verb|Not implemented yet (...)|\\
    Sorry, but I haven't had the time to implement this feature.
    Tell me if you really need it, maybe I have already an improved
    version of the package.

\item \verb|Substitution of dependent variables ...|\\
    You tried to substitute a variable that is already present in the
    Taylor kernel or on which one of the Taylor variables depend.

\item \verb|Taylor kernel doesn't have an original part|\\
\ttindex{TAYLORORIGINAL} \ttindex{TAYLORKEEPORIGINAL}
    The Taylor kernel upon which you try to use \verb|TAYLORORIGINAL|
    was created with the switch \verb|TAYLORKEEPORIGINAL|
    set to \verb|OFF|
    and does therefore not keep the original expression.

\item \verb|Wrong number of arguments (TAYLOR)|\\
    You try to use the operator \verb|TAYLOR| with a wrong number of
    arguments.

\item \verb|Zero divisor in Taylor substitution|\\
    That's exactly what the message says.  As an example consider the
    case of a Taylor kernel containing the term \verb|1/x| and you try
    to substitute \verb|x| by \verb|0|.

\item \verb|... invalid as kernel|\\
    You tried to expand with respect to an expression that is not a
    kernel.

\item \verb|... invalid as order of expansion|\\
    The order parameter you gave to \verb|TAYLOR| is not an integer.

\item \verb|... invalid as Taylor kernel|\\
\ttindex{TAYLORORIGINAL} \ttindex{TAYLORTEMPLATE}
    You tried to apply \verb|TAYLORORIGINAL| or \verb|TAYLORTEMPLATE|
    to an expression that is not a Taylor kernel.

\item \verb|... invalid as Taylor variable|\\
    You tried to substitute a Taylor variable by an expression that is
    not a kernel.

\item \verb|... invalid as value of TaylorPrintTerms|\\
\ttindex{TAYLORPRINTTERMS} 
    You have assigned an invalid value to \verb|TAYLORPRINTTERMS|.
    Allowed values are: an integer or the special identifier
    \verb|ALL|.

\item \verb|TAYLOR PACKAGE (...): this can't happen ...|\\
    This message shows that an internal inconsistency was detected.
    This is not your fault, at least as long as you did not try to
    work with the internal data structures of \REDUCE. Send input
    and output to me, together with the version information that is
    printed out.

\end{itemize}

\section{Comparison to other packages}

At the moment there is only one \REDUCE{} package that I know of:
the truncated power series package by Alan Barnes and Julian Padget.
In my opinion there are two major differences:
\begin{itemize}
  \item The interface. They use the domain mechanism for their power
        series, I decided to invent a special kind of kernel. Both
        approaches have advantages and disadvantages: with domain
        modes, it is easier
        to do certain things automatically, e.g., conversions.
  \item The concept of a truncated series. Their idea is to remember
        the original expression and to compute more coefficients when
        more of them are needed. My approach is to truncate at a
        certain order and forget how the unexpanded expression
        looked like.  I think that their method is more widely
        usable, whereas mine is more efficient when you know in
        advance exactly how many terms you need.
\end{itemize}

\MACSYMA{} has Taylor and power series packages.  I don't know much
about the general power series package but the Taylor package has some
features that are still lacking here, e.g., correct treatment of
known essential singularities.  In \MACSYMA{} a Taylor series is a
special object, a sort of extended rational expression recognized by
all simplification functions.  They also have a better user interface. 
E.g., you may define the Taylor expansion of an unknown function. 

\Mathematica's \verb|series| function can only handle power series of
one variable.  However, it is better in its handling of singularities.

\end{document}

Added r34.1/doc/tps.tex version [f9c539ba50].













































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
\documentstyle[11pt,reduce]{article}
\title{Truncated Power Series}
\date{}
\author{Alan Barnes \\ Dept. of Computer Science and Applied Mathematics \\
Aston University, Aston Triangle, \\
Birmingham B4 7ET \\ GREAT BRITAIN \\
Email: barnesa@kirk.aston.ac.uk \\[0.1in]
and \\[0.1in]
Julian Padget \\
School of Mathematics, University of Bath \\
Claverton Down, Bath, BA2 7AY \\
GREAT BRITAIN \\
Email: jap@maths.bath.ac.uk}
\begin{document}
\maketitle
\index{power series} \index{truncated power series}
\index{Barnes, Alan} \index{Padget, Julian}
\section{Introduction}
\index{Laurent series expansions}
This package implements formal Laurent series expansions in one
variable using the domain mechanism of REDUCE. This means that power
series objects can be added, multiplied, differentiated etc. like other
first class objects in the system. A lazy evaluation scheme is used in
the package and thus terms of the series are not evaluated until they
are required for printing or for use in calculating terms in other
power series. The series are extendible giving the user the impression
that the full infinite series is being manipulated.  The errors that
can sometimes occur using series that are truncated at some fixed depth
(for example when a term in the required series depends on terms of an
intermediate series beyond the truncation depth) are thus avoided.

Below we give a brief description of the operators available in the
power series package together with some examples of their use.

\subsection{PS Operator}

Syntax:

\noindent{\tt PS}(EXPRN:{\em algebraic},DEPVAR:{\em kernel},ABOUT:{\em algebraic}):{\em ps object}

\index{PS operator}
The {\tt PS} operator returns a  power series object (a tagged domain element)
representing the univariate formal power series expansion of EXPRN with
respect to the dependent variable DEPVAR about the expansion point
ABOUT.  EXPRN may itself contain power series objects.

The algebraic expression ABOUT should simplify to an expression
which is independent of the dependent variable DEPVAR, otherwise
an error will result.  If ABOUT is the identifier {\tt INFINITY}
then the power series expansion about DEPVAR = $\infty$ is
obtained in ascending powers of 1/DEPVAR.

\index{PSEXPLIM operator}
If the command is terminated by a semi-colon, a power series object
representing EXPRN is compiled and then a number of terms of the
power series expansion are evaluated and printed.  The expansion is
carried out as far as the value specified by {\tt PSEXPLIM}.  If,
subsequently, the value of {\tt PSEXPLIM} is increased, sufficient
information is stored in the power series object to enable the
additional terms to be calculated without recalculating the terms
already obtained.

If the command is terminated by a dollar symbol, a power series object
is compiled, but at most one term is calculated at this stage.

If the function has a pole at the expansion point then the correct
Laurent series expansion will be produced.

\noindent The following examples are valid uses of {\tt PS}:
\begin{verbatim}
    psexplim 6;
    ps(log x,x,1);
    ps(e**(sin x),x,0);
    ps(x/(1+x),x,infinity);
    ps(sin x/(1-cos x),x,0);
\end{verbatim}

\index{power series ! of user defined function}
New user-defined functions may be expanded provided the user provides
LET rules giving

\begin{enumerate}
\item the value of the function at the expansion point
\item a differentiation rule for the new function.
\end{enumerate}

\noindent For example
\begin{verbatim}
    operator sech;
    forall x let df(sech x,x)= - sech x * tanh x;
    let sech 0 = 1;
    ps(sech(x**2),x,0);
\end{verbatim}
 
\index{power series ! of integral}
The power series expansion of an integral may also be obtained (even if
REDUCE cannot evaluate the integral in closed form).  An example of
this is

\begin{verbatim}
    ps(int(e**x/x,x),x,1);
\end{verbatim}
 
Note that if the integration variable is the same as the expansion
variable then REDUCE's integration package is not called; if on the
other hand the two variables are different then the integrator is
called to integrate each of the coefficients in the power series
expansion of the integrand.  The constant of integration is zero by
default.  If another value is desired, then the shared variable {\tt
PSINTCONST} should be set to required value. \index{PSINTCONST (shared)}

For example in algebraic mode
\begin{verbatim}
        psintconst:=a**2;
\end{verbatim}

would set the value of this constant to be (the value of) {\tt A**2}.
The setting of this constant has no effect on the value returned by
the REDUCE integrator. If the expansion and integration variables are
the same and {\tt PSINTCONST} depends on this variable an error
results.
 
 
\subsection{PSEXPLIM Operator}

\index{PSEXPLIM Operator}
Syntax:

\hspace*{2em} {\tt PSEXPLIM}(UPTO:{\em integer}):{\em integer}

\hspace*{4em} or

\hspace*{2em} {\tt PSEXPLIM}():{\em integer}

Calling this operator sets an internal variable of the
TPS package to the value of UPTO (which should evaluate to an integer).
The value returned is the previous value of this variable. The default value
is six.
 
If {\tt PSEXPLIM} is called with no argument, the current value for
the expansion limit is returned.
 

\subsection{PSORDLIM Operator}

\index{PSORDLIM operator}
Syntax:

\hspace*{2em} {\tt PSORDLIM}(UPTO:{\em integer}):{\em integer}

\hspace*{4em} or

\hspace*{2em} {\tt PSORDLIM}():{\em integer}

An internal variable is set to the value of {\tt UPTO} (which should
evaluate to an integer). The value returned is the previous value of
the variable.  The default value is 15.

If {\tt PSORDLIM} is called with no argument, the current value is
returned.

The significance of this control is that the system attempts to find
the order of the power series required, that is the order is the
degree of the first non-zero term in the power series.  If the order
is greater than the value of this variable an error message is given
and the computation aborts. This prevents infinite loops in examples
such as

\begin{verbatim}
        ps(1 - (sin x)**2 - (cos x)**2,x,0);
\end{verbatim}

where the expression being expanded is identically zero, but is not
recognized as such by REDUCE.


\subsection{PSTERM Operator}

\index{PSTERM operator}
Syntax:

\hspace*{2em} {\tt PSTERM}(TPS:{\em power series object},NTH:{\em integer}):{\em algebraic}

The operator {\tt PSTERM} returns the NTH term of the existing
power series object TPS. If NTH does not evaluate to
an integer or TPS to a power series object an error results.  It
should be noted that an integer is treated as a power series.


\subsection{PSORDER Operator}

\index{PSORDER operator}
Syntax:

\hspace*{2em} {\tt PSORDER}(TPS:{\em power series object}):{\em integer}

The operator {\tt PSORDER} returns the order, that is the degree of
the first non-zero term, of the power series object TPS.
TPS should evaluate to a power series object or an error results. If
TPS is zero, the identifier {\tt UNDEFINED} is returned.

\subsection{PSSETORDER Operator}

\index{PSSETORDER operator}
Syntax:

\hspace*{2em} {\tt PSSETORDER}(TPS:{\em power series object}, ORD:{\em integer}):{\em integer}

The operator {\tt PSSETORDER} sets the order of the power series TPS to the
value ORD, which should evaluate to an integer. If
TPS does not evaluate to a power series object, then an error
occurs. The value returned by this operator is the previous order of
TPS, or 0 if the order of TPS was undefined.  This
operator is useful for setting the order of the power series of a
function defined by a differential equation in cases where the power
series package is inadequate to determine the order automatically.


\subsection{PSDEPVAR Operator}

\index{PSDEPVAR operator}
Syntax:

\hspace*{2em} {\tt PSDEPVAR}(TPS:{\em power series object}):{\em identifier}

The operator {\tt PSDEPVAR} returns the expansion variable of the
power series object TPS. TPS should evaluate to a power
series object or an integer, otherwise an error results. If TPS
is an integer, the identifier {\tt UNDEFINED} is returned.

\subsection{PSEXPANSIONPT operator}

\index{PSEXPANSIONPT operator}
Syntax:

\hspace*{2em} {\tt PSEXPANSIONPT}(TPS:{\em power series object}):{\em algebraic}

The operator {\tt PSEXPANSIONPT} returns the expansion point of the
power series object TPS. TPS should evaluate to a power
series object or an integer, otherwise an error results. If TPS
is integer, the identifier {\tt UNDEFINED} is returned. If the
expansion is about infinity, the identifier {\tt INFINITY} is
returned.

\subsection{PSFUNCTION Operator}

\index{PSFUNCTION operator}
Syntax:

\hspace*{2em} {\tt PSFUNCTION}(TPS:{\em power series object}):{\em algebraic}

The operator {\tt PSFUNCTION} returns the function whose expansion
gave rise to the power series object TPS. TPS should
evaluate to a power series object or an integer, otherwise an error
results.

\subsection{PSCHANGEVAR Operator}

\index{PSCHANGEVAR operator}
Syntax:

\hspace*{2em} {\tt PSCHANGEVAR}(TPS:{\em power series object}, X:{\em kernel}):{\em power series object}

The operator {\tt PSCHANGEVAR} changes the dependent variable of the
power series object TPS to the variable X. TPS
should evaluate to a power series object and X to a kernel,
otherwise an error results.  Also X should not appear as a
parameter in TPS. The power series with the new dependent
variable is returned.

\subsection{PSREVERSE Operator}

\index{PSREVERSE operator}
Syntax:

\hspace*{2em} {\tt PSREVERSE}(TPS:{\em power series object}):{\em power series}

Power series reversion.  The power series TPS is functionally
inverted.  Four cases arise:

\begin{enumerate}
\item If the order of the series is 1, then the expansion point of the
inverted series is 0. 

\item If the order is 0 {\em and} if the first order term in TPS
is non-zero, then the expansion point of the inverted series is taken
to be the coefficient of the zeroth order term in TPS.

\item If the order is -1 the expansion point of the inverted series
is the point at infinity.  In all other cases a REDUCE error is
reported because the series cannot be inverted as a power series. Puiseux
\index{Puiseux expansion} expansion would be required to handle these cases.

\item If the expansion point of TPS is finite it becomes the
zeroth order term in the inverted series. For expansion about 0 or the
point at infinity the order of the inverted series is one.
\end{enumerate}

If TPS is not a power series object after evaluation an error results.

\noindent Here are some examples:
\begin{verbatim}
        ps(sin x,x,0);
        psreverse(ws); % produces series for asin x about x=0.
        ps(exp x,x,0);
        psreverse ws; % produces series for log x about x=1.
        ps(sin(1/x),x,infinity);
        psreverse(ws); % produces series for 1/asin(x) about x=0.
\end{verbatim}

\subsection{PSCOMPOSE Operator}

\index{PSCOMPOSE operator}
Syntax:

\hspace*{2em} {\tt PSCOMPOSE}(TPS1:{\em power series}, TPS2:{\em power series}):{\em power series}

\index{power series ! composition}
{\tt PSCOMPOSE} performs power series composition.
The power series TPS1 and TPS2 are functionally composed.
That is to say that TPS2 is substituted for the expansion
variable in TPS1 and the result expressed as a power series. The
dependent variable and expansion point of the result coincide with
those of TPS2.  The following conditions apply to power series
composition:

\begin{enumerate}
\item If the expansion point of TPS1 is 0 then the order of the
TPS2 must be at least 1.

\item If the expansion point of TPS1 is finite, it should
coincide with the coefficient of the zeroth order term in TPS2.
The order of TPS2 should also be non-negative in this case.

\item If the expansion point of TPS1 is the point at infinity
then the order of TPS2 must be less than or equal to -1.

\end{enumerate}

If these conditions do not hold the series cannot be composed (with
the current algorithm terms of the inverted series would involve
infinite sums) and a REDUCE error occurs.

\noindent Examples of power series composition include the following.

\begin{verbatim}
    a:=ps(exp y,y,0);  b:=ps(sin x,x,0); 
    pscompose(a,b);
    % Produces the power series expansion of exp(sin x)
    % about x=0.

    a:=ps(exp z,z,1); b:=ps(cos x,x,0);
    pscompose(a,b);
    % Produces the power series expansion of exp(cos x)
    % about x=0.

    a:=ps(cos(1/x),x,infinity);  b:=ps(1/sin x,x,0);
    pscompose(a,b);
    % Produces the power series expansion of cos(sin x)
    % about x=0.
\end{verbatim}

\subsection{PSSUM Operator}

\index{PSSUM operator}
Syntax:

\begin{tabbing}
\hspace*{2em} {\tt PSSUM}(\=J:{\em kernel} = LOWLIM:{\em integer}, COEFF:{\em algebraic}, X:{\em kernel}, \\ 
\> ABOUT:{\em algebraic}, POWER:{\em algebraic}):{\em power series}
\end{tabbing}

The formal power series sum for J from LOWLIM to {\tt INFINITY} of 

\begin{verbatim}
      COEFF*(X-ABOUT)**POWER
\end{verbatim}

or if ABOUT is given as {\tt INFINITY}

\begin{verbatim}
      COEFF*(1/X)**POWER
\end{verbatim}

is constructed and returned. This enables power series whose general
term is known to be constructed and manipulated using the other
procedures of the power series package. 

J and X should be distinct simple kernels. The algebraics
ABOUT,  COEFF and POWER should not depend on the
expansion variable X, similarly the algebraic ABOUT should
not depend on the summation variable J.  The algebraic POWER should be
a strictly increasing integer valued function of J for J in the range
LOWLIM to {\tt INFINITY}.

\begin{verbatim}
   pssum(n=0,1,x,0,n*n);
   % Produces the power series summation for n=0 to
   % infinity of x**(n*n).

   pssum(m=1,(-1)**(m-1)/(2m-1),y,1,2m-1);
   % Produces the power series expansion of atan(y-1)
   % about y=1.

   pssum(j=1,-1/j,x,infinity,j);
   % Produces the power series expansion of log(1-1/x)
   % about the point at infinity.

   pssum(n=0,1,x,0,2n**2+3n) + pssum(n=1,1,x,0,2n**2-3n);
   % Produces the power series summation for n=-infinity
   % to +infinity of x**(2n**2+3n).
\end{verbatim}

\subsection{Arithmetic Operations}

\index{power series ! arithmetic}
As power series objects are domain elements they may be combined
together in algebraic expressions in algebraic mode of REDUCE in the
normal way.
 
For example if A and B are power series objects then the commands such as:

\index{+ ! power series} \index{- ! power series} \index{/ ! power series}
\index{* ! power series} \index{** ! power series}
\begin{verbatim}
    a*b;
    a**2+b**2;
\end{verbatim}

will produce power series objects representing the product and the sum
of the squares of the power series objects A and B respectively.
 
\subsection{Differentiation}

\index{power series ! differentiation}
If A is a power series object depending on X then the input
{\tt df(a,x);} will produce the power series expansion of the derivative
of A with respect to X.


\section{Restrictions and Known Bugs}

If A and B are power series objects and X is a variable
which evaluates to itself then currently expressions such as {\tt a/b} and
{\tt a*x} do not evaluate to a single power series object (although the
results are in each case formally valid).  Instead use {\tt ps(a/b,x,0)}
and {\tt ps(a*x,x,0)} {\em etc.}.  The failure of the system to simplify
quotients to a single power series is due to an infelicity in the REDUCE
simplifier which will be corrected in future releases of REDUCE.

Similarly expressions such as {\tt sin(A)} where {\tt A} is a PS object
currently will not be expanded. For example:

\begin{verbatim}
    a:=ps(1/(1+x),x,0);
    b:=sin a;
\end{verbatim}

will not expand {\tt sin(1/(1+x))} as a power series. In fact

\begin{verbatim}
          SIN(1 - X + X**2 - X**3 + .....)
\end{verbatim}

will be returned. However,

\begin{verbatim} 
    b:=ps(sin(a),x,0);
\end{verbatim}

or

\begin{verbatim} 
    b:=ps(sin(1/(1+x)),x,0);
\end{verbatim}

should work as intended.

The handling of functions with essential singularities is currently
erratic: usually an error message

\hspace*{2em} {\tt ***** Essential Singularity}

or

\hspace*{2em} {\tt ***** Logarithmic Singularity}

occurs but occasionally a division by
zero error or some drastic error like (for PSL) binding stack overflow may
occur.
 
Mixed mode arithmetic of power series objects with other domain
elements is quite restricted: only integers and floats can currently
be converted to power series objects.
 
The printing of power series currently leaves something to be
desired: often line-breaks appear in the middle of terms.

There is no simple way to write the results of power series
calculation to a file and read them back into REDUCE at a later
stage.
\end{document}

Added r34.1/lib/Makefile version [fbdfc79beb].



























































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
#
#  Makefile for REDUCE User Contributed Library (PSL Version)
#	
#  Author:  James H. Davenport <jhd@maths.bath.ac.uk>.
#
#  Modified by:  Anthony C. Hearn.
#
#  This Makefile may be used to build fast loading versions of all the
#  PSL REDUCE User Contributed Library packages, or any particular
#  package.  It assumes that the relevant source files are in the
#  $reduce/lib directory.  It is specific to PSL, and of course those
#  systems (e.g. UNIX) that support a make mechanism.  However, it can
#  be easily used with other systems with a make facility once a
#  suitable mkfasl script has been written.

REDUCE= /reduce
FASL  = b
BINDIR= $(REDUCE)/fasl
SRCDIR= $(REDUCE)/lib
TSTDIR= $(REDUCE)/lib
MKFASL= $(REDUCE)/util/mkfasl

PACKAGES= assist camal changevar cvit desir fide gnuplot laplace \
	  linineq numeric physop pm reacteqn reset rlfi showrules \
	  symmetry tri wu

UNCOMPILEDPACKAGES= odeex

TSTPACKAGES= assist camal changevar cvit desir fide laplace linineq \
	     numeric physop pmrules reacteqn rlfi symmetry tri wu

all:    $(PACKAGES)

assist: $(BINDIR)/assist.$(FASL)

$(BINDIR)/assist.$(FASL): $(SRCDIR)/assist.red
	$(MKFASL) assist lib


camal:  $(BINDIR)/camal.$(FASL)

$(BINDIR)/camal.$(FASL): $(SRCDIR)/camal.red
	$(MKFASL) camal lib


changevar:      $(BINDIR)/changevar.$(FASL)

$(BINDIR)/changevar.$(FASL): $(SRCDIR)/changevar.red
	$(MKFASL) changevar lib


cvit:   $(BINDIR)/cvit.$(FASL)

$(BINDIR)/cvit.$(FASL): $(SRCDIR)/cvit.red
	$(MKFASL) cvit lib


desir:  $(BINDIR)/desir.$(FASL)

$(BINDIR)/desir.$(FASL): $(SRCDIR)/desir.red
	$(MKFASL) desir lib


fide:   $(BINDIR)/fide1.$(FASL) $(BINDIR)/fide.$(FASL)

$(BINDIR)/fide1.$(FASL): $(SRCDIR)/fide1.red
	$(MKFASL) fide1 lib

$(BINDIR)/fide.$(FASL): $(SRCDIR)/fide.red
	$(MKFASL) fide lib


gnuplot:        $(BINDIR)/gnuplot.$(FASL)

$(BINDIR)/gnuplot.$(FASL): $(SRCDIR)/gnuplot.red
	$(MKFASL) gnuplot lib


laplace:        $(BINDIR)/laplace.$(FASL)

$(BINDIR)/laplace.$(FASL): $(SRCDIR)/laplace.red
	$(MKFASL) laplace lib


linineq: $(BINDIR)/linineq.$(FASL)

$(BINDIR)/linineq.$(FASL): $(SRCDIR)/linineq.red
	$(MKFASL) linineq lib


numeric:  $(BINDIR)/numeric.$(FASL)

$(BINDIR)/numeric.$(FASL): $(SRCDIR)/numeric.red
	$(MKFASL) numeric lib


physop: $(BINDIR)/noncom2.$(FASL) $(BINDIR)/physop.$(FASL)

$(BINDIR)/noncom2.$(FASL): $(SRCDIR)/noncom2.red
	$(MKFASL) noncom2 lib

$(BINDIR)/physop.$(FASL): $(SRCDIR)/physop.red
	$(MKFASL) physop lib


pm:     $(BINDIR)/pm.$(FASL) $(BINDIR)/pmrules.$(FASL)
#       $(BINDIR)/pmrules2.$(FASL)

$(BINDIR)/pm.$(FASL): $(SRCDIR)/pm.red
	$(MKFASL) pm lib

$(BINDIR)/pmrules.$(FASL): $(SRCDIR)/pmrules.red
	$(MKFASL) pmrules lib

# $(BINDIR)/pmrules2.$(FASL): $(SRCDIR)/pmrules2.red
#         $(MKFASL) pmrules2 lib


reacteqn: $(BINDIR)/reacteqn.$(FASL)

$(BINDIR)/reacteqn.$(FASL): $(SRCDIR)/reacteqn.red
	$(MKFASL) reacteqn lib


reset:  $(BINDIR)/reset.$(FASL)

$(BINDIR)/reset.$(FASL): $(SRCDIR)/reset.red
	$(MKFASL) reset lib


rlfi:   $(BINDIR)/rlfi.$(FASL)

$(BINDIR)/rlfi.$(FASL): $(SRCDIR)/rlfi.red
	$(MKFASL) rlfi lib


showrules:  $(BINDIR)/showrules.$(FASL)

$(BINDIR)/showrules.$(FASL): $(SRCDIR)/showrules.red
	$(MKFASL) showrules lib


symmetry: $(BINDIR)/symmetry.$(FASL)

$(BINDIR)/symmetry.$(FASL): $(SRCDIR)/symmetry.red
	$(MKFASL) symmetry lib


tri:  $(BINDIR)/tri.$(FASL)

$(BINDIR)/tri.$(FASL): $(SRCDIR)/tri.red
	$(MKFASL) tri lib


wu:     $(BINDIR)/wu.$(FASL)

$(BINDIR)/wu.$(FASL): $(SRCDIR)/wu.red
	$(MKFASL) wu lib

test:   $(PACKAGES)
	for i in $(TSTPACKAGES) ; do \
	rm -f $(REDUCE)/log/$$i.log ; \
	echo \
'load_package '$$i';on errcont;in"'$(TSTDIR)/$$i'.tst";showtime;bye;' \
		    | reduce > $(REDUCE)/log/$$i.log ; \
	done

check:  $(PACKAGES)
	- for i in $(TSTPACKAGES) ; do \
	echo 'comparing '$$i'...' ;  \
	diff $(REDUCE)/log/$$i.log $(TSTDIR) ; \
	done

Added r34.1/lib/Makefile.tmp version [208266a87d].



























































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
#
#  Makefile for REDUCE User Contributed Library (PSL Version)
#	
#  Author:  James H. Davenport <jhd@maths.bath.ac.uk>.
#
#  Modified by:  Anthony C. Hearn.
#
#  This Makefile may be used to build fast loading versions of all the
#  PSL REDUCE User Contributed Library packages, or any particular
#  package.  It assumes that the relevant source files are in the
#  $reduce/lib directory.  It is specific to PSL, and of course those
#  systems (e.g. UNIX) that support a make mechanism.  However, it can
#  be easily used with other systems with a make facility once a
#  suitable mkfasl script has been written.

REDUCE= /tresor/dagobert/cons/reduce3.4.1/dec3100
FASL  = b
BINDIR= $(REDUCE)/fasl
SRCDIR= $(REDUCE)/lib
TSTDIR= $(REDUCE)/lib
MKFASL= $(REDUCE)/util/mkfasl

PACKAGES= assist camal changevar cvit desir fide gnuplot laplace \
	  linineq numeric physop pm reacteqn reset rlfi showrules \
	  symmetry tri wu

UNCOMPILEDPACKAGES= odeex

TSTPACKAGES= assist camal changevar cvit desir fide laplace linineq \
	     numeric physop pmrules reacteqn rlfi symmetry tri wu

all:    $(PACKAGES)

assist: $(BINDIR)/assist.$(FASL)

$(BINDIR)/assist.$(FASL): $(SRCDIR)/assist.red
	$(MKFASL) assist lib


camal:  $(BINDIR)/camal.$(FASL)

$(BINDIR)/camal.$(FASL): $(SRCDIR)/camal.red
	$(MKFASL) camal lib


changevar:      $(BINDIR)/changevar.$(FASL)

$(BINDIR)/changevar.$(FASL): $(SRCDIR)/changevar.red
	$(MKFASL) changevar lib


cvit:   $(BINDIR)/cvit.$(FASL)

$(BINDIR)/cvit.$(FASL): $(SRCDIR)/cvit.red
	$(MKFASL) cvit lib


desir:  $(BINDIR)/desir.$(FASL)

$(BINDIR)/desir.$(FASL): $(SRCDIR)/desir.red
	$(MKFASL) desir lib


fide:   $(BINDIR)/fide1.$(FASL) $(BINDIR)/fide.$(FASL)

$(BINDIR)/fide1.$(FASL): $(SRCDIR)/fide1.red
	$(MKFASL) fide1 lib

$(BINDIR)/fide.$(FASL): $(SRCDIR)/fide.red
	$(MKFASL) fide lib


gnuplot:        $(BINDIR)/gnuplot.$(FASL)

$(BINDIR)/gnuplot.$(FASL): $(SRCDIR)/gnuplot.red
	$(MKFASL) gnuplot lib


laplace:        $(BINDIR)/laplace.$(FASL)

$(BINDIR)/laplace.$(FASL): $(SRCDIR)/laplace.red
	$(MKFASL) laplace lib


linineq: $(BINDIR)/linineq.$(FASL)

$(BINDIR)/linineq.$(FASL): $(SRCDIR)/linineq.red
	$(MKFASL) linineq lib


numeric:  $(BINDIR)/numeric.$(FASL)

$(BINDIR)/numeric.$(FASL): $(SRCDIR)/numeric.red
	$(MKFASL) numeric lib


physop: $(BINDIR)/noncom2.$(FASL) $(BINDIR)/physop.$(FASL)

$(BINDIR)/noncom2.$(FASL): $(SRCDIR)/noncom2.red
	$(MKFASL) noncom2 lib

$(BINDIR)/physop.$(FASL): $(SRCDIR)/physop.red
	$(MKFASL) physop lib


pm:     $(BINDIR)/pm.$(FASL) $(BINDIR)/pmrules.$(FASL)
#       $(BINDIR)/pmrules2.$(FASL)

$(BINDIR)/pm.$(FASL): $(SRCDIR)/pm.red
	$(MKFASL) pm lib

$(BINDIR)/pmrules.$(FASL): $(SRCDIR)/pmrules.red
	$(MKFASL) pmrules lib

# $(BINDIR)/pmrules2.$(FASL): $(SRCDIR)/pmrules2.red
#         $(MKFASL) pmrules2 lib


reacteqn: $(BINDIR)/reacteqn.$(FASL)

$(BINDIR)/reacteqn.$(FASL): $(SRCDIR)/reacteqn.red
	$(MKFASL) reacteqn lib


reset:  $(BINDIR)/reset.$(FASL)

$(BINDIR)/reset.$(FASL): $(SRCDIR)/reset.red
	$(MKFASL) reset lib


rlfi:   $(BINDIR)/rlfi.$(FASL)

$(BINDIR)/rlfi.$(FASL): $(SRCDIR)/rlfi.red
	$(MKFASL) rlfi lib


showrules:  $(BINDIR)/showrules.$(FASL)

$(BINDIR)/showrules.$(FASL): $(SRCDIR)/showrules.red
	$(MKFASL) showrules lib


symmetry: $(BINDIR)/symmetry.$(FASL)

$(BINDIR)/symmetry.$(FASL): $(SRCDIR)/symmetry.red
	$(MKFASL) symmetry lib


tri:  $(BINDIR)/tri.$(FASL)

$(BINDIR)/tri.$(FASL): $(SRCDIR)/tri.red
	$(MKFASL) tri lib


wu:     $(BINDIR)/wu.$(FASL)

$(BINDIR)/wu.$(FASL): $(SRCDIR)/wu.red
	$(MKFASL) wu lib

test:   $(PACKAGES)
	for i in $(TSTPACKAGES) ; do \
	rm -f $(REDUCE)/log/$$i.log ; \
	echo \
'load_package '$$i';on errcont;in"'$(TSTDIR)/$$i'.tst";showtime;bye;' \
		    | reduce > $(REDUCE)/log/$$i.log ; \
	done

check:  $(PACKAGES)
	- for i in $(TSTPACKAGES) ; do \
	echo 'comparing '$$i'...' ;  \
	diff $(REDUCE)/log/$$i.log $(TSTDIR) ; \
	done

Added r34.1/lib/README version [0d8fe58f04].





























































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

                     REDUCE USER CONTRIBUTED LIBRARY

                               15 July 1992

The files in this directory comprise a library of contributions from many
REDUCE users.  The relevant members first appeared in the REDUCE Network
Library.  They are collected here as a service to REDUCE users, and no
responsibility can be taken regarding them.  In particular, any questions
about any of the files should be directed to the relevant author(s).

All code in this library has been tested with REDUCE 3.4, but may require
modifications to work in later releases.  Any updates will appear in later
releases of this library, or in the REDUCE Network Library.  For an
information about this library, send the message "help" to
reduce-netlib@rand.org, reduce-netlib@can.nl or redlib@elib.zib-berlin.de.

A prototypical Makefile is included for those users whose systems provide
this facility (e.g., UNIX-based systems).  Although this makefile is
specific to PSL- and Common Lisp-based systems, it should be fairly easy
to modify for other versions.  The use of this Makefile should be
self-explanatory.  In particular, "make all" will make fast loading
versions of all relevant files in that directory, and "make <package>"
will make a fast loading version of the package named <package>.

The Network Library is divided into sublibraries which have a particular
theme (such as "chemistry").  The sublibraries are then divided into
members, which are individual files with names of the form <name>.<type>.
This particular organization is not preserved here, since all members are
in a single directory.  The table of contents of the current library
organized in the original hierarchical manner is:

                               ARITH

numeric.red    - Source for numerical algorithm package
numeric.tst    - Test file for numerical algorithm package
numeric.tex    - Document file for numerical algorithm package
numeric.log    - Log of test run for numerical algorithm package

                             CHEMISTRY

reacteqn.doc   - documentation for reaction equation system package
reacteqn.log   - log of test file for reaction equation system package
reacteqn.red   - source for reaction equation system package
reacteqn.tst   - test file for reaction equation system package

                       DE (Differential Equations)

changevar.log  - Log of test file for Changevar - a package for
                    changing variables in differential equations
changevar.red  - Source for Changevar package
changevar.tex  - Tex version of document for Changevar package
changevar.tst  - Test file for Changevar package
desir.doc      - Document for DESIR package
desir.log      - Log of UNIX script for testing DESIR package
desir.red      - Source for DESIR package
desir.tst      - Test file for DESIR package.  This should be used with
                    the UNIX script tstdesir, or modified for the local
                    system
tstdesir       - UNIX script for testing DESIR package
fide.doc       - Document for FIDE package for the automation
                    of the finite difference method for PDE's
fide.log       - log of run of FIDE package test file
fide1.red      - part 1 of source file for FIDE package
fide.red       - part 2 of source file for FIDE package
fide.tst       - Test file for FIDE package
odeex.red      - Examples of solving ODE's using Taylor series

                              GRAPHICS

gnuplot.red    - Source for REDUCE GNUPLOT package
gnuplot.tst    - Test file for REDUCE GNUPLOT package
gnuplot.tex    - Document for REDUCE GNUPLOT package

                              GROEBNER

wu.log         - log of test file for Wu's algorithm package
wu.red         - source for Wu's algorithm package
wu.tex         - LaTeX version of document for Wu's algorithm
                   package (there is no plain text version)
wu.tst         - test file for Wu's algorithm package

                              LAPLACE

laplace.red    - source for Laplace and Inverse Laplace Transforms
laplace.doc    - document for Laplace and Inverse Laplace Transforms
laplace.tst    - Test file for Laplace and Inverse Laplace Transforms
laplace.log    - Log of test file for Laplace and Inverse Laplace Transforms

                                MISC

reset.red      - code for resetting REDUCE to initial state

                              PHYSICS

cvit.red       - source for CVIT package for the computation of Dirac
                 gamma matrix expressions by the Cvitanovic-Kennedy
                 algorithm
cvit.doc       - document for CVIT package
cvit.log       - log of running test file for CVIT package
cvit.tst       - test file for CVIT package
physop.red     - source file for PHYSOP package for operator
                     calculus in physics. This REQUIRES the NONCOM2
                     package described below
physop.log     - log of running test file for PHYSOP package
physop.tex     - LaTeX version of document for PHYSOP package
physop.tst     - Test file for PHYSOP package
noncom2.red    - source for noncommutativity package NONCOM2
                               needed by PHYSOP package
symmetry.log   - Log of test run for symmetry package
symmetry.red   - Part 1 of source for symmetry package
                    (all parts are needed)
symdata1.red   - Part 2 of source for symmetry package
symdata2.red   - Part 3 of source for symmetry package
symmetry.tex   - Document file for symmetry package
symmetry.tst   - Log of test run for symmetry package


                                RULES

pm.red         - Source of the PM pattern matcher
pmrules.red    - Basic rules for PM pattern matcher
                 NOTE that pm.red is loaded by this file
pmrules2.red   - More rules for PM pattern matcher, but not thoroughly
                 tested. NOTE that pm.red and pmrules.red must be loaded
                 before this file
pm.doc         - Document for the PM pattern matcher
pmrules.tst    - Test file for the PM pattern matcher and basic rules
pmrules.log    - Log of test file for PM pattern matcher and basic rules

                               SERIES

camal.red      - Source for CAMAL package for celestial mechanics
camal.bib      - Bibliography file for CAMAL package document
camal.log      - Log of running test file for CAMAL package
camal.tex      - LaTeX version of document for CAMAL package
camal.tst      - Test file for CAMAL package

                               SOLVE

linineq.log    - Log of test file for the linineq package for
                     solving sets of linear inequalities
linineq.red    - Source for linineq package
linineq.tex    - LaTex version of document for linineq package
linineq.tst    - Test file for linineq package

                                TEX

reduce.tex     -  TeX file to be used together with output from
                      the TRI package for producing TeX output
redwidth.tex   -  TeX file for determining item widths
tri.latex      -  LaTeX form of document for TRI package
tri.red        -  REDUCE source code for TRI package
tri.tex        -  TeX form of document for TRI package
tri.tst        -  Test file for TRI package; this produces a file
                     tritst.tex,  which can be compared with
                     tritstx.tex, and then processed by "tex tritest"
tri.log        -  Log from run of TRI test file
tritest.tex    -  TeX file for processing output of tri.tst
tritstx.tex    -  Normal output from running test file for TRI package
rlfi.doc       -  Document for the RLFI package for producing
                     LaTeX output
rlfi.red       -  REDUCE source for RLFI package
rlfi.log       -  Log from run of RLFI test file
rlfi.tst       -  Test file for RLFI package

                                UTIL

assist.doc     -  Document for ASSIST utility package
assist.log     -  Log of test file for ASSIST utility package
assist.red     -  Source for ASSIST utility package
assist.tst     -  Test file for ASSIST utility package
showrules.red  -  Source for a command to show rules for an
                     operator (no other documentation)

Added r34.1/lib/assist.doc version [8fce5c193a].





























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814

                           ****** ASSIST ******


   A file of additional functions to REDUCE which raise the programming
     power of the user in a broad range of applications.


Author : H. Caprasse .     Date : 15/09/1991
------                     ----

Address : Physics Institute, B5 , Sart-Tilman, B4000 Liege, Belgium.
--------

Electronic Mail : <u21400L@bliulg11.bitnet> or <u214001@vm1.ulg.ac.be>
---------------

ASSIST arose from the use of REDUCE in many different applications.  It
contains functions which are often needed.  Many of them give
assistance to the user allowing him to produce a more straightforward
and a more efficient code for its own applications. Others give him
more control on the environment. Some of them allows him to introduce
PROPERTIES and FLAGS within the algebraic mode.

                  ___________________________________
                           _________________


                        NEW FUNCTIONS AVAILABLE
                        -----------------------


Control of SWITCHES :
--------------------

SWITCHES SWITCHORG


Operations on "lists" AND "bags" :
-------------------------------

MKLIST DELETE BAGPROP
PUTBAG CLEARBAG BAGP BAGLISTP ALISTP ABAGLISTP LISTBAG
FIRST SECOND THIRD REST REVERSE LAST BELAST APPEND CONS
LENGTH REMOVE DELETE MEMBER ELMULT PAIR DEPTH INSERT POSITION
ASFLIST ASSLIST RESTASLIST SUBSTITUTE REPFIRST REPLAST


Operations on SETS :
------------------

MKSET UNION SETP SETDIFF SYMDIFF


General purpose functions :
-------------------------

MKIDN == INF2 SUP2 ODDP EVENP FOLLOWLINE DETIDNUM
RANDOMLIST COMBNUM PERMUTATION COMBINATIONS FUNCVAR
IMPLICIT DEPATOM EXPLICIT SIMPLIFY


"Properties" and "flags":
-----------------------

PUTFLAG PUTPROP DISPLAYPROP DISPLAYFLAG CLEARFLAG CLEARPROP

Control statement and control of the environment :

NORDP DEPVARP ALATOMP ALKERNP PRECP
KORDERLIST REMSYM SHOW SUPPRESS CLEAROP CLEARFUNCTIONS

Handling of polynomials :
-----------------------

DISTRIBUTE LEADTERM REDEXPR MONOM LOWESTDEG DIVPOL


Handling of TRIGONOMETRIC functions :
-----------------------------------

TRIGEXPAND HYPEXPAND TRIGREDUCE HYPREDUCE


Handling of log's :
-----------------

PLUSLOG CONCSUMLOG

Handling of n-vectors :

SUMVECT MINVECT SCALVECT CROSSVECT MPVECT

Handling of matrices :
MKIDM BAGLMAT COERCEMAT UNITMAT SUBMAT MATSUBR MATSUBC
RMATEXTR RMATEXTC HCONCMAT VCONCMAT TPMAT HERMAT SETELTMAT GETELTMAT

                        __________________
                             =====
We describe successively these different facilities.

CONTROL OF SWITCHES
--------------------

Not all switches are included. The ones we have chosen are
EXP, DIV, MCD, LCM, EZGCD, GCD, ALLFAC, INTSTR, RAT , RATIONAL, FACTOR,
PRECISE, REDUCED, COMPLEX, RATIONALIZE and the new switch DISTRIBUTE.
The selection covers all switches which are essential for ALGEBRAIC
calculations fashion by the user.  The control symbolic variables
!*EXP, !*DIV, etc... which have either the value T or the value NIL are
available on the level of the algebraic mode so it  becomes
possible to write conditional statements of the kind

                  IF !*EXP THEN DO ......

                  IF !*GCD THEN OFF GCD;

Two functions SWITCHES; and SWITCHORG; are provided:

SWITCHES; gives the ACTUAL STATUS of ALL (selected) switches,
SWITCHORG; puts them in the status they have when ENTERING
                                           the system (ORiGinal status).
The new switch DISTRIBUTE controls the working of some polynomial func-
tions which are described below. It allows to put polynomial in a distri-
buted form.

MANIPULATION OF THE "LIST" STRUCTURE
____________________________________

Some additional functions for list manipulations are provided.

i) automatic generation of a LIST :

                      MKLIST n ;    n is an INTEGER

   returns a list of length n with 0 elements.

                      MKLIST(U,n);    U is LIST-like, n is an INTEGER

   returns U if n is LESS than the length of U; otherwise returns a list
   of length n with the first length U elements equal to the elements of
   U. and with the n-length U elements equal to 0.

ii) direct manipulation of a LIST (apart from FIRST,REST,REVERSE):

            ***    U is a LIST-like quantity.

                      LAST U ; BELAST U ; DEPTH U ;

   LAST gives the last element of U
   BELAST gives the list U without the last element,
   DEPTH returns an INTEGER equal to the number of levels where a
   list is found if and only if this number is the SAME for each element
   of U otherwise a message telling the user that U is of UNEQUAL depth
   is returned.

                      POSITION(x,U);    x is anything.

   returns the POSITION of the first occurrence of x in U or a message
   if x is not present in U.

                      DELETE(x,U);    x is anything.

   DELETE returns U after the FIRST occurrence of x in U has been deleted.

                      REMOVE(U,n);    n is an INTEGER.

   REMOVE returns a list which is U without the nth. element.

   If one wants to EXTRACT the nth. element of U instead of using PART
   one may write

                      U.n;

                      MEMBER(x,U);    x is anything.

   MEMBER returns a non-empty list if x belongs to U and nothing if it this
      is not the case. It is a BOOLEAN function so one may write

                      IF MEMBER(x,U) then ......

                      ELMULT(x,U);     x is anything.

   ELMULT return an INTEGER which is the MULTIPLICITY of x inside U.

                     REPFIRST(x,U); REPREST(x,U);   x is anything.

   REPFIRST replaces the first element of U by x and returns the new list.

   REPREST replaces the rest of U by x and returns the list
                                    list(first U,x).

                     INSERT(x,U,n); x is anything, n is an integer.

   INSERTs x in U at the position n and returns the resulting list.

                     SUBSTITUTE(new,old,U);

   where "new" is the OBJECT to substitute to the object "old" in U at
   ALL levels. This function is more elementary than the functions "SUB".
   It is more efficient but works properly only for atomic "new" and old
   objects.

iii) manipulations of two lists:

                 ***  U and V are LIST-like.

                      APPEND(U,V); U.V;

   APPEND returns a list which is the union of the two lists U and V.

   "." (dot) returns a list whose first element is the list U and the other
         elements are the elements of V.

                     PAIR(U,V);

   PAIR returns a list whose elements are LISTS of TWO ELEMENTS. The
   nth sublist contains the nth element of U and the nth. element of V.
   These types of lists are called ASSOCIATION LISTS or ALISTS in the fol-
   lowing. To test for these type of lists a BOOLEAN function is available

            ABAGLISTP U;

   Can ONLY be used in a conditional statement like

            IF ABAGLISTP U THEN .....

   ( this "bizarre" name because it also works for BAGS; see below).

iv) functions which apply to ALISTS:

                   *** x is anything, U is an ALIST.

                    ASFIRST(x,U);

    returns the sublist of U whose FIRST element is x.

                    ASSECOND(x,U);

    returns the sublist of U whose SECOND element is x.

                    ASLAST(x,U);

    returns the sublist of U whose LAST element is x.

                    ASREST(V,U);   here V is a LIST.

    returns the sublist of U whose REST is V.

In addition to these different functions always gives as output the
FIRST occurrence of the appropriate element. There are functions which
either return a LIST of elements of U. We describe them now. U is still
 an ALIST.

                    ASFLIST(x,U);

    returns ALL the listb-elements of U whose
    first element are the KEY x. So the returned object is a list of lists.

                    ASSLIST(x,U);

     acts in the same way as the previous one except that the KEY x is
     the second element of the list-elements of U.

                    RESTASLIST(V,U);   V is a LIST of KEYS.

     returns  a list of the RESTs of the sublists of U associated to each KEY
     present in V.


THE "BAG" TYPE AND ITS ASSOCIATED FUNCTIONS
___________________________________________

In REDUCE 3.4, the LIST structure has a mapping property associated
to it and, consistently, cannot be a coefficient in a polynomial.
Sometimes, also, one would like to manipulate functions
or operators arguments in the same way one manipulates the
elements of a list. The BAG structure allows to do such things.

The definition: It is a "FLAG" which can be superimposed to the properties
                of most KERNELS. They keep their own properties but
                to these are superimposed properties which make them VERY
                SIMILAR to lists.  When the prefix of a kernel gets
                the flag "BAG" all functions defined for lists (or for sets)
                become ACTIVE.
                A detailed description of this structure is given in the
                article by H. Caprasse and M. Hans in
                SIGSAM Bulletin, Vol. 19, 46-52 (1985).
                Here we try to make the use of this notion clear from the des-
                cription of the action of the various functions available.

                        PUTBAG id1,id2,....idn;

    where id1,.....idn are identifiers.
    This functions allows one to give to id1,...,idn the BAG properties.
    id1,.. ,idn  are only restricted NOT to be

          - the name LIST,
          - the name of a BOOLEAN function.

     id1,....,idn may be the

          - the name of an OPERATOR prefix,
          - the name of an ordinary function.

     WHEN AND ONLY WHEN the identifier is not an already defined function
     does PUTBAG puts on it the property of an OPERATOR PREFIX.

                        CLEARBAG id1,...idn;

     eliminates the BAG property on id1,...,idn.


When an identifier has got the bag property ALL FUNCTIONS previously defined
for LISTS (and also subsequently defined for SETS) become ACTIVE.  Their
actions are the same as for list-like objects except for the following
important difference:

      The NAME of the IDENTIFIER is KEPT by the functions

                             FIRST and LAST.

When "appending" two bags the resulting bag gets the name of the FIRST
argument bag.
So a bag-like identifier can always be considered as an "envelope" suited
to contain any objects. These ojects are the arguments of the bag.
The possibility to manipulate the arguments as if the bag were a LIST
increases the programming capabilities and efficiency in the ALGEBRAIC MODE.
The TEST FILE gives several illustrations of the actions of the various
functions on bags.  Here we stress two cases where it is particularly
convenient:
An operator function is defined as

                       OP(x):=x**2;
                       OP(x,y):=x*sin(y);


The command           PUTBAG OP;

will allow us to encompass the different definitions trivially.

For example

                    AA:=FIRST OP(X,Y,Z); ==> AA:=OP(X)

and                 AA:=AA; ==>              AA:=X**2

                    AA:=REST OP(X,X,Y); ==> AA:=OP(X,Y)

and                 AA:=AA; ==>              AA:=X*SIN Y

One can wonder why we did not manage to do the two steps together. This
is so because in most applications we encountered the evaluation is not
to be done IMMEDIATELY. Moreover we want to keep the basic functions
very efficient since they are usually applied repeatedly a great number
of times. Last but not least, it is not difficult, if necessary, to con-
struct a procedure which does so.

The second case is when one wants to construct a PROCEDURE with an (a
priori) INDETERMINATE number of variables.  Then the use of a prefix with
the "BAG" flag to capture all variables will allow to do so easily.  The
package provides a "standard" name for it which is

                                BAG

but ANY OTHER NAME can be used after it has been declared a "bag" through

                                PUTBAG.

For instance one may write

                     PROCEDURE TRIAL U ;
                     FOR I:=1:SIZE U DO WRITE PART(U,i);

When U is BAG(v1,v2,....,vn), SIZE U automatically determines the ACTUAL
number of variables (SIZE is another name for LENGTH which is more
appropriate when applied to a bag-like object).
This possibility is also available if U is a list when one delivers the
command

                      LISTARGP TRIAL;

But this command forbids the associated mapping property of U.
So, it is very convenient to be able to use as U either a list-like or
bag-like object using a code which manages to handle both structures.
Of course several arguments are allowed one or several of them can be
"bags".  The example above could be treated also with U being LIST-LIKE.
It is important to remember that

               - a bag can be treated as  an ordinary KERNEL so that all
                 ALGEBRAIC operations and simplifications do apply to it.
               - if the prefix is the one of an already defined function
                 it keeps these properties or can also be given other
                 properties (one may declare BAG to be a SYMMETRIC function
                 for instance).


ADDITIONAL FUNCTIONS
--------------------

There are several simple functions devoted to the bag manipulations .

                          BAGP x ; BAGLISTP x ;   x is anything.

They are boolean functions.  As such they can only be used in conditional
statements.

BAGP detects if x is a bag or not .
BAGLISTP detects if x is a list or a bag.

Coercing functions are

                          KERNLIST U ;  U is a bag.

KERNLIST transforms a KERNEL into a LIST. This is convenient when the name
of the prefix does not matter or if one wants to HIDE temporarily
its properties.

                          LISTBAG(U,nb); U is a list, nb is an identifier.

LISTBAG transforms a LIST into a BAG whose envelope has the NAME nb.

                          SIZE U ;   U is a bag (or a list).

As said above it is another name for length givem to indicate that it gives
the total number of objects INSIDE the envelope.

REMARK: The functions KERNLIST and LISTBAG allow easily to mix list-like and
------  bag-like objects in a given expression. All functions do recognize
        the differences except that functions which work on association-list
        or -bag cannot work on MIXED objects. This restriction can be elimina-
        ted but we have had no motivation to do so.


SETS AND BASIC MANIPULATION FUNCTIONS
-------------------------------------

These functions apply BOTH to list-like and bag-like objects.

                         MKSET U ; SETP U ; U is a bag or list.

MKSET  returns a bag or list with each element appearing only ONCE.
SETP is a boolean function which recognizes set-like objects.

            UNION(U,V); INTERSECT(U,V); DIFFSET(U,V); SYMDIFF(U,V);

U and V are set-like.

All these functions return a SET.  The names are self-explanatory.


GENERAL PURPOSE FUNCTIONS
-------------------------

The list of these functions were already given. They depend either of
one or two arguments. We describe some of them only.
COMBNUM gives the number of combinations of P objects taken among
N objects.


                     PERMUTATIONS U ;  U is a bag

returns a bag of bags each containing one permutation of the original bag.

                     COMBINATIONS (U,n) ; U is a bag , n is an integer.

returns a bag of bags each containing one combination of the original bag

                      FUNCVAR x ; x is any expression .

returns the *set* identifiers which are NOT prefix identifiers. The set
does NOT contain reserved or constant identifiers.

                      DEPATOM x ; x is an ATOMIC expression.

returns a list of identifiers if x has previously been declared to DEPEND on
these otherwise returns an empty list.

                      EXPLICIT x ; IMPLICIT x ;

These two functions allow one to change smoothly the representation of
OPERATORS and FUNCTIONS going from an EXPLICIT to an IMPLICIT
representations of these objects.  By EXPLICIT representation we mean one
in which VARIABLES mus be EXPLICITLY written as in

                      OP(X,Y,F(G));

By IMPLICIT representation we mean one in which VARIABLES dependences are
"HIDDEN" as one obtains through the DEPEND command.  So the IMPLICIT
representation of the object above is

                      OP ;

TOGETHER with the command

                      DEPEND OP,X,Y,F(G);

One could equivalently call them the CONCRETE and ABSTRACT representations.
It is often much better in a calculation to manipulate the abstract represen-
tation but then we need functions allowing us to switch easily to the concrete
one and vice versa. The function

IMPLICIT returns its argument if it is an ATOM and returns the ABSTRACT (or
"implicit") representation of its argument if this argument is an OPERATOR
(or a FUNCTION). So

                  IMPLICIT OP(X,Y,F(G)); ==>     OP
                  IMPLICIT A           ; ==>     A.

The function EXPLICIT must have an argument x which is ALWAYS an ATOM. If
this atom is the abstract representation of an OPERATOR (or a FUNCTION) it
returns its CONCRETE (or "explicit") representation. So

                  EXPLICIT OP ; ==>    OP(X,Y,F(G))


                  DETIDXNUM x ;  where x is any IDENTIFIER

This function allows to identify a given variable in a set like
                        A1,A2,....A23,...
extracting the number appended to its name. It returns nothing if a
variable name terminates by a letter but any integer may be included in
the name. For instance

                  DETIDXNUM a1bb23c122 ; ==> 122

The function SET of REDUCE 3.4 is generalized and slightly modified to
make it work not only for atomic quantities but also for KERNELS. We have
not redefined the function SET but we have created the INFIX function
" == " . Suppose one makes the assignment

                  A:=OP(X);

then writing

                  A == SIN(X);

will assign OP(X) to SIN(X).

Finally the function SIMPLIFY which full forces resimplification of an
expression is an "emergency" function sometimes helpful to simplify
some output of the EXCALC package.

"PROPERTIES" AND "FLAGS":
-----------------------

One of the important drawbacks of the algebraic mode is the fact that the user
has not the possibility to ENDOW objects of flags and properties. The subse-
quent functions allow one to do that.
If one wants to give a flag or a property to one or a list of IDENTIFIERS
one must issue

                  PUTFLAG(idp,<flagname>,T); or
                  PUTFLAG(LIST(idp1,idp2,..),<flagname>,T);

                  PUTPROP(idp,<propname>,<value>,T); or
                  PUTPROP(LIST(idp1,idp2,..),<propname>,<value>,T);

The SAME commands must be issued if one wants to ERASE them EXCEPT that

                     T must be replaced by 0.


If one wants to DISPLAY the FLAGS or (and) the PROPERTIES of a given
IDENTIFIER one must issue the commands

                  DISPLAYFLAG(idp); or (and)
                  DISPLAYPROP(idp,<propname>);


We point out that the "DISPLAY" functions do not give access to the property
list generated at the level of the source code but ONLY to the properties
generated by the PUT(FLAG or PROP) commands i.e. to the properties or flags
CREATED BY THE USER.
Two additional functions for CLEARING are provided. They are

                   CLEARFLAG A1,A2,...An ;
                   CLEARPROP A1,A2,...An ;

where A1..,An  are identifiers. They eliminate ALL flags or properties
of these. Moreover if one chooses ALL as the UNIQUE argument ALL
flags or properties of ALL identifiers are ELIMINATED.


CONTROL FUNCTIONS
-----------------

Here we describe a certain number of functions which will help the user to
CONTROL and BETTER understand the REDUCE environment.
A collection of  BOOLEAN functions are available. They are

           ALATOMP x;     x is anything.
           ALKERNP x;      x is anything.
           PRECP(x,y);     x,y are ATOMS or printcharacters.
           DEPVARP(x,V);   x is anything, V is an ATOM or a KERNEL.

ALATOMP has the value T iff x is an integer or  an identifier AFTER it
has been evaluated.
ALKERNP has the value T iff x is a KERNEL AFTER it has been evaluated.
PRECP determines whether the OPERATION x has PRECEDENCE over the OPERATION y.
Returns T iff it is the case.
DEPVARP returns T iff the expression x depends on V at ANY LEVEL.
These functions are ALSO ALGEBRAIC functions. This is very convenient
to guide beginners and in particular to make them understand what a KERNEL is.
In addition the function

                       STRINGP x ;

which determines if x is a string is also available in conditional statements.
The next functions allow one to analyze and to CLEAN the environment
of REDUCE which is created by the user while he is working INTERACTIVELY.
They REMIND the user of the names of identifiers they have introduced
IN THE CONSOLE for different purposes and to make PARTIAL CLEARING of them
according to their TYPES.

There are TWO commands to remember:

                        SHOW and SUPPRESS.


They have different arguments which are associated to the different types.
So, one can deliver the following commands to DISPLAY the different used-ids:


                        SHOW SCALARS;
                        SHOW LISTS;
                        SHOW MATRICES;
                        SHOW ARRAYS;
                        SHOW VECTORS;    (contains vector, index and tvector)
                        SHOW FORMS;
                        SHOW ALL;

The argument ALL allows to see all user variables whatever their type.
SUPPRESS can be called with the same arguments.  It clears ALL ids of
the required type and eventually all of them.
It must be stressed these functions IGNORE all variables which are not
DIRECTLY introduced or manipulated ON THE CONSOLE.  For instance variables
which are used ONLY in an INPUT FILE.

The CLEAR function of the system does not do a complete cleaning of OPERATORS
and FUNCTIONS. The following two functions do a more complete cleaning which
also takes automatically into account the USER flag and properties that the
new functions PUTFLAG and PUTPROP may have introduced.

                        CLEAROP x;           x is an OPERATOR

do a COMPLETE cleaning of the x property list.

                        CLEARFUNCTIONS A1,A2,...An ;


do the same with ALL functions with names A1,A2...An.
These are still in an EXPERIMENTAL STAGE . The user should be careful
when he uses them since they only avoid to ERASE the PROTECTED functions and
most of the functions in the basic code are NOT protected.


HANDLING OF POLYNOMIALS :
-----------------------

The LOG file gives all necessary explanations here. Two comments are
to be made:

     a. MONOM is very useful since it places automatically of all monoms
              of a multivariate polynomial in a list. From the result
              each monom  can be manipulated SEPARATELY. Moreover, if
              one wishes, it becomes trivial to place them in an ARRAY
              or to put then as elements of a MATRIX.
     b. LEADTERM and REDEXPR works either on the recursive or on the
        distributive forms of a polynomial. They give a mean to control
        simplifications  and the swelling of intermediate expressions.
        The choice of the recursive- or distributive-way of working is
        made by the user through the command

                     OFF (ON) DISTRIBUTE;

HANDLING OF TRIGONOMETRIC FUNCTIONS :
-----------------------------------

The LOG file is here self-explanatory. The use of TRIG(HYP)REDUCE
followed by the use of TRIG(HYP)EXPAND makes the necessary simplifica-
tions for the sum-squared of the trig(hyp)-functions. In these two cases
they make the work of the COMPACT. It is not garanteed however that the
resulting expression will be the most compact one.


HANDLING OF LOG'S :
-----------------

PLUSLOG is put for convenience of the user. CONCSUMLOG do the reverse
job for any rational expression. Both of them restore the environment in
the status it had before their action.


BASIC OPERATIONS ON N-DIMENSIONAL (explicit) VECTORS
_____________________________________________________

Vectors in EUCLIDEAN space may be represented by list-like or bag-like
objects.  The components may be "bags" but may NOT be "lists".  This is so
because one has only defined operations between vectors and NOT between
tensors so that the operations at level 1 are ORDINARY algebraic
operations.  As already said list-like objects may NOT be treated as
ordinary kernels while bag-like objects do for the basic operations.
Of course one can be much more ambitious and we have indeed been. But in this
UTILITY package which must remain of rather small size and UNSPECIALIZED so
we confine to the ELEMENTARY cases.
We have, with U1,U2 being two BAGS or LISTS with n elements

                         SUMVECT(U1,U2);  for the sum of U1 and U2,

                         MINVECT(U1,U2);  for the difference of U1 and U2,

                         SCALVECT(U1,U2);for the scalar product.

LIMITED to 3-dimensional vectors we have

                         CROSSVECT(U1,U2); for the cross product,

                         MPVECT(U1,U2);    for the mixed product.



ADDITIONAL FUNCTIONS FOR MATRIX MANIPULATIONS
---------------------------------------------


                         MKIDM(U,J); J is an ATOM.

This functions works like MKID except that its argument U is a MATRIX. It is
also REQUIRED that Uj be a MATRIX. It allows one to make loops.
For instance if U,U1,U2,..U5 are matrices one may write

                         FOR I:=1:5 DO U:=U-MKIDM(U,I);

The next functions are COERCION functions i.e. they MAP matrices on
BAG-LIKE or LIST-LIKE objects and conversely they generate MATRICES from
"bags" or "lists".  If U is a MATRIX and id is any identifier

                         COERCEMAT(U,id);

COERCEMAT transforms U into a list of lists IFF id is equal to LIST otherwise
it transforms it into a bag of bags whose ENVELOPE has the NAME id.

If UN is a MATRIX-NAME and bgl is either a bag or a list of DEPTH two
the function

                         BAGLMAT(bgl,UN);

transforms bgl into a matrix whose name is UN.  The transformation is NOT
done if UN is ALREADY the name of a previously defined matrix.  This is to
avoid ACCIDENTAL redefinition of this matrix.

Often one needs to construct a UNIT matrix of some dimension.  This
construction is done by the system thanks to the function

                         UNITMAT M1(n1), M2(n2), .....Mi(ni) ;

where M1,...Mi are names of matrices and n1,n2,....ni are INTEGERS
representing space dimensions.

Submatrices are obtained using the function

                         SUBMAT(U,nr,nc);

where nr,nc are the row and column numbers respectively.  It gives the
submatrix obtained from U deleting the row nr and the column nc.  When nr
or nc are equal to zero only column nc or row nr is deleted.

Two functions allow one to EXTRACT a row or a column. They are

                         MATEXTR(U,VN,nr);

                         MATEXTC(U,VN,nc);

U is the matrix, VN is the "VECTOR NAME", nr and nc are integers.  If VN
is equal to LIST the vector is given as a list otherwise it is given as a
BAG.

Rows and columns may be SUBSTITUTED using

                         MATSUBR(U,bgl,nr);

                         MATSUBC(U,bgl,nc);

The meaning of the variables U,nr,nc is the same as above while bgl is a LIST
or a BAG. Of course the LENGTH (or the SIZE) of bgl should be compatible with
the dimensions of U.

Concatenation of two matrices can be made with

                         HCONCMAT(U,V);

                         VCONCMAT(U,V);

the first function concatenates horizontally, the second one concatenates
vertically.

The tensor product between two matrices is madse by

                         TPMAT(U,V); or U TPMAT V;

The hermitian matrix corresponding ti an already defined matrix is
created automatically by

                         HERMAT(U,hu);

hu becomes the hermitian matrix of U.
hu SHOULD be a FREE identifier for HERMAT to work successfully. This is
done on purpose to prevent accidental redefinition of an already used
used identifier .

SETELMAT allows to reset the element (i,j) of a given matrix while
GETELTMAT allows to extract the element (i,j). They are useful only
when used INSIDE a procedure.

Added r34.1/lib/assist.log version [bc29b70b65].







































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
REDUCE 3.4.1, 15-Jul-92 ...

1: 
(ASSIST)


% Tests of Assist Package version 1.1 .
% Valid only with REDUCE 3.4
% DATE : 15 September 1991.
% Author: H. Caprasse <u214001@bliulg11.bitnet>.
%                     <u214001@vm1.ulg.ac.be>
%---------------------------------------------------------------------
load assist;


showtime;


Time: 17 ms

% 1. TESTS OF THE SWITCH CONTROL FUNCTIONS :
;


switches;


      **** exp:=T ............. allfac:= T ****

      **** ezgcd:=NIL ......... gcd:= NIL ****

      **** mcd:=T ............. lcm:= T ****

      **** div:=NIL ........... rat:= NIL ****

      **** intstr:=NIL ........ rational:= NIL ****

      **** precise:=NIL ....... reduced:= NIL ****

      **** complex:=NIL ....... rationalize:= NIL ****

      **** factor:= NIL ....... distribute:= NIL ***
switchorg;


switches;


      **** exp:=T ............. allfac:= T ****

      **** ezgcd:=NIL ......... gcd:= NIL ****

      **** mcd:=T ............. lcm:= T ****

      **** div:=NIL ........... rat:= NIL ****

      **** intstr:=NIL ........ rational:= NIL ****

      **** precise:=NIL ....... reduced:= NIL ****

      **** complex:=NIL ....... rationalize:= NIL ****

      **** factor:= NIL ....... distribute:= NIL ***
;


if !*mcd then "the switch mcd is on";


the switch mcd is on

if !*gcd then "the switch gcd is on";


;


% A new switch :
!*distribute;


%
% 2. THE "LIST" MANIPULATION FACILITIES" :
;


% generation of a new list
;


 t1:=mklist(4);


T1 := {0,0,0,0}


 for i:=1:4 do t1:= (t1.i:=mkid(a,i));


;


%   notice that part(t1,i) has become t1.i. as also shown  here :
;


t1.1;


A1

t1:=(t1.1).t1;


T1 := {A1,A1,A2,A3,A4}


% MKLIST does NEVER destroy anything
;


mklist(t1,3);


{A1,A1,A2,A3,A4}

mklist(t1,10);


{A1,A1,A2,A3,A4,0,0,0,0,0}


% 3. THE DEFINITION OF A BAG
;


% The atom "BAG" is an available (and reserved) name for a BAG envelope
% it is an OPERATOR. In what follows we mostly use it but we insist that
% ANY identifier (there are a few exceptions) may be used.
;


aa:=bag(x,1,"A");


AA := BAG(X,1,A)

% It is easy to construct NEW bag-like objects
;


putbag bg1,bg2;


T


% now one can verify that
;


aa:=bg1(x,y**2);


             2
AA := BG1(X,Y )

% is a bag by BAGP
;


if bagp aa then "this is a bag";


this is a bag

;


% One can erase the bag property of bg2 by the command
;


clearbag bg2;


;


% baglistp works in the same way for either a LIST OR a BAG
;


if baglistp aa then "this is a bag or list";


this is a bag or list

if baglistp list(x) then "this is a bag or list";


this is a bag or list

;


% Use of the DISPLAYFLAG command that we shall illustrate below is
% another way.
% "LIST" MAY NOT be a bag.
on errcont;


% The command below gives an error message:
;


putbag list;


***** LIST invalid as BAG

% LISTS may be transformed to BAGS and vice versa
off errcont;


;


kernlist(aa);


    2
{X,Y }

listbag(list x,bg1);


BG1(X)

%
%
% 4. BASIC MANIPULATION FUNCTIONS WORKING FOR BOTH STRUCTURES :
;


% define:
;


ab:=bag(x1,x2,x3);


AB := BAG(X1,X2,X3)

al:=list(y1,y2,y3);


AL := {Y1,Y2,Y3}

% We illustrate how the elementary functions do work DIFFERENTLY
;


first ab;


BAG(X1)
  third ab;


BAG(X3)
  first al;


Y1

last ab;


BAG(X3)
 last al;


Y3

% The subsequent one do act in the SAME way;
rest ab;


BAG(X2,X3)
 rest al;


{Y2,Y3}

belast ab;


BAG(X1,X2)
 belast al;


{Y1,Y2}

;


% depth determines if the depth of the list is uniform.
% when it is, it gives its deepness as an integer.
;


depth al;


1
 depth bg1(ab);


2

% It is very convenient to define the PICKUP function PART(x,n) by . :
;


ab.1;


X1
 al.3;


Y3

on errcont;


ab.4;


***** Expression BAG(X1,X2,X3) does not have part 4

off errcont;


% For bags, it is possible to avoid an error message when one
% has an index out of range using "first", "second" and "third".
% For instance:
;


second second ab;


BAG()

% This is coherent because the envelope of a bag always remains.
;


size ab;


3
 length al;


3

remove(ab,3);


BAG(X1,X2)

delete(y2,al);


{Y1,Y3}

reverse al;


{Y3,Y2,Y1}

member(x3,ab);


BAG(X3)
 % notice the output.
;


al:=list(x**2,x**2,y1,y2,y3);


        2
AL := {X ,

        2
       X ,

       Y1,

       Y2,

       Y3}

;


elmult(x**2,al);


2

position(y3,al);


5

;


repfirst(xx,al);


     2
{XX,X ,Y1,Y2,Y3}

represt(xx,ab);


BAG(X1,XX)

insert(x,al,3);


  2  2
{X ,X ,X,Y1,Y2,Y3}

insert( b,ab,2);


BAG(X1,B,XX)

insert(ab,ab,1);


BAG(BAG(X1,XX),X1,XX)

substitute (new,y1,al);


  2  2
{X ,X ,NEW,Y2,Y3}

;


% Function that acts on TWO lists or bags :
;


append(ab,al);


           2  2
BAG(X1,XX,X ,X ,Y1,Y2,Y3)

append(al,ab);


  2  2
{X ,X ,Y1,Y2,Y3,X1,XX}

;


% Association list or bag may be constructed and thoroughly used
;


l:=list(a1,a2,a3,a4);


L := {A1,A2,A3,A4}

b:=bg1(x1,x2,x3);


B := BG1(X1,X2,X3)

% PAIR is the CONSTRUCTOR of the ASSOCIATION LIST or BAG.
al:=pair(list(1,2,3,4),l);


AL := {{1,A1},{2,A2},{3,A3},{4,A4}}

ab:=pair(bg1(1,2,3),b);


AB := BG1(BG1(1,X1),BG1(2,X2),BG1(3,X3))

;


% A BOOLEAN function abaglistp to test if it is an association
;


if abaglistp bag(bag(1,2)) then "it is an associated bag";


it is an associated bag

;


% Values associated to the keys can be extracted
% first occurence ONLY.
;


asfirst(1,al);


{1,A1}

asfirst(3,ab);


BG1(3,X3)

;


assecond(a1,al);


{1,A1}

assecond(x3,ab);


BG1(3,X3)

;


aslast(z,list(list(x1,x2,x3),list(y1,y2,z)));


{Y1,Y2,Z}

asrest(list(x2,x3),list(list(x1,x2,x3),list(y1,y2,z)));


{X1,X2,X3}

;




% All occurences.
asflist(x,bg1(bg1(x,a1,a2),bg1(x,b1,b2)));


BG1(BG1(X,A1,A2),BG1(X,B1,B2))

asslist(a1,list(list(x,a1,a2),list(x,a1,b2),list(x,y,z)));


{}

restaslist(bag(a1,x),bg1(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z)));


BG1(BG1(X,B2),BG1(A1,A2))

restaslist(list(a1,x),bag(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z)));


BAG(BAG(X,B2),BAG(A1,A2))


%********
% Mapping functions can be used with bags through
;


on errcont;


;


for each j in list(list(a),list(c)) join j;


{A,C}

for each j in list(bg1(a),bg1(b)) collect first j;


{BG1(A),BG1(BG1(X1,X2,X3))}

off errcont;


;


% The FOR EACH .. IN .. statement requires a LIST-LIKE object.;
;


% There are functions available for manipulating bags or lists
% as sets. (they exist in the symbolic mode).
;


ts:=mkset list(a1,a1,a,2,2);


TS := {A1,A,2}

;


% Again a boolean function to test the SET property
;


if setp ts then "this is a SET";


this is a SET

;


union(ts,ts);


{A1,A,2}

diffset(ts,list(a1,a));


{2}

diffset(list(a1,a),ts);


{}

symdiff(ts,ts);


{}

intersect(listbag(ts,set1),listbag(ts,set2));


SET1(A1,A,2)



% 5. MISCELLANEOUS GENERAL PURPOSE FUNCTIONS :
;


clear a1,a2,a3,a,x,y,z,x1,x2,op;


%
% DETECTION OF A GIVEN VARIABLE IN A GIVEN SET
;


detidnum aa;


detidnum a10;


10

detidnum a1b2z34;


34

% A list of a finite number of randomly chosen integers can be
% generated:
%
randomlist(3,10);


{0,0,1,2,2,2,0,0,0,0}

%
combnum(8,3);


56

permutations(bag(a1,a2,a3));


BAG(BAG(A1,A2,A3),BAG(A1,A3,A2),BAG(A2,A1,A3),BAG(A2,A3,A1),

    BAG(A3,A1,A2),BAG(A3,A2,A1))

combinations({a1,a2,a3},2);


{{A2,A3},{A1,A3},{A1,A2}}

;


% The "depend" command can be  traced and made EXPLICIT :
;


depatom a;


A

depend a,x,y;


depatom a;


{X,Y}

% The second use of DEPEND
;


depend op,x,y,z;


implicit op;


OP

explicit op;


OP(X,Y,Z)

depend y,zz;


explicit op;


OP(X,Y(ZZ),Z)

aa:=implicit op;


AA := OP

% The ENTIRE dependence of OP becomes "IMPLICIT"
;


df(aa,y);


DF(OP,Y)

% These two last functions work properly ONLY when the command "DEPEND"
%involves ATOMIC  quantities.
;


% Detection of variables a given function depends on is possible
;


funcvar(x+y);


{X,Y}

funcvar(sin log(x+y));


{X,Y}

;


% Variables on which an expression depends :
%
funcvar(sin pi);


funcvar(x+e+i);


{X}

%
% CONSTANT and RESERVED identifiers are recognize and not taken
% as variables.
%
% Now we illustrate functions that give, display or erase
%            a "FLAG" or a "PROPERTY" :
;


% It is possible to give "flags" in the algebraic mode;
%
putflag(list(a1,a2),fl1,t);


T

putflag(list(a1,a2),fl2,t);


T

displayflag a1;


{FL1,FL2}

% to clear ALL flags created for a1 :
;


clearflag a1,a2;


displayflag a2;


{}

putprop(x1,propname,value,t);


X1

displayprop(x1,prop);


{}

displayprop(x1,propname);


{{PROPNAME,VALUE}}

% To clear ONE property
;


putprop(x1,propname,value,0);


displayprop(x1,propname);


{}

%
%
% 6. FUNCTIONS TO CONTROL THE ENVIRONMENT :
;


% Algebraic ATOMS detection
;


alatomp z;


T

z:=s1;


Z := S1

alatomp z;


T

% Algebraic KERNEL detection
;


alkernp z;


T

alkernp log sin r;


T

% PRECEDENCE detection
;


precp(difference,plus);


T

precp(plus,difference);


precp(times,.);


precp(.,times);


T

% STRING detection
;


if stringp x then "this is a string";


if stringp "this is a string" then "this is a string";


this is a string

;


;


% A function which detects the dependence of u with respect
%to the ATOM or KERNEL v at ANY LEVEL
;


depvarp(log(sin(x+cos(1/acos rr))),rr);


T

;


operator op;


*** OP already defined as operator 

symmetric op;


op(x,y)-op(y,x);


0

remsym op;


op(x,y)-op(y,x);


OP(X,Y) - OP(Y,X)

;


clear y,x,u,v;


korder y,x,u,v;


korderlist;


(Y X U V)

;


for all x,y such that nordp(x,y) let op(x,y)=x+y;


op(a,b);


BG1(X1,X2,X3) + A

op(b,a);


OP(BG1(X1,X2,X3),A)

clear op;


% DISPLAY and CLEARING of user's objects of various types entered
% to the console. Only TOP LEVEL assignments are considered up to now.
% The following statements must be made INTERACTIVELY. We put them
% as COMMENTS for the user to experiment with them. We do this because
% in a fresh environment all outputs are nil.
;


% THIS PART OF THE TEST SHOULD BE REALIZED INTERACTIVELY.
% SEE THE ** ASSIST LOG **  FILE .
%clear a1,a2,aa,ar,br,mm,m1,m2,f,tv;
%a1:=a2:=1;
%show scalars;
%x**2;
%saveas res;
%show scalars;
%aa:=list(a);
%show lists;
%array ar(2),br(3,3);
%show arrays;
%load matr$
%matrix mm; matrix m1(2,2); m2:=mat((1,1));
%show matrices;
%vector v1,v2;
%show vectors;
%load excalc; pform f=1; tvector tv;
%show vectors;
%show forms;
%show all;
%suppress vectors;
%show vectors;
%suppress all
%show all;
clear op;


operator op;


op(x,y,z);


OP(X,Y,S1)

clearop op;


T

clearfunctions abs,tan;


     *** ABS is unprotected : Cleared ***

     *** TAN is unprotected : Cleared ***


"Clearing is complete"

;


% THIS FUNCTION MUST BE USED WITH CARE !!"!!!
;



% 7. NEW POLYNOMIAL MANIPUKLATION FACILITIES
%
%
clear x,y,z;


% To see the internal representation :
%
off pri;


;


pol:=(x+2*y+3*z**2)**3;


          3               2   2       2       2         4       3
POL := 8*Y  + (12*X + 36*Z )*Y  + (6*X  + 36*Z *X + 54*Z )*Y + X  + 9

         2  2       4         6
       *Z *X  + 27*Z *X + 27*Z

;


% Notice the recursive form.
;


pold:=distribute pol;


           3       2  2         2       4         2          2      3
POLD := 8*Y  + 36*Z *Y  + 12*X*Y  + 54*Z *Y + 36*Z *X*Y + 6*X *Y + X

              2  2       4         6
         + 9*Z *X  + 27*Z *X + 27*Z

;


% Now it is in a distributive form.
;


% Terms and reductums may be extracted individually :
on distribute;


polp:=pol$


leadterm (pold);


   3
8*Y

pold:=redexpr pold;


            2  2         2       4         2          2      3      2
POLD := 36*Z *Y  + 12*X*Y  + 54*Z *Y + 36*Z *X*Y + 6*X *Y + X  + 9*Z

          2       4         6
        *X  + 27*Z *X + 27*Z

leadterm pold;


    2  2
36*Z *Y

;


off distribute;


polp:=pol$


leadterm polp;


   3
8*Y

polp:=redexpr polp;


                    2   2       2       2         4       3      2  2
POLP := (12*X + 36*Z )*Y  + (6*X  + 36*Z *X + 54*Z )*Y + X  + 9*Z *X

               4         6
         + 27*Z *X + 27*Z

leadterm polp;


            2   2
(12*X + 36*Z )*Y

;


% "leadterm" and "redexpr" extract the leading term and reductum of a
% polynomial respectively WITHOUT specifying the variable.
% The default ordering is then assumed.
% They work both for the distributive and recursive representations.
%
% The function "monom" puts in a list all monoms of a multivariate
% polynomial.
monom polp;


     6
{27*Z ,

     4
 27*Z *X,

    2  2
 9*Z *X ,

  3
 X ,

    2
 6*X *Y,

     2
 36*Z *X*Y,

     4
 54*Z *Y,

       2
 12*X*Y ,

     2  2
 36*Z *Y }

% "lowestdeg" extracts the smallest power of a given indeterminate
% in a polynomial:
lowestdeg(pol,z);


0

;


on pri;


;


divpol(pol,x+2*y+3*z**2);


  2                2      2         2      4
{X  + 4*X*Y + 6*X*Z  + 4*Y  + 12*Y*Z  + 9*Z ,

 0}

% This function gives the quotient AND the remainder directly inside a
% list.
;


% 8. MANIPUKLATIONS OF SOME ELEMENTARY TRANSCENDENTAL FUNCTIONS

trig:=((sin x)**2+(cos x)**2)**4;


              8           6       2           4       4
TRIG := SIN(X)  + 4*SIN(X) *COS(X)  + 6*SIN(X) *COS(X)

                   2       6         8
         + 4*SIN(X) *COS(X)  + COS(X)

trigreduce trig;


1

trig:=sin (5x);


TRIG := SIN(5*X)

trigexpand trig;


              4            2       2           4
SIN(X)*(SIN(X)  - 10*SIN(X) *COS(X)  + 5*COS(X) )

trigreduce ws;


SIN(5*X)

trigexpand sin(x+y+z);


 - SIN(X)*SIN(Y)*SIN(Z) + SIN(X)*COS(Y)*COS(Z) + SIN(Y)*COS(X)*COS(Z)

 + SIN(Z)*COS(X)*COS(Y)

;


% The same functions exist for hyperbolic functions:
;


hypreduce (sinh x **2 -cosh x **2);


-1

;


% For expressions containing log's. Expansion in terms of sums,
% differences, .. is given by "logplus" while concatenation is given
% by the function "concsumlog".
;


clear a,b;


pluslog log(a*log(x**b));


LOG(LOG(X)) + LOG(A) + LOG(B)

concsumlog((2*log x + a*b*log(x*y)+1)/(3*x**2*log(y)));


      A*B  A*B  2
 LOG(Y   *X   *X ) + 1
-----------------------
              2
           3*X
      LOG(Y    )

% Though these functions do use substitution rules, these are
% active only during the time they actually do their work.


%  9. VECTOR CALCULUS OPERATIONS
;


clear u1,u2,v1,v2,v3,v4,w3,w4;


u1:=list(v1,v2,v3,v4);


U1 := {V1,V2,V3,V4}

u2:=bag(w1,w2,w3,w4);


U2 := BAG(W1,W2,W3,W4)

%
sumvect(u1,u2);


{V1 + W1,

 V2 + W2,

 V3 + W3,

 V4 + W4}

minvect(u2,u1);


BAG( - V1 + W1, - V2 + W2, - V3 + W3, - V4 + W4)

scalvect(u1,u2);


V1*W1 + V2*W2 + V3*W3 + V4*W4

crossvect(rest u1,rest u2);


{V3*W4 - V4*W3,

  - V2*W4 + V4*W2,

 V2*W3 - V3*W2}

mpvect(rest u1,rest u2, minvect(rest u1,rest u2));


0

scalvect(crossvect(rest u1,rest u2),minvect(rest u1,rest u2));


0

;


% 10. NEW OPERATIONS ON MATRICES
;


clear m,mm,b,b1,bb,cc,a,b,c,d;


matrix mm(2,2);


baglmat(bag(bag(a1,a2)),m);


T

m;


[A1  A2]


on errcont;


;


baglmat(bag(bag(a1),bag(a2)),m);


***** (MAT ((*SQ ((((A1 . 1) . 1)) . 1) T) (*SQ ((((A2 . 1) . 1)) . 1) T))) 
should be an identifier 

off errcont;


%    **** i.e. it cannot redefine the matrix! in order
%         to avoid accidental redefinition of an already given matrix;

clear m;

 baglmat(bag(bag(a1),bag(a2)),m);


T

m;


[A1]
[  ]
[A2]


on errcont;


baglmat(bag(bag(a1),bag(a2)),bag);


***** OPERATOR BAG invalid as matrix

off errcont;


% Right since a bag-like object cannot become a matrix.
coercemat(m,op);


OP(OP(A1),OP(A2))

coercemat(m,list);


{{A1},{A2}}

;


on nero;


unitmat b1(2);


matrix b(2,2);


b:=mat((r1,r2),(s1,s2));


     [R1  R2]
B := [      ]
     [S1  S2]


b1;


[1  0]
[    ]
[0  1]

b;


[R1  R2]
[      ]
[S1  S2]


mkidm(b,1);


[1  0]
[    ]
[0  1]


% Allows to relate matrices already defined.
;


% Convenient to replace or get a matrix element inside a procedure :
%
seteltmat(b,newelt,2,2);


[R1    R2  ]
[          ]
[S1  NEWELT]


geteltmat(b,2,1);


S1

%
b:=matsubr(b,bag(1,2),2);


     [R1  R2]
B := [      ]
     [1   2 ]


% It gives automatically a new matrix with the second row substituted.
;


submat(b,1,2);


[1]


% What is left when row 1 and column 2 are taken off the matrix.
bb:=mat((1+i,-i),(-1+i,-i));


      [I + 1   - I]
BB := [           ]
      [I - 1   - I]


cc:=matsubc(bb,bag(1,2),2);


      [I + 1  1]
CC := [        ]
      [I - 1  2]


% Second column substituted.
cc:=tp matsubc(bb,bag(1,2),2);


      [I + 1  I - 1]
CC := [            ]
      [  1      2  ]


matextr(bb, bag,1);


BAG(I + 1, - I)

% First row extracted and placed in a bag.
matextc(bb,list,2);


{ - I, - I}

% Second column  extracted and placed in a bag.
;


hconcmat(bb,cc);


[I + 1   - I  I + 1  I - 1]
[                         ]
[I - 1   - I    1      2  ]


vconcmat(bb,cc);


[I + 1   - I ]
[            ]
[I - 1   - I ]
[            ]
[I + 1  I - 1]
[            ]
[  1      2  ]


% Horizontal an vertical concatenations.
;


tpmat(bb,bb);


[ 2*I     - I + 1   - I + 1  -1]
[                              ]
[  -2     - I + 1   I + 1    -1]
[                              ]
[  -2     I + 1     - I + 1  -1]
[                              ]
[ - 2*I   I + 1     I + 1    -1]


% Tensor product.
%
% It is an INFIX operation :
bb tpmat bb;


[ 2*I     - I + 1   - I + 1  -1]
[                              ]
[  -2     - I + 1   I + 1    -1]
[                              ]
[  -2     I + 1     - I + 1  -1]
[                              ]
[ - 2*I   I + 1     I + 1    -1]


;


clear hbb;


hermat(bb,hbb);


[ - I + 1   - (I + 1)]
[                    ]
[   I          I     ]


% id hbb changed to a matrix id and assigned to the hermitian matrix
% of bb.
;


showtime;


Time: 2210 ms

end;


Time: 17 ms


Quitting

Added r34.1/lib/assist.red version [f968fdd3e2].





































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
module assist; % Header Module for REDUCE 3.4 Extensions.

% create!-package('(assist switchext baglist genpurfunc control
%                   polyextensions transfunctions vectoroper matrext),
%                                    '(contrib assist));

% % ********************************************************************
%
%                Author: H. Caprasse <u214001@bliulg11.bitnet>.
%                      or            <u214001@vm1.ulg.ac.be>
%
% Version and Date:  Version 1.1, 15 September 1991.
% Revision history for version 1.0 :
%
% 5 Aug. 1991 :   Corrections to RCONS
%                 Property NUMBER!_OF!_ARGS commented.
%                 Flag "NOVAL" on REDEXPR and LEADTERM eliminated.
% 1 Sept. 1991 :  MAXLIST and MINLIST eliminated since they exist
%                 now in the basic package.
% 6 Sept. 1991 :  Module "transfunctions" rewritten to conform to
%                 the new syntax for rules.
%                 FACT function eliminated since in the ARITH
%                 package under the name FACTORIAL.
%                 Function SIMPLIFY added to enforce full
%                 simplification in outputs of EXCALC.
% 12 Sept.1991 :  Capabilities of the functions SHOW and SUPPRESS
%                 enlarged.
%                 Control of switches extended.
% ********************************************************************
%
endmodule;


module switchext$

fluid '(!*distribute);

switch distribute;

flag('(!*factor !*mcd !*div !*exp !*gcd !*rat !*rational !*rationalize
        !*intstr !*reduced !*ratpri !*revpri !*distribute
        !*ezgcd !*complex !*reduced !*lcm !*precise),'share)$


endmodule$


module baglist$

symbolic procedure rmklis u$
% This function works only for LIST-like objects.
begin scalar s,ss;integer n;
argnochk('mklist . u);
if length u = 2  then
<<s:=reval car u; n:=reval cadr u;
if car s eq 'list then  ss:=
     append(s,cdr rmklis(list(n+1-length s))) else nil>> else
if length u=1 then
 <<n:=reval car u; for j:=1:n do s:=0 . s; ss:='list . s>>
else nil;
return ss end;

put('mklist,'psopfn,'rmklis);

global '(!:flaglis !:proplis); % To make properties and flags
                               % available in algebraic mode.

put('bag,'simpfn,'simpiden);

flag('(bag),'bag)$  % the default bag
flag('(bag),'reserved)$

symbolic (!:flaglis:=union(list list2('bag,'bag),!:flaglis))$

symbolic procedure !:delete(u,prop,val)$
if prop then
for each x in !:proplis do if x=list3(u,prop,val)
              then !:proplis:=delete(x,!:proplis) else nil else
for each x in !:flaglis do if x=list2(u,val)
              then !:flaglis:=delete(x,!:flaglis);

symbolic procedure !:bagno u; u eq 'list or flagp(u,'boolean);

symbolic procedure !:bagyes u; getd u or
                  gettype u member list('tvector,'vector) or
                  flagp( u,'opfn) or
                  get(u,'simpfn) or get(u,'psopfn) or
                  get(u,'fdegree) or get(u,'ifdegree);

symbolic procedure simpbagprop u$
% gives the bag property to identifier or baglike-list of identifiers U
% V is T if one creates the property or 0 if one destroys it.
% Use is bagprop(<list of atoms>,T or 0)
% Makes tests to avoid giving this property to an unsuitable object.
   begin scalar id,bool;
   id:= car u; bool:= if  cadr u eq t then t;
   if listp id then
    << for each x in id do simpbagprop list(x,bool) $
     return bool>> else
   if  idp id and bool=t then
         if !:bagno id then typerr (id,"BAG") else
         if !:bagyes id then <<flag(list id,'bag),go to l1>> else
         <<put(id,'simpfn,'simpiden)$ flag(list id,'bag)$ go to l1>>
   else
   if  idp id and not bool  then
   <<remflag(list id,'bag); go to l1>>
   else  rederr("BAD ARGUMENT for bagprop");
l1: if bool then !:flaglis:=union(list list2(id,'bag),!:flaglis)
      else !:delete(id,nil,'bag) end;

symbolic procedure putbag u; simpbagprop list(u,t);
% gives the bag property to identifier or baglike-list of identifiers u
% V is T to create the bag property.

symbolic procedure clearbag u; simpbagprop list(u,0);
% destroys the bag property of the identifier or the baglike-list u

symbolic rlistat '(putbag clearbag);

symbolic procedure bagp(u)$
% test of the baglike property of U$
not atom u and flagp(car u ,'bag)$

flag('(bagp),'boolean);

symbolic procedure nbglp(u,n)$
%Function which determines if U is not a bag at the level N.
% Used in DEPTH.
if n=0 then not baglistp u else
if atom u or not bglp!:!: car u  then nil else
begin scalar uu$ uu:= u$
 l1:  uu:=cdr uu$
    if null uu then return t$
    if nbglp(car uu,n-1) then  go to l1 else
          return nil end$

symbolic procedure bglp!:!: u;
if not atom u then bglp!:!: car u else
     if (flagp(u,'bag) or u eq 'list) then t else nil;

symbolic procedure baglistp u;
% This function is supposed to act on a prefix simplified expression.
not atom u and ( car u eq 'list  or flagp(car u,'bag));

symbolic procedure nul!: u; baglistp u and null cdr u;

symbolic flag('(baglistp nul!:),'boolean);

symbolic procedure alistp u$
% Not for use in algebraic mode.
if null u then t else
(not atom car u) and alistp cdr u;

symbolic procedure abaglistp u;
% For use in algebraic mode. Recognizes when a bag-like object
% contains bags which themselves contain two and only two objects.
if null baglistp u or null baglistp cadr u then nil else
     begin;
l1:  u:=cdr u;
    if null u then return t ;
     if length car u <3 then return nil else go to l1 end;

         flag('(abaglistp),'boolean);

% Definitions of operations on lists

symbolic procedure rexplis u;
% THIS PROCEDURE GENERALIZES BAGLIST TO ANY OBJECT AND GIVES A LIST OF
% THE ARGUMENTS OF U.
<<argnochk('kernlist . u);
if atom ( u:=reval car u) then nil else
if kernp mksq(u,1) then 'list . cdr u>> ;

put('kernlist,'psopfn,'rexplis);

symbolic procedure rlisbag u$
begin scalar x,prf;
argnochk('listbag . u);
x:=reval car u; prf :=reval cadr u;
if atom x then return nil else
<<simpbagprop list(prf,t) ; x:=prf . cdr x>>;
return x end;

% symbolic put('rlisbag,'number!_of!_args,2);
symbolic put('listbag,'psopfn,'rlisbag);


symbolic procedure rfirst li;
<<argnochk('first . li);
  if bagp( li:=reval car li) then
  if null cdr li then car li . nil else  car li . cadr li . nil else
  if car li neq 'list then typerr(li,"list or bag")
  else if null cdr li then parterr(li,1)
  else cadr li>>$

put('first,'psopfn,'rfirst);

symbolic procedure rsecond li;
   <<argnochk ('second . li);
   if bagp( li:=reval car li) then
   if null cdr li or null cddr li then  car li . nil
    else  car li . caddr li . nil
   else if car li neq 'list then typerr(li,"list or bag")
   else if null cdr li or null cddr li then parterr(li,2)
   else caddr li>>;

put('second,'psopfn,'rsecond);

symbolic procedure rthird li;
   <<argnochk ('third . li);
     if bagp( li:=reval car li) then
    if null cdr li  or null cddr li or null cdddr li
    then car li . nil else  car li . cadddr li . nil
    else if car li neq 'list then typerr(li,"list or bag")
    else if null cdr li or null cddr li or null cdddr li
    then parterr(li,3)
    else cadddr li>>;

symbolic procedure rrest li;
<<argnochk('rest . li);
if bagp( li:=reval car li) then
if null cdr li then li . nil else  car li . cddr li  else
if car li neq 'list then typerr(li,"list or bag")
else 'list . if null (li:=cdr li) then li else cdr li>>$

symbolic put('rest,'psopfn,'rrest);

symbolic procedure rreverse u;
<<argnochk('reverse . u); u:=reval car u;
if bagp u then car u . reverse cdr u  else
if car u neq 'list  then typerr(u,"list or bag")
else 'list . reverse cdr u>>$

symbolic  put('reverse,'psopfn,'rreverse);

symbolic procedure rlast u;
<<argnochk('last . u); u:=reval car u;
if bagp u then if null cdr u then u else
    car u . car reverse cdr u . nil
 else if car u neq 'list  then typerr(u,"list or bag")
 else  if null cdr u then nil
 else car  reverse cdr u>>$

symbolic put('last,'psopfn,'rlast);

symbolic procedure rdc u;
if null cdr u then nil else car u . rdc cdr u;

symbolic procedure rbelast u;
<<argnochk('belast . u); u:=reval car u;
if bagp u then if null cdr u then u else car u . rdc cdr u else
if car u neq 'list then typerr(u,"list or bag")
else if null cdr u then u else 'list . rdc cdr u>>$

put('belast,'psopfn,'rbelast);

symbolic procedure rappend u;
   begin scalar x,y;
      argnochk ('append . u);
   if length u neq 2 then rederr("append has TWO arguments");
      x:=reval car u;
      y:=reval cadr u;
   if baglistp x and baglistp y  then
                     return car x . append(cdr x,cdr y) else
       typerr(list(x,y),"list or bag")
  end ;

% put('rappend,'number!_of!_args,2);

put('append,'psopfn,'rappend);

symbolic procedure rcons u;
% This procedure does not work perfectly well when the package
% HEPHYS is entered because ISIMPA is applied by reval1 on the
% result of RCONS. When it is given by (BAG (LIST A B) C D) it gives
% the output BAG({A,B}) erasing C and D ! It is due to the fact that
% ISIMP1 and ISIMP2 do not accept SQ forms for identifiers.
% So avoid inputs like list(a,b).bag(c,d) when HEPHYS is loaded.
 begin scalar x,y,z;
      if (y := getrtypeor(x := revlis u)) eq 'hvector
        then return if get('cons,'opmtch) and (z:=opmtch('cons . x))
                      then reval z
                    else prepsq simpdot x
      else if getrtype(y:=cadr x) eq 'list
             then return  'list . car x . cdadr x
      else if bagp y
             then return   z:=car y . car x . cdr y
       else if fixp y
          then return z:=revalpart u
       else typerr(x,"list or bag")
   end;

% symbolic put('rcons,'number!_of!_args,2);

symbolic put('cons,'setqfn,'setpart!*);
symbolic put('cons,'psopfn,'rcons);

symbolic procedure lengthreval u;
   begin scalar v,w;
      if length u neq 1
        then rederr "LENGTH called with wrong number of arguments"
       else if idp car u and arrayp car u
        then return 'list . get(car u,'dimension)
       else if bagp (u:=reval car u)
        then return  length cdr u;
      v := aeval u;
      if (w := getrtype v) and (w := get(w,'lengthfn))
        then return apply1(w,v)
       else if atom v then return 1
       else if not idp car v or not(w := get(car v,'lengthfn))
        then typerr(u,"length argument")
       else return apply1(w,cdr v)
   end;

symbolic put('length,'psopfn,'lengthreval);
symbolic put('size,'psopfn,'lengthreval);

symbolic procedure rremove u;
% Allows one to remove the element n of bag u.
% First argument is a bag or list, second is an integer.
 if length u neq 2 then
       rederr("remove called with wrong number of arguments") else
begin scalar x;integer n;
argnochk('remove . u);
x:=reval car u; n:=reval cadr u;
if baglistp x  then return car x . remove(cdr x,n) else
rederr(" first argument is a list or a bag, second is an integer")
 end;

% symbolic put('rremove,'number!_of!_args,2);

symbolic put('remove,'psopfn,'rremove);

symbolic procedure rdelete u;
begin scalar x,y;
x:=reval car u; y:=reval cadr u;
if baglistp y then return delete(x,y) end;

symbolic put('delete,'psopfn,'rdelete);

% Use is delete(<any>,<bag or list>)

symbolic procedure rmember u;
% First argument is anything, second argument is a bag or list.
begin scalar x,y$
 argnochk('member . u);
 x:=reval car u;
 y:=reval cadr u;
if baglistp y then
              if (x:=member(x,cdr y))
              then return car y . x else return nil
 else typerr(y,"list or bag") end;

% symbolic put('rmember,'number!_of!_args,2);

symbolic put('member,'psopfn,'rmember);

% INPUT MUST BE " member (any , < bag OR list> ) ".

symbolic procedure relmult u;
if length u neq 2 then
      rederr("elmult called with wrong number of arguments") else
begin scalar x,y; integer n;
 argnochk('elmult . u);
 x:=reval car u;  % It is the object the multiplicity of which one
                  % wants to compute.
 y:=reval cadr u; % IT IS THE list OR bag
if x=y then return 1 else
if baglistp y then
            <<y:=cdr y;
             while not null (y:=member(x,y)) do <<y:=cdr y;n:=n+1>>>>
         else typerr(y,"list or bag");
return n end;

% symbolic put('relmult,'number!_of!_args,2);

symbolic put('elmult,'psopfn,'relmult);

% Use is  " elmult (any , < bag OR list> ) " .

symbolic procedure rpair u$
begin scalar x,y,prf$
argnochk('pair . u);
if length u neq 2 then
      rederr("pair called with wrong number of arguments");
x:=reval car u; y:=reval cadr u$
if not (baglistp x and baglistp y) then
                  rederr("arguments must be lists or bags") else
prf:=car x;x:=cdr x; y:=cdr y;
y:=pair(x,for each j in y collect list j);
return y:=prf . for each j in y collect prf . j  end;

% symbolic put('rpair,'number!_of!_args,2);

symbolic put('pair,'psopfn,'rpair);

symbolic procedure depth!: u;
   if not atom u and (car u eq 'list or flagp(car u,'bag))
     then 1 + depth!: cadr u
    else 0;

symbolic procedure rdepth(u)$
% Use is depth(<BAG or LIST>).
begin scalar x; integer n;
argnochk('depth . u);
x := reval car u;
if nbglp(x,n:=depth!: x) then
     return n else return "bag or list of unequal depths" end;

put('depth,'psopfn,'rdepth);

symbolic procedure rinsert u;
% Use is insert(<any>, <list or bag>, <integer>).
begin scalar x,bg,bbg,prf; integer n;
argnochk('insert . u);
bg:=reval cadr u; n:=reval caddr u;
if not baglistp bg then typerr(bg,"list or bag") else
if n<=0 then rederr("third argument must be positive an integer") else
if (n:=n+1) > length bg then return append(bg,x:=list reval car u);
 prf:=car bg; x:=reval car u;
 for i:=3:n do <<bg:=cdr bg; bbg:=car bg . bbg>>;
 bbg:=reverse bbg;
 return bbg:=prf . append(bbg,cons(x,cdr bg))
 end;

% symbolic put('insert,'number!_of!_args ,3);

symbolic put('insert,'psopfn,'rinsert);

symbolic procedure rposition u$
% Use is position(<any>,<LIST or BAG>).
begin scalar el,bg; integer n;
el:=reval car u;
if not baglistp (bg:=reval cadr u) then typerr(bg," list or bag");
n:=length( bg:=cdr bg);
if (bg:=member(el,bg))
             then return (n:=n+1-length bg)  else
 msgpri(nil,el,"is not present in list or bag",nil,nil) end;

% put('rposition,'number!_of!_args,2);

put('position,'psopfn,'rposition);

% **********

% The functions below, when applied to objects containing SEVERAL bag
% prefixes have a rule to select them in the output object when this
% one is itself a bag: the first level prefix has priority over all
% other prefixes and will be selected, when needed, as the envelope
% of the output.

symbolic procedure !:assoc u;
if length u neq 2 then
      rederr("asfirst called with wrong number of arguments") else
begin scalar x,y,prf;
argnochk('asfirst . u);
x:=reval car u; y:=reval cadr u;
if null baglistp y then typerr(y,"list or bag");
prf:=car y; y:=cdr y;
if null alistp y then typerr(y, "association list") else
    y:=for each j in y collect cdr j;
return  if null (y:=assoc(x,y)) then nil else prf . y   end;

% symbolic put ('!:assoc,'number!_of!_args,2);

symbolic put('asfirst,'psopfn,'!:assoc);

% Use is : asfirst(<key>,<a-list>Y<a-bag>)

symbolic procedure !:rassoc u;
if length u neq 2 then
      rederr("assecond called with wrong number of arguments") else
begin scalar x,y,prf;
argnochk('assecond . u);
x:=reval car u; y:=reval cadr u;
if null baglistp y then typerr(y,"list or bag");
prf:=car y; y:=cdr y;
if null alistp y then typerr(y, "association list") else
    y:=for each j in y collect cdr j;
return  if null (y:=rassoc(list x,y)) then nil else prf . y   end;

% symbolic put ('!:rassoc,'number!_of!_args,2);

symbolic put('assecond,'psopfn,'!:rassoc);

% Use is : assecond(<key>,<a-list>Y<a-bag>)

symbolic procedure !:assoc2 u;
if length u neq 2 then
      rederr("asrest called with wrong number of arguments") else
begin scalar x,y,prf;
argnochk('asrest . u);
x:=reval car u; y:=reval cadr u;
if null baglistp x or null baglistp y then
 typerr(list(x,y),"list or bag");
prf:=car y; y:=cdr y; x:=cdr x;
if null alistp y then typerr(y, "association list") else
    y:=for each j in y collect cdr j;
return  if null (y:=assoc2(x,y)) then nil else prf . y   end;

% symbolic put ('!:assoc2,'number!_of!_args,2);

symbolic put('asrest,'psopfn,'!:assoc2);

% Use is : asrest(<key>,<a-list>Y<a-bag>)

symbolic procedure lastassoc!*(u,v);
% Use is :
% aslast(<key as a last element>,<a-list>Y<a-bag>)
% Finds the sublist in which u is the last element in the
% compound list  or bag v, or nil if it is not found.
   if null v then nil
    else begin scalar vv; vv:=car v;
          while length vv > 1  do vv:=cdr vv;
          if u = car vv then return car v
    else return lastassoc!*(u,cdr v) end;

symbolic procedure !:lassoc u;
if length u neq 2 then
      rederr("aslast called with wrong number of arguments") else
begin scalar x,y,prf;
argnochk('aslast . u);
x:=reval car u; y:=reval cadr u;
if null baglistp y then typerr(y,"list or bag");
prf:=car y; y:=cdr y;
if null alistp y then typerr(y, "association list") else
    y:=for each j in y collect cdr j;
return  if null (y:=lastassoc!*(x,y)) then nil else prf . y   end;

% symbolic put ('!:lassoc,'number!_of!_args,2);

symbolic put('aslast,'psopfn,'!:lassoc);

symbolic procedure rasflist u;
% Use is :
% asflist(<key as a first element>,<a-list>Y<a-bag>)
% This procedure gives the LIST (or BAG) associated with the KEY con-
% tained in the first argument. The KEY is here the FIRST element
% of each sublist contained in the association list .
if length u neq 2 then
      rederr("ASFLIST called with wrong number of arguments") else
begin scalar x,y,prf,res,aa;
 x:=reval car u; y:=reval cadr u; prf:=car y;
 if null cdr y then return y;
 for each j in cdr y do if car j neq prf then
 rederr list("prefix INSIDE the list or bag neq to",prf);
  l1: aa:=!:assoc(list(x,y));
     if not aa then return prf . reverse res;
     res:=aa . res;
     y:=delete(aa,y);
     go to l1;
                end$

symbolic put('asflist,'psopfn,'rasflist);

symbolic procedure rasslist u;
% Use is :
% asslist(<key as the second element>,<a-list>Y<a-bag>)
if length u neq 2 then
      rederr("ASSLIST called with wrong number of arguments") else
begin scalar x,y,prf,res,aa;
 x:=reval car u; y:=reval cadr u; prf:=car y;
 if null cdr y then return y;
 for each j in cdr y do if car j neq prf then
 rederr list("prefix INSIDE the list or bag neq to",prf);
  l1: aa:=!:rassoc(list(x,y));
     if not aa then return prf . reverse res;
     res:=aa . res;
     y:=delete(aa,y);
     go to l1;
                end$

symbolic put('asslist,'psopfn,'rasslist);

symbolic procedure !:sublis u;
% Use is :
% restaslist(<bag-like object containing keys>,<a-list>Y<a-bag>)
% Output is a list containing the values associated to the selected
% keys.
if length u neq 2 then
    rederr("restaslist called with wrong number of arguments") else
begin scalar x,y,yy,prf;
argnochk('sublis . u);
x:=reval car u;
y:=reval cadr u; prf:=car y;
if null baglistp y then typerr(y,"list or bag") else
if null alistp (y:=cdr y) then typerr(y," association list or bag")
else  y:=for each j in y collect cdr j;
if baglistp x then <<x:=cdr x; x:=for each j in x collect
                        if  assoc(j,y) then j>>;
y:=sublis(y,x); if atom y then yy:=list y else
for each j in y do if not null j then yy:=j . yy;
yy:=reverse yy;
return  prf . for each j in yy collect
                     if atom j then prf . j . nil else prf . j$
        end$

% symbolic put('!:sublis,'number!_of!_args,2);

symbolic put('restaslist,'psopfn,'!:sublis);

% Use is :
% restaslist(<bag-like object containing keys>,<a-list>Y<a-bag>)
% Output is a list containing the values associated to the selected
% keys.
% ******* End of functions which may change bag- or list- prefixes.

% FOR SUBSTITUTION OF IDENTIFIERS IT IS CONVENIENT TO USE :

symbolic procedure !:subst u;
<<argnochk('substitute . u);
        reval subst(reval car u,reval cadr u,reval caddr u)>>;

% symbolic put('!:subst,'number!_of!_args,3);

symbolic put('substitute,'psopfn,'!:subst);

% Use is : substitute(<newid>,<oldid>,<in any>).
% May serve to transform ALL bags into lists or vice-versa.

symbolic procedure !:repla u;
if length u neq 2 then
      rederr("repfirst called with wrong number of arguments") else
begin scalar x,y,prf;
 argnochk('repfirst . u);
y:=reval car u; x:= reval cadr u;
if null baglistp x then typerr(x,"list or bag");
prf:= car x; x:=cdr x;
return prf . rplaca(x,y) end;

% symbolic put('!:repla,'number!_of!_args,2);

symbolic put('repfirst,'psopfn,'!:repla);

% Use is : repfirst(<any>, <bag or list>);

symbolic procedure !:repld u;
% Use is : replast(<any>, <bag or list>);
begin scalar x,y,prf;
 argnochk('represt . u);
if length u neq 2 then
      rederr("replast called with wrong number of arguments");
y:=reval car u; x:= reval cadr u;
if null baglistp x then typerr(u,"list or bag");
prf:= car x; x:=cdr x;
return prf . rplacd(x,list y) end;

% symbolic put('!:repld,'number!_of!_args,2);

symbolic put('represt,'psopfn,'!:repld);

symbolic procedure rinsert u;
begin scalar x,bg,bbg,prf; integer n;
argnochk('insert . u);
bg:=reval cadr u; n:=reval caddr u;
if not baglistp bg then typerr(bg,"list or bag") else
if n<=0 then rederr("third argument must be positive integer") else
if (n:=n+1) > length bg then return append(bg,x:=list reval car u);
 prf:=car bg; x:=reval car u;
 for i:=3:n do <<bg:=cdr bg; bbg:=car bg . bbg>>;
 bbg:=reverse bbg;
 return bbg:=prf . append(bbg,cons(x,cdr bg))
 end;

% symbolic put('insert,'number!_of!_args ,3);

symbolic put('insert,'psopfn,'rinsert);

% Use is : insert(<any>, <list or bag>, <integer>).

% HERE ARE FUNCTIONS FOR SETS.

symbolic procedure !:union u$
begin scalar x,y,prf;
argnochk('union . u);
if length u neq 2 then
      rederr("union called with wrong number of arguments");
x:=reval car u; y:=reval cadr u;
if baglistp x and baglistp y then
<<prf:=car y; y:=prf . union(cdr x,cdr y)>> else return nil;
return y end;

% symbolic put('!:union,'number!_of!_args,2);

symbolic put('union,'psopfn,'!:union);

symbolic procedure setp u;
null repeats u;

symbolic flag('(setp),'boolean);

symbolic procedure !:mkset u$
if null u then nil else if member(car u,cdr u) then !:mkset cdr u
else car u . !:mkset cdr u$

symbolic procedure rmkset u;
begin scalar x,prf$
 argnochk('mkset . u); x:=reval car u; prf:=car x;
  if baglistp x then return prf . !:mkset cdr x end;

symbolic put('mkset,'psopfn,'rmkset);

symbolic procedure !:setdiff u$
begin scalar x,y,prf;
argnochk('diffset . u);
if length u neq 2 then
      rederr("diffset called with wrong number of arguments");
x:=reval car u; y:=reval cadr u;
if baglistp x and baglistp y then
<<prf:=car y; y:=prf . setdiff(cdr x,cdr y)>> else return nil;
return y end;

% symbolic put('!:setdiff,'number!_of!_args,2);

symbolic put('diffset,'psopfn,'!:setdiff);

symbolic procedure !:symdiff u$
begin scalar x,y,prf;
argnochk('symdiff . u);
if length u neq 2 then
      rederr("symdiff called with wrong number of arguments");
x:=reval car u; y:=reval cadr u; prf:=car x;
if setp x and setp y then return
prf . append(setdiff(x:=cdr x,y:=cdr y),setdiff(y,x))
 end;

% symbolic put('!:symdiff,'number!_of!_args,2);

symbolic put('symdiff,'psopfn,'!:symdiff);

symbolic procedure !:xn u$
begin scalar x,y,prf;
argnochk('intersect . u);
if length u neq 2 then
      rederr("intersect called with wrong number of arguments");
x:=reval car u; y:=reval cadr u;
if setp x and setp y then return car x . intersection(cdr x,cdr y)
 end;

% symbolic put('!:xn,'number!_of!_args,2);

symbolic put('intersect,'psopfn,'!:xn);

endmodule ;

module genpurfunc;

%=====================================================================$
%                                                                     $
% VARIOUS GENERAL PURPOSE FUNCTIONS                                   $
%                                                                     $
%=====================================================================$

% 1. GENERALIZATION OF EXISTING FUNCTIONS


symbolic procedure mkidn(u)$
% generalizes "mkid" for any number of atoms
% Input is mkidn(list(a1,...ak)Ybag(a1,...,ak)).
expand(cdr u, 'mkid);

flag('(mkidn),'opfn);


symbolic procedure simpsetf u;
% generalizes the function "set" to kernels.
  begin scalar x;
     x := simp!* car u;
if not kernp x  or fixp (!*q2a x) then
                           typerr(!*q2a x,"setvalue kernel") else
      x:=!*q2a x;
     let0 list(list('equal,x,mk!*sq(u := simp!* cadr u)));
     return u
  end;

put ('setvalue, 'simpfn, 'simpsetf);

newtok '((!= !=) setvalue ! !=!=! );

infix ==;

symbolic procedure inf2(n,m);
if evalgreaterp(n,m) then m else n;

symbolic procedure sup2(n,m);
if evalgreaterp(n,m) then n else m;

flag('(inf2,sup2),'opfn);

flag('(prin2 ) ,'opfn); % To make it available in the alg. mode.


% 2. NEW ELEMENTARY FUNCTIONS CLOSELY RELATED TO EXISTING ONES.

symbolic procedure oddp u$
% Tests if integer U is odd. Is also defined in EXCALC;
fixp u and  remainder(u,2)=1$

symbolic procedure evenp  u;
not oddp u;

symbolic flag('(oddp evenp),'boolean);

symbolic procedure followline(n)$
% It allows to go to a new line at the position  given by the integer N.
<< terpri()$ spaces(n)>>$

symbolic flag('(followline ) ,'opfn);

% 3. NEW GENERAL PURPOSE FUNCTIONS.

symbolic procedure charnump!: x;
 if x member list('!0,'!1,'!2,'!3,'!4,'!5,'!6,'!7,'!8,'!9) then t ;

symbolic procedure charnump u;
if null u then t else charnump!: car u and charnump cdr u;

 symbolic procedure detidnum u;
 % Allows one to extract the index number from the identifier u.
 if idp u then
 begin scalar uu;
   if length(uu:= cdr explode u) =1 then go to l1
    else
    while not charnump uu do uu:=cdr uu;
l1: uu:= compress uu;
    if fixp uu then return uu end;

flag('(detidnum),'opfn);

symbolic procedure randomlist(n,trial);
% This procedure gives a list of trials in number "trial" of
% random numbers between 0 and n. For the algorithm see KNUTH vol. 2.
'list . lisp for j:=1:trial collect random n;

flag('(randomlist),'opfn);

algebraic procedure combnum(n,nu)$
% Number of combinations of n objects nu to nu.
if nu>n then
rederr "second argument cannot be bigger than first argument"
else  factorial(n)/factorial(nu)/factorial(n-nu)$

symbolic procedure rpermutation u;
<<argnochk('permutations . u); if not baglistp(u:=reval car u) then
nil else if null cdr u then 'list . nil  else
begin scalar x,prf$ prf:=car u$
    u:=cdr u$
    x:=for each j in  u
    conc  mapcons(permutations delete(j,u),j)$
    x:=for each j in x collect prf . j$
    return prf . x end>>;

put('permutations,'psopfn,'rpermutation);

symbolic procedure !:comb(u)$
begin scalar x,prf; integer n;
argnochk('combinations . u);
if length u neq 2 then
     rederr "combinations called with wrong number of arguments";
x:=reval car u ;  if not baglistp x then return nil ;


prf :=car x; x:=cdr x; n:=reval cadr u;
return prf . (for each j in comb(x,n) collect prf . j)
 end;

symbolic put('combinations,'psopfn,'!:comb);

symbolic procedure rfuncvar(u)$
% U is an arbitrary expression
% Gives a list which contains all the variables whom U depends
% in an ARBITRARY order$
<<if atom (u:=reval car u) then
if not flagp(u,'reserved) then
        if depatom u neq u  then depatom u else nil
else nil else
 begin scalar wi,aa$
  aa:=listofvars(u)$
% if null cdr aa then return car aa else
  if null cdr aa then return
      if flagp(car aa,'reserved) or flagp(car aa,'constant)
      then nil else car aa else
  aa:=!:mkset aa $ wi:=aa$
  while wi do if flagp(car wi ,'reserved) then
    <<aa:=delete(car wi ,aa)$ wi:=cdr wi >> else wi:=cdr wi $
  return aa:='list . aa end >>;

flag('(e i),'reserved);

symbolic procedure listofvars u $
if null u  or numberp u  then nil else
if atom u then list u else
varsinargs cdr u $

symbolic procedure varsinargs(u)$
if null u then nil else
append(listofvars car u,varsinargs cdr u)$

symbolic put('funcvar,'psopfn ,'rfuncvar);

symbolic procedure implicit u;
if atom u then u else
 begin scalar prf;
 prf:=car u;
 if get(prf,'simpfn) neq 'simpiden  then
                          rederr list(u,"must be an OPERATOR");
 remprop(car u,'simpfn);
 depl!*:=union(list (car u . reverse
           for each y in cdr u collect implicit y),depl!*);
 return prf end;

symbolic procedure depatom a$
%Gives a list of variables declared in DEPEND commands whom A depends
%A must be an atom$
    if not atom a then rederr("ARGUMENT MUST BE AN ATOM") else
         if null assoc(a,depl!*) then a  else
                            'list . reverse cdr assoc(a,depl!*);
flag('(depatom),'opfn);

symbolic procedure explicit u$
% U is an atom. It gives a function named A which depends on the
% variables detected by DEPATOM and this to all levels$
begin scalar aa$
    aa:=depatom u $
    if aa = u then  return u$
    put(u,'simpfn,'simpiden)$
    return u . (for each x in cdr aa collect explicit x) end$

symbolic flag('(implicit explicit),'opfn);

symbolic procedure simplify u;
% Enforces simplifications if necessary.
% u is any expression.
mk!*sq resimp simp!* reval u;

symbolic flag('(simplify),'opfn);

% 4. FUNCTIONS TO DEAL WITH PROPERTIES IN THE ALGEBRAIC MODE.

global('(!:flaglis !:proplis));
symbolic(!:flaglis:=union(list list2('bag,'bag),!:flaglis));

symbolic procedure putflag(u,flg,b)$
% Allows one to put or erase any FLAG on the identifier U.
% U is an idf or a list of idfs, FLAG is an idf, B is T or 0.
if not idp u and not null baglistp u then
              <<for each x in cdr u do putflag(x,flg,b)$ t>>
 else      if idp u and b eq t then
            <<flag(list u, flg)$
              !:flaglis:=union(list list2(u, flg),!:flaglis)$ u>>
 else      if idp u and b equal 0 then
            <<remflag( list u, flg)$ !:delete(u,nil,flg)$>>
 else rederr "*** VARIABLES ARE (idp OR list of flags, T or 0).";


symbolic procedure putprop(u,prop,val,b)$
% Allows to put or erase any PROPERTY on the object U
% U is an idf or a list of idfs, B is T or 0$
if not idp u and baglistp u then
              <<for each x in cdr u do putprop(x,prop,val,b)$ t>>
 else      if idp u and b eq t then
            <<put(u, prop,val)$
              !:proplis:=union(list list3(u,prop,val),!:proplis)$ u>>
 else      if idp u and b equal 0 then
            <<remprop( u, prop)$  !:delete(u,prop,val)$ >>
 else rederr "*** VARIABLES ARE (idp OR list of idps, T or 0).";

symbolic  flag('(putflag putprop),'opfn)$

symbolic procedure rdisplayprop(u)$
% U is the idf whose properties one wants to display.Result is a
% list which contains them$
begin scalar x,val,aa$ x:=reval car u; val:=reval cadr u;
for each j in !:proplis do if car j eq x and cadr j eq val
                          then aa:=('list . cdr j) . aa;
return 'list . aa end;

symbolic put('displayprop,'psopfn,'rdisplayprop)$
symbolic put('displayflag,'psopfn,'rdisplayflag)$

symbolic procedure rdisplayflag(u)$
% U is the idf whose properties one wants to display.Result is a
% list which contains them$
begin scalar x,aa$ x:=reval car u;
for each j in !:flaglis do if car j=x then aa:=cons(cadr j,aa)$
return 'list . aa end;

symbolic procedure clrflg!: u;
for each x in !:flaglis do
            if u eq car x then putflag(car x,cadr x,0) ;

symbolic procedure clearflag u;
% If u equals "all" all flags are eliminated.
% If u is a1,a2,a3.....an flags of these identifiers are eliminated.
if null cdr u and car u eq 'all then for each x in !:flaglis
          do putflag (car x,cadr x,0) else
 if null cdr u then clrflg!: car u else
                for each  y in u do clrflg!: y;

symbolic procedure clrprp!: u;
for each x in !:proplis do
      if u eq car x then putprop(car x,cadr x,caddr x,0);

symbolic procedure clearprop u;
% If u equals "all" all properties are eliminated.
% If u is a1,a2,a3...an properties of these identifiers are eliminated.
if null cdr u and car u eq 'all then for each x in !:proplis
          do putprop(car x,cadr x,caddr x,0) else
if null cdr u then clrprp!: car u else
                for each  y in u do clrprp!: y;

symbolic put('clearflag,'stat,'rlis);
symbolic put('clearprop,'stat,'rlis);

endmodule;

module control;

% functions which offer a BETTER CONTROL on $
                % various objects and of the ALREADY USED quantities $

% 1. BOOLEAN functions.

flag('(null idp flagp),'boolean);

symbolic procedure nordp(u,v);
% TRUE if a>b, FALSE if a=<b. NOT USED HERE.
not ordp(u,v);


symbolic procedure depvarp(u,v)$
% V is an idf. or a kernel$
    if depends(u,v)  then t else nil$

symbolic procedure alatomp(u)$
% U is any expression . Test if U is an idf. whose only value is its
% printname or another atom$
 fixp u or idp u$

symbolic procedure alkernp u$
% U is any expression . Test if U is a kernel.$
not stringp u  and kernp(simp!* u)$

symbolic procedure precp(u,v)$
% Tests if the operator U has precedence over the operator V.
begin integer nn$scalar uu,vv,aa$
    uu:=u$ vv:=v$aa:=preclis!*$
    if or(not(uu member aa),not(vv member aa)) then return nil$
    nn:=lpos(u,aa)$;
    nn:=nn-lpos(v,aa)$
    if nn geq 0 then return t else return nil end$

flag('(nordp alatomp alkernp precp depvarp stringp ),'boolean)$

% THE SUBSEQUENT DECLARATION IS USEFUL FOR "TEACHING PURPOSES".

flag('(alatomp precp depvarp alkernp depatom ) ,'opfn);

% 2. MISCELLANEOUS functions.

symbolic procedure korderlist;
% gives a list of the user defined internal order of the
% indeterminates. Just state KORDERLIST; to get it.
kord!*;

 flag('(korderlist), 'opfn);
 put('korderlist,'stat,'endstat);

symbolic procedure remsym u;
% ALLOWS TO ELIMINATE THE DECLARED SYMMETRIES.
for each j in u do
  if flagp(j,'symmetric) then remflag(list j,'symmetric) else
  if flagp(j,'antisymmetric) then remflag(list j,'antisymmetric);

        put('remsym,'stat,'rlis);

% 3. Control of SWITCHES.

symbolic procedure switches;
%This procedure allows to  see the values of the main switches$
<<terpri();
prin2 "      **** exp:=";prin2 !*exp;prin2 " ............. ";
prin2 "allfac:= ";prin2 !*allfac;prin2 " ****";terpri(); terpri();
prin2 "      **** ezgcd:=";prin2 !*ezgcd;prin2 " ......... ";
prin2 "gcd:= ";prin2 !*gcd;prin2 " ****";terpri();terpri();
prin2 "      **** mcd:=";prin2 !*mcd;prin2 " ............. ";
prin2 "lcm:= ";prin2 !*lcm;prin2 " ****";terpri();terpri();
prin2 "      **** div:=";prin2 !*div;prin2 " ........... ";
prin2 "rat:= ";prin2 !*rat;prin2 " ****";terpri();terpri();
prin2 "      **** intstr:=";prin2 !*intstr;prin2 " ........ ";
prin2 "rational:= ";prin2 !*rational;prin2 " ****";terpri();terpri();
prin2 "      **** precise:=";prin2 !*precise;prin2 " ....... ";
prin2 "reduced:= ";prin2 !*reduced;prin2 " ****";terpri();terpri();
prin2 "      **** complex:=";prin2 !*complex;prin2 " ....... ";
prin2 "rationalize:= ";prin2 !*rationalize;
                                prin2 " ****";terpri();terpri();
prin2 "      **** factor:= "; prin2 !*factor;prin2 " ....... ";
prin2 "distribute:= ";prin2 !*distribute;prin2 " ***";>>$

         flag('(switches),'opfn)$

symbolic procedure switchorg$
%It puts all switches relevant to current algebra calculations to
% their initial values.
<< !*exp:=t;
   !*allfac:=t;
   !*gcd:=nil;
   !*mcd:=t;
   !*div:=nil;
   !*rat:=nil;
   !*distribute:=nil;
   !*intstr:=nil;
   !*rational:=nil;
   !*ezgcd:=nil;
   !*ratarg:=nil;
   !*precise:=nil;
   !*complex:=nil;
   !*heugcd:=nil;
   !*lcm:=t;
   !*factor:=nil;
   !*ifactor:=nil;
   !*rationalize:=nil;
   !*reduced:=nil;
   !*savestructr:=nil;
                       >>;

flag('(switchorg switchoff),'opfn)$

deflist('((switches endstat) (switchorg endstat) (switchoff endstat)),
           'stat)$

% 4. Control of USER DEFINED objects.
% This  aims to extract from the history of the run
% the significant data defined by the user. It DOES NOT give insights on
% operations done in the SYMBOLIC mode.

symbolic procedure remvar!:(u,v)$
% This procedure traces and clear both assigned or saved scalars and
% lists.
 begin scalar buf,comm,lv;
     buf:=inputbuflis!*;
     for each x in buf do if not atom (comm:=caddr x)
                                 and car comm = 'setk then
  begin scalar obj;
  l1: if null cddr comm then return lv;
         obj:=cadadr comm;
      if  gettype obj  eq v then
         lv:=cons(obj,lv);
         comm:=caddr comm;
         go to l1  end;
 lv:= !:mkset lv;
 if null u then
    <<for each x in lv do clear x; return t>> else return lv
     end;

flag('(displaylst displayscal),'noform);

symbolic  procedure displayscal;
% Allows to see all scalar variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
 union(remvar!:(t,'scalar),remsvar!:(t,'scalar));

symbolic  procedure displaylst$
% Allows to see all list variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
  union(remvar!:(t,'list),remsvar!:(t,'list)) ;

symbolic procedure clearscal$
% Allows to clear all scalar variables introduced
% DIRECTLY ON THE CONSOLE;
<<remvar!:(nil,'scalar);remsvar!:(nil,'scalar)>>$

symbolic procedure clearlst$
% Allows to clear all list variables introduced
% DIRECTLY ON THE CONSOLE;
<<remvar!:(nil,'list);remsvar!:(nil,'list)>>;

symbolic procedure remsvar!:(u,v)$
 begin scalar buf,comm,lsv,obj;
     buf:= inputbuflis!*;
     for each x in buf do
      if not atom (comm:=caddr x) and car comm eq 'saveas then
         if  v eq t then
             if gettype (obj:=cadr cadadr comm)
                  member list('scalar,'list,'matrix,'hvector,'tvector)
                  then lsv:=cons(obj,lsv)
             else nil
         else if v eq gettype (obj:=cadr cadadr comm)
                  then lsv:=cons(obj,lsv);
     lsv:= !:mkset lsv$
    if null u then
    <<for each x in lsv do clear x$ return t>> else return lsv
     end;

flag('(displaysvar),'noform);

symbolic  procedure displaysvar;
% Allows to see all variables created by SAVEAS.
remsvar!:(t,t) ;

symbolic  procedure clearsvar;
% Allows to clear  all variables created.
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file.
remsvar!:(nil,t);

symbolic procedure rema!:(u);
% This function works to trace or to clear arrays.
 begin scalar buf,comm,la$
     buf:=inputbuflis!*$
     for each x in buf do if not atom (comm:=caddr x) and
                car comm eq 'arrayfn then
     begin scalar arl,obj;
         arl:=cdaddr comm;
     l1: if null arl then return la else
           if gettype (obj:=cadadr car arl ) eq 'array then
             la:=cons(obj,la);
         arl:=cdr arl$
         go to l1  end$
  la:= !:mkset la$
  if null u then
   <<for each x in la do clear x$ return t>> else return la
 end;

flag('(displayar),'noform);

symbolic  procedure displayar;
% Allows to see all array variables created.
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file.
 rema!:(t)$

symbolic procedure clearar;
% Allows to clear array variables introduced
% DIRECTLY ON THE CONSOLE;
rema!:(nil)$

% This file shoul be loaded together with remscal.red

symbolic procedure remm!:(u)$
% This function works to trace or to clear matrices. Be CAREFUL to use
% the declaration MATRIX on input (not m:=mat(...) directly).
% declaration MATRIX ..
%x ==> (97 SYMBOLIC (MATRIX (LIST (LIST (QUOTE MM) 1 1))))
% Declaration MM:=MAT((...))
% x==>(104 ALGEBRAIC
%       (SETK (QUOTE M2) (AEVAL (LIST (QUOTE MAT) (LIST 1) (LIST 1)))))
 begin scalar buf,comm,lm;
     buf:= inputbuflis!*;
  for each x in buf do if  not atom (comm:=caddr x) and
                           car comm eq 'matrix then
      begin scalar lob,obj;
      lob:=cdadr comm;
   l1: if null lob then return lm else
       if gettype(obj:=if length car lob = 2 then cadr car lob else
                    cadadr car lob) then
          lm:=cons(obj,lm);
      lob:=cdr lob;
      go to l1  end$
lm :=union(lm,remvar!:(t,'matrix));
lm:=!:mkset lm;
if null u then
 <<for each x in lm do clear x$ return t>> else return lm
 end;

flag('(displaymat),'noform);

symbolic procedure displaymat$
% Allows to see all variables of matrix type
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union( remm!:(t),remsvar!:(t,'matrix));

symbolic procedure clearmat$
% Allows to clear all user variables introduced
% DIRECTLY ON THE CONSOLE;
<<remm!:(nil);remsvar!:(nil,'matrix)>>;


symbolic procedure remv!:(u)$
% This function works to trace or to clear vectors.
 begin scalar buf,av$
     buf:= inputbuflis!*$
  for each x in buf do if not atom (x:=caddr x) and
              car x member list('vector,'tvector,'index)
         then
     begin scalar uu,xx$
         uu:=cdadr x$
     l1: if null uu then return av else
           if gettype(xx:=cadar uu) or get(xx,'fdegree) then
             av:=cons(xx,av);
         uu:=cdr uu$
         go to l1  end$
  av:= !:mkset av$
  if null u then
   <<for each x in av do clear x$ return t>> else return av
 end$

flag('(displayvec),'noform);

symbolic  procedure displayvec$
% Allows to see all variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union(remv!:(t),union(remsvar!:(t,'hvector),remsvar!:(t,'tvector)) );

symbolic procedure clearvec$
% Allows to clear all user variables introduced
% DIRECTLY ON THE CONSOLE;
<<remv!:(nil);remsvar!:(nil,'hvector);remsvar!:(nil,'tvector)>>;

symbolic procedure remf!:(u)$
% This function works to trace or to clear arrays.
 begin scalar buf,av$
     buf:= inputbuflis!*$
     for each x in buf do if not atom (x:=caddr x) and
                              car x eq 'pform then
     begin scalar uu,xx$
         uu:=cdadr x$
     l1: if null uu then return av else
           if get(xx:=cadadr cdar uu ,'fdegree) or
             (not atom xx and get(xx:=cadr xx,'ifdegree))
    then
             av:=cons(xx,av);
         uu:=cdr uu$
         go to l1  end$
  av:= !:mkset av$
  if null u then
   <<for each x in av do clear x$ return t>> else return av
 end$

flag('(displayform),'noform);

symbolic  procedure displayform$
% Allows to see all variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union(remf!:(t),remvar!:(t,'pform));

symbolic procedure clearform$
% Allows to clear all user variables introduced
% DIRECTLY ON THE CONSOLE;
<<remf!:(nil);remvar!:(nil,'pform)>>;

symbolic procedure clear!_all;
<<remvar!: (nil,'scalar); remvar!:(nil,'list); remvar!:(nil,'pform);
  remsvar!:(nil,t);rema!: nil;remv!: nil;remm!: nil; remf!: nil ;t>>;


symbolic procedure show u;
begin u:=car u;
           if u eq 'scalars then
              return write "scalars are: ", displayscal()
           else
           if u eq 'lists  then
              return write "lists are: ", displaylst()
           else
           if u eq 'arrays then
               return write "arrays are: ", displayar()
           else
           if u eq 'matrices then
                       return write "matrices are: ",displaymat()
           else
           if u member list('vectors,'tvectors,'indices)  then
                       return  write "vectors are: ", displayvec()
           else
           if u eq 'forms then
                        return write "forms are: ", displayform()
           else
           if u eq 'all then for each i in
            list('scalars,'arrays,'lists,'matrices,'vectors,'forms) do
                        <<show list i;lisp terpri()>>;
end;

put('show,'stat,'rlis);

symbolic procedure suppress u;
begin u:=car u;
            if u member list('vectors,'tvectors,'indices) then
                       return clearvec() else
            if u eq 'variables then return clearvar() else
            if u eq 'scalars then return clearscal() else
            if u eq 'lists then return clearlst() else
            if u eq 'saveids  then return clearsvar() else
            if u eq 'matrices then return clearmat() else
            if u eq 'arrays then return clearar() else
            if u eq 'forms then return clearform() else
            if u eq 'all then return clear!_all() end;

put('suppress,'stat,'rlis);


% 5. Means to CLEAR operators and functions.

symbolic procedure clearop u;
<<clear u; remopr u; remprop(u , 'kvalue);remprop(u,'klist)$
  for each x in !:flaglis do
            if u eq car x then putflag(u,cadr x,0) else nil;
  for each x in !:proplis do
            if u eq car x then putprop(u,cadr x,caddr x,0)
                              else nil;
     remflag(list u,'used!*); t>>;

symbolic flag('(clearop),'opfn);

symbolic procedure clearfunctions u$
% U is any number of idfs. This function erases properties of  non
% protected functions described by the idfs.
% It is very convenient but is dangerous if applied to the
% basic functions of the system since most of them  are NOT protected.
% It clears all properties introduced by PUTFLAG, PUTPROP and DEPEND.
begin scalar uu,vv$
l1: uu:=car u$
    vv:=cdr rdisplayflag (list  uu )$
    if flagp(uu,'lose) then go to l2 else
    << terpri();spaces(5)$
       write "*** ",uu," is unprotected : Cleared ***"$
       followline(0)>>$
  for each x in !:proplis do
            if u eq car x then putprop(u,cadr x,caddr x,0)
                              else nil;
    if get(uu,'simpfn) then <<clearop uu; remprop(uu,'!:ft!:);
       remprop(uu,'!:gf!:)>> else
    if get(uu,'psopfn) then remprop(uu,'psopfn) else
    if get(uu,'expr) then remprop(uu,'expr) else
    if get(uu,'subr) then remd uu$
    remprop(uu,'stat);
    remprop(uu,'dfn);
    remflag(list uu,'opfn)$
    remflag(list uu,'full)$
    remflag(list uu,'odd)$
    remflag(list uu,'even)$
    remflag(list uu,'boolean)$
    remflag(list uu,'used!*)$
    for each x in vv do putflag( uu,x,0)$
    depl!*:=delete(assoc(uu,depl!*),depl!*);
    remflag(list uu,'impfun)$ % to be effective in EXCALC;
    u:= cdr u$ go to l3$
l2: << spaces(5)$
       write "*** ",uu," is a protected function: NOT cleared ***"$
       terpri(); u:=cdr u>>$
l3: if null u then <<terpri();
              return "Clearing is complete">> else

    go to l1 end$

symbolic rlistat '(clearfunctions);


endmodule;

module polyextensions;

%=====================================================================

% ADDITIONAL FUNCTIONS FOR POLYNOME AND RATIONAL EXPRESSION
% MANIPULATIONS.

%=====================================================================

fluid '(!*distribute);

switch distribute;

symbolic procedure addfd (u,v);
% It contains a modification to ADDF to avoid
% a recursive representation.
% U and V are standard forms. Value is a standard form.
if null u then v
else if null v then u
else if  domainp u then addd(u,v)
else if  domainp v then addd(v,u)
%else if peq(lpow u,lpow v) or ordpp(lpow u,lpow v)
else if ordpp(lpow u,lpow v)
then lt u .+ addfd(red u,v)
else lt v .+ addfd (u,red v);


symbolic procedure distribute u;
% Gives a polynome in distributed form in the algebraic mode.
list('!*sq,distri!_pol numr simp!* u  ./ 1,t);

symbolic flag('(distribute),'opfn);

symbolic procedure distri!_pol u;
% This function assumes that u is a polynomial given
% as a standard form. It transforms its recursive representation into
% a distributive representation.
if null u then nil else
if atom u then u else
if red u  then
   addfd(distri!_pol !*t2f lt u,distri!_pol red u)
     else
 begin scalar x,y;
 x:=1 ;
 y:=u;
 while  not atom y and null red y do
                        <<x:=multf(!*p2f lpow y,x); y:=lc y>>;
 if atom y then return multf(x,y) else
 return
 addfd(distri!_pol multf(x,distri!_pol !*t2f lt y),
       distri!_pol multf(x,distri!_pol red y))

end;

symbolic procedure leadterm u;
<<u:=simp!* u; if !*distribute  then u:=distri!_pol numr u ./ denr u
  else u; if domainp u then mk!*sq u
  else  mk!*sq(!*t2f lt numr u ./ denr u)>>;

symbolic flag('(leadterm redexpr ),'opfn);

symbolic procedure redexpr u;
<<u:=simp!* u; if !*distribute  then u:=distri!_pol numr u ./ denr u
  else u; if domainp u then mk!*sq(nil ./ 1) else
  mk!*sq( red numr u ./ denr u)>>;

symbolic procedure list!_of!_monom u;
% It takes a polynomial in distributive form.
% returns a list of monoms.
% u is numr simp!* (algebraic expression)
if domainp u then u else
begin scalar exp,lmon,mon;
     exp:=u;
l:  if null exp then return lmon ;
      mon:=lt exp;
    lmon:=(!*t2f mon ) . lmon;
     exp:=red exp;
     go to l;
end;

symbolic procedure monomterm y;
begin scalar x;
x:=numr simp!* y;
x:=distri!_pol x;
x:=list!_of!_monom x;
x:=for each m in x collect mk!*sq(m ./ 1);
return 'list . x end;

algebraic procedure monom(u);
% Use: monom <polynome>
begin scalar x,xx;
xx:= lisp monomterm u ;
return xx
end;

symbolic procedure !&dpol u$
% RETURNS A LIST WHICH CONTAINS THE QUOTIENT POLYNOMIAL and THE
% REMAINDER.
if length u neq 2 then rederr "divpol must have two arguments"
else
begin scalar poln,pold,aa,ratsav$
if lisp (!*factor) then off factor; % This restriction is
                                  % necessary for some implementatins .
    poln:= simp!* car u$
    pold:= simp!* cadr u$
    if denr poln neq 1 or denr pold neq 1 then
    rederr(" arguments must be polynomials")$
    poln:=numr poln$ pold:=numr pold$
    if lc poln neq 1 or lc poln neq lc pold then
                       <<ratsav:=lisp (!*rational); on rational>>;
    aa:=qremf(poln,pold)$
  aa:=mksq(list('list ,prepsq!*( car aa . 1), prepsq!*(cdr aa . 1)),1)$
    if not ratsav then off rational;
    return  aa end$

put('divpol,'simpfn,'!&dpol)$

symbolic procedure lowestdeg(u,v)$
% IT EXTRACTS THE LOWEST DEGREE IN V OF THE POLYNOMIAL U.
begin scalar x,y,uu,vv,mvy$
    uu:=simp!* u$
    if domainp uu then return 0$
    uu:=!*q2f uu;
    vv:=!*a2k v$
    x:=setkorder list v$
    y:=reorder uu$ setkorder x$
    y:=reverse y$y$
    if fixp y then return 0$
    mvy:=mvar y$
    if not atom mvy then if car mvy eq 'expt then
         rederr("exponents must be integers")$
    if mvy neq vv then return 0 else
         return  ldeg y end$

flag('(lowestdeg),'opfn)$

endmodule;


module transfunctions;

algebraic;

algebraic procedure trigexpand wws;
  wws where { sin(~x+~y) => sin(x)*cos(y)+cos(x)*sin(y),
              cos(~x+~y) => cos(x)*cos(y)-sin(x)*sin(y),
              sin((~n)*~x) => sin(x)*cos((n-1)*x)+cos(x)*sin((n-1)*x)
                   when fixp n and n>1,
              cos((~n)*~x) => cos(x)*cos((n-1)*x)-sin(x)*sin((n-1)*x)
                   when fixp n and n>1 };

algebraic procedure hypexpand wws;
  wws where {sinh(~x+~y) => sinh(x)*cosh(y)+cosh(x)*sinh(y),
             cosh(~x+~y) => cosh(x)*cosh(y)+sinh(x)*sinh(y),
             sinh((~n)*~x) => sinh(x)*cosh((n-1)*x)+cosh(x)*sinh((n-1)*x)
                   when fixp n and n>1,
             cosh((~n)*~x) => cosh(x)*cosh((n-1)*x)+sinh(x)*sinh((n-1)*x)
                   when fixp n and n>1 };

operator !#ei!&; !#ei!&(0):=1;

trig!#ei!& := {!#ei!&(~x)**(~n) => !#ei!&(n*x),
               !#ei!&(~x)*!#ei!&(~y) => !#ei!&(x+y)};

let trig!#ei!&;

algebraic procedure trigreduce wws;
        <<wws:=(wws WHERE {cos(~x) => (!#ei!&(x)+!#ei!&(-x))/2,
                           sin(~x) => -i*(!#ei!&(x)-!#ei!&(-x))/2});
          wws:=(wws WHERE {!#ei!&(~x) => cos x +i*sin x})>>;

algebraic procedure hypreduce wws;
        <<wws:=(wws where {cosh(~x) => (!#ei!&(x)+!#ei!&(-x))/2,
                           sinh(~x) => (!#ei!&(x)-!#ei!&(-x))/2});
          wws:=(wws where {!#ei!&(~x) => cosh(x)+sinh(x)})>>;

algebraic procedure pluslog wws;
   wws:=(wws where {log(~x*(~n)) => log(x)+log(n),
                    log(~x/(~n)) => log(x)-log(n),
                    log(~x**(~n)) => n*log(x),
                    log sqrt(~x) => 1/2*log(x),
                    log cbrt(~x) => 1/3*log(x) });


% realizes the concatenation of "sum over i c(i)*log x(i)".

operator e!_log!_conc;

algebraic procedure concsumlog exp;
% This procedure works properly only in ON EXP only though it may lead
% to some simplification  also in OFF EXP.
if den exp neq 1 then concsumlog num exp / concsumlog den exp  else
 <<exp:=(e!_log!_conc(exp) where
                 { e!_log!_conc(~x+~y)=e!_log!_conc(x)*e!_log!_conc(y),
                   e!_log!_conc(log(~x)) => x,
                   e!_log!_conc(-log(~x)) => 1/x,
                   e!_log!_conc(~a*log (~x)) => x**a,
                   e!_log!_conc((- ~a)*log(~x)) => 1/x**a });
   exp:=(log exp where
                 { log(e!_log!_conc(~y)) => y,
                   log(~x*e!_log!_conc(~y)) => log(x)+y,
                   log(~x*e!_log!_conc(-~y)) => log(x)-y,
                   log(~x*e!_log!_conc(-~y)/(~z)) => log(x/z)-y,
                   log(~x*e!_log!_conc(~y)/(~z)) => log(x/z)+y })>>;

symbolic;

endmodule;

module vectoroper;

% This small module makes basic operation between EXPLICIT vectors
% available. They are assumed to be represented by BAGS or LISTS.
% Mixed product  is restricted to 3-space vectors.
% Generalization is still NEEDED.                 ;

symbolic procedure depthl1!: u;
 if null u then t else (caar u neq 'list) and depthl1!: cdr u;

symbolic procedure depthl1 u;
not null getrtype u and  depthl1!: cdr u;

symbolic procedure !:vect(u,v,bool);
   %returns a list whose elements are the sum of each  list elements.
   % null v check not necessary;
   if null u then nil
else  addsq(car u,if null bool then car v else negsq car v)
                                          . !:vect(cdr u,cdr v,bool);
symbolic procedure rsumvect(u);
begin scalar x,y,prf;
argnochk('sumvect . u);
x:=reval car u;y:=reval cadr u; prf:=car x;
 if (rdepth list x = 0) or (rdepth list y = 0) then
    rederr " both arguments must be of depth 1 " else
x:=cdr x; y:=cdr y;
if length x neq length y then rederr "vector mismatch";
x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return prf . (for each j in !:vect(x,y,nil) collect mk!*sq j) end;

         put('sumvect,'psopfn,'rsumvect);

symbolic procedure rminvect(u);
begin scalar x,y,prf;
argnochk('minvect . u);
x:=reval car u;y:=reval cadr u; prf:=car x;
 if (rdepth list x = 0) or (rdepth list y = 0) then
    rederr " both arguments must be of depth 1 " else
x:=cdr x; y:=cdr y;
if length x neq length y then rederr "vector mismatch";


x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return prf . (for each j in !:vect(x,y,'minus) collect mk!*sq j) end;

         put('minvect,'psopfn,'rminvect);

symbolic procedure !:scalprd(u,v);
   %returns scalar product of two lists;
   if null u and null v then nil ./ 1
    else addsq(multsq(car u,car v),!:scalprd(cdr u,cdr v));

symbolic procedure sscalvect(u);
begin scalar x,y;
argnochk('scalvect . u);
x:=reval car u;y:=reval cadr u;
if (rdepth list x = 0) or (rdepth list y = 0) then
    rederr " both arguments must be of depth 1 " else
if length x neq length y then rederr "vector mismatch";
x:=cdr x; y:=cdr y;
x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return mk!*sq !:scalprd(x,y)
end;

symbolic put('scalvect,'psopfn,'sscalvect);

symbolic procedure !:pvect3 u;
begin scalar x,y; integer xl;
 if (rdepth list car u = 0) or (rdepth cdr u = 0) then
    rederr " both arguments must be of depth 1 " else
x:=reval car u;y:=reval cadr u;
if (xl:=length x) neq 4 then rederr "not 3-space vectors" else
if xl neq length y then rederr "vector mismatch" ;
x:=cdr x; y:=cdr y;
x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return
 list( addsq(multsq(cadr x,caddr y),negsq multsq(caddr x,cadr y)),
        addsq(multsq(caddr x,car y),negsq multsq(car x,caddr y)),
         addsq(multsq(car x,cadr y),negsq multsq(cadr x,car y)))
  end;

symbolic procedure rcrossvect u;
<<% implemented only with LIST prefix;
 argnochk('crossvect . u);
'list . (for each j in !:pvect3 u collect mk!*sq j)>>;

symbolic put ('crossvect,'psopfn,'rcrossvect);

symbolic procedure smpvect u;
begin scalar x;
if  (rdepth list car u =0) then
    rederr " arguments must be of depth 1 "  else
x:=reval car u; u:=cdr u;
x:=cdr x;
if length x neq 3 then rederr " not 3-space vector";


x:=for each j in x collect simp!* j;


return mk!*sq !:scalprd(x,!:pvect3 u) end;

symbolic put('mpvect,'psopfn,'smpvect);

endmodule;





module matrext;

% This module defines additional utility functions for manipulating
% matrices.  Coercions to BAG and LIST structures are defined.

symbolic procedure natnumlis u;
   % True if U is a list of natural numbers.
   % Taken from MATR.RED for bootstrap purpose.
   null u


      or numberp car u and fixp car u and car u>0 and natnumlis cdr u;



symbolic procedure mkid!:(x,y);
  % creates the ID XY from identifier X and (evaluated) atom Y.
  if not idp x or null getrtype x then typerr(x,"MKID root")
   else if atom y and (idp y or fixp y and not minusp y)
    then intern compress nconc(explode x,explode y)
   else typerr(y,"MKID index");

symbolic procedure mkidm(u,j);
% This function allows us to RELATE TWO MATRICES by concatanation of
% characters. u AND uj should BOTH be matrices.
  matsm cadr get(mkid!:(u,j),'avalue) ;

symbolic  put('mkidm,'rtypefn,'getrtypecar);




symbolic  flag('(mkidm),'matflg);


symbolic  procedure baglmat (u,op);
% this procedure maps U into the matrix whose name is OP;
% it cannot REDEFINE the matrix OP.
% This is to avoid accidental redefinition of a previous matrix;
if getrtype op  then rederr list(op,"should be an identifier")
else
begin scalar x,y;
if atom op then if not (y:=gettype op) then put(op,'rtype,'matrix) else
typerr(list(y,op),"matrix");
if rdepth list u neq 2 then rederr("depth of list or bag must be 2");
     x:=cdr u;
    x:= for each j in x collect for each k in cdr j collect k;
    put(op,'avalue,list('matrix,'mat . x));
return t end;

symbolic flag('(baglmat),'opfn);

symbolic procedure rcoercemat u;
% Transforms a matrix into a bag or list. Argument is a list (mat,idp).
% idp is the name to  be given to the line or column vectors.
% The idp-envelope of the bag is the same as the one of the one of the
% subbags$
begin scalar x,prf;
 x:=reval car u;
if getrtype x neq 'matrix then rederr list(x,"should be a matrix");
 prf:= cadr u;
if car x neq 'mat then typerr(x,"matrix") else
 if prf neq 'list then  <<prf:=reval prf; simpbagprop list(prf,t)>>;
 x:=cdr x;
 x:= for each j in x collect (prf .  j);
return prf . x end;

symbolic put('coercemat,'psopfn,'rcoercemat);
symbolic put('rcoercemat,'number!_of!_args,2);

symbolic procedure n!-1zero(n,k)$
if n=0 then nil else
if k=1 then 1 . nzero(n-1) else
if k=n then  append(nzero(n-1) , (1 . nil))  else
append(nzero(k-1), (1 . nzero(n-k)))$

symbolic procedure unitmat u$
% It creates unit matrices. The argument is of the form A(2),B(5)....$
begin scalar l,sy,x,aa$
for each s in u do
<< if idp s or length (l:= revlis cdr s) neq 1 or not natnumlis l
      then errpri2(s,'hold) else
<<aa:=nil;sy:=car s; x:=gettype sy; if not null x then if x eq 'matrix
                                    then lprim list(x,sy,"redefined")
                                    else typerr(list(x,sy),"matrix");
         l:=car l; for n:=1:l do aa:=n!-1zero(l,l-n+1) . aa$
        put(sy,'rtype,'matrix);
        put(sy,'avalue,list('matrix,'mat . aa))>>>>;
 end$

symbolic put('unitmat,'stat,'rlis);

symbolic procedure  submat (u,nl,nc);
% Allows to extract from the matrix M the matrix obtained when
% the row NL and the column NC have been dropped.
% When NL and NC are out of range gives a copy of M;
if getrtype u neq 'matrix then rederr list(u,"should be a matrix")
else
begin scalar x;
x:=  matsm  u;
    if and(nl=0,nc=0) then return  x else
    if nl neq 0 then x:=remove(x,nl)$
    if nc neq 0 then
         x:=for each j in x collect remove(j,nc);
    return x end;

symbolic put('submat,'rtypefn,'getrtypecar);
symbolic flag('(submat),'matflg);

symbolic procedure matsubr(m,bgl,nr)$
if getrtype m neq 'matrix then rederr list(m,"should be a matrix")
else
begin scalar x,y,res; integer xl;
% It allows to replace row NR of the matrix M by the bag or list BGL;
y:=reval bgl;
 if not baglistp y  then typerr(y,"bag or list") else
 if nr leq 0 then rederr " THIRD ARG. MUST BE POSITIVE"
 else
    x:=matsm m$ xl:=length x$
   if length( y:=cdr y) neq xl then  rederr " MATRIX MISMATCH"$
    y:= for each j in y collect simp j;
   if nr-xl >0 then rederr " row number is out of range";
    while (nr:=nr-1) >0
              do <<res:=car x . res$ x:=cdr x >>;
           rplaca(x,y) ;
           res:=append(  reverse res, x) ;
    return  res   end;

symbolic put('matsubr,'rtypefn,'getrtypecar);
symbolic flag('(matsubr),'matflg);

symbolic procedure matsubc(m,bgl,nc)$
if getrtype m neq 'matrix then rederr list(m,"should be a matrix")
else
begin scalar x,y,res; integer xl;
%It allows to replace column NC of the matrix M by the bag or list BGL
y:=reval bgl;
 if not baglistp y  then typerr(y,"bag or list") else
 if nc leq 0 then rederr " THIRD ARG. MUST BE POSITIVE"
 else
    x:=tp1 matsm m$ xl:=length x$
   if length( y:=cdr y) neq xl then  rederr " MATRIX MISMATCH"$
    y:= for each j in y collect simp j;
   if nc-xl >0 then rederr " column  number is out of range";
    while (nc:=nc-1) >0
              do <<res:=car x . res$ x:=cdr x >>;
           rplaca(x,y) ;
           res:=tp1 append(  reverse res, x) ;
    return  res   end;

symbolic put('matsubc,'rtypefn,'getrtypecar);
symbolic flag('(matsubc),'matflg);

symbolic procedure rmatextr u$
% This function allows to extract the row N from the matrix A and
% to place it inside a bag whose name is LN$
begin scalar x,y; integer n,nl;
x:= matsm car u; y:= reval cadr u; n:=reval caddr u;
if  not fixp n then
rederr "Arguments are: matrix, vector name, line number" else
if not baglistp list y  then  simpbagprop list(y, t)$
nl:=length x;
if n<= 0  or n>nl then return nil$
while n>1 do <<x:=cdr x$ n:=n-1>>$
if null x then return nil$
return x:=y . ( for each j in car x  collect prepsq j) end$

symbolic procedure rmatextc u$
% This function allows to extract the row N from the matrix A and
% to place it inside a bag whose name is LN$
begin scalar x,y; integer n,nc;
x:= tp1 matsm car u; y:= reval cadr u; n:=reval caddr u;
if  not fixp n then
rederr "Arguments are: matrix, vector name, line number" else
if not baglistp list y  then  simpbagprop list(y, t)$
nc:=length x;
if n<= 0  or n>nc then return nil$
while n>1 do <<x:=cdr x$ n:=n-1>>$
if null x then return nil$
return x:=y . ( for each j in car x  collect prepsq j) end$

symbolic put('matextr,'psopfn,'rmatextr);
symbolic put('matextc,'psopfn,'rmatextc);

symbolic procedure  hconcmat(u,v)$
% Gives the horizontal concatenation of matrices U and V$
  hconcmat!:(matsm u,matsm v );

symbolic procedure hconcmat!:(u,v)$
if null u then v else if null v then u else
append(car u,car v) . hconcmat!:(cdr u,cdr v)$

symbolic put('hconcmat,'rtypefn,'getrtypecar);
symbolic flag('(hconcmat),'matflg);

symbolic procedure vconcmat (u,v)$
% Gives the vertical concatenation of matrices U and V$
 append(matsm u,matsm v);

symbolic put('vconcmat,'rtypefn,'getrtypecar);
symbolic flag('(vconcmat),'matflg);

symbolic procedure tprodl(u,v)$
begin scalar aa,ul$
l1: if null u then return aa$
    ul:=car u$
    ul:=multsm(ul,v)$
    aa:=hconcmat!:(aa,ul)$
    u:=cdr u$
    go to l1$
    end$

symbolic procedure tpmat(u,v)$
% Constructs the direct product of two matrices;
if null gettype u  then multsm(simp u,matsm v) else
if null gettype v then multsm(simp v,matsm u) else
begin scalar aa,uu,vv$
    uu:=matsm u$ vv:=matsm v$
    for each x in uu do aa:=append (aa,tprodl(x,vv))$
return aa end;

infix tpmat$

         put('tpmat,'rtypefn, 'getrtypecar);
         flag('(tpmat),'matflg)$

algebraic procedure hermat (m,hm);
% hm must be an identifier with NO value. Returns the
% Hermitiam Conjugate matrix.
begin scalar ml,ll; %ll:=length M;
m:=tp m;
ml:=coercemat(m,list);
ll:=list(length first ml,length ml);
ml:=for j:=1: first ll collect for k:=1:second ll collect
        sub(i=-i,(ml.j).k);
baglmat(ml,hm);
return hm end;

symbolic procedure seteltmat(m,elt,i,j);
% Sets the matrix element (i,j) to elt. Returns the modified matrix.
begin scalar res;res:=matsm m;
rplaca(pnth(nth(res,i),j),simp elt);
return res end;

put('seteltmat,'rtypefn,'getrtypecar);
flag('(seteltmat),'matflg);

symbolic procedure simpgetelt u;
% Gets the matrix element (i,j). Returns the element.
begin scalar mm;
mm:=matsm car u;
return nth(nth(mm,cadr u),caddr u) end;

put('geteltmat, 'simpfn,'simpgetelt);

endmodule;

end;

Added r34.1/lib/assist.tst version [df2ab03702].































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
% Tests of Assist Package version 1.1 .
% Valid only with REDUCE 3.4
% DATE : 15 September 1991.
% Author: H. Caprasse <u214001@bliulg11.bitnet>.
%                     <u214001@vm1.ulg.ac.be>
%---------------------------------------------------------------------
load assist;
showtime;
% 1. TESTS OF THE SWITCH CONTROL FUNCTIONS :
;
switches;
switchorg;
switches;
;
if !*mcd then "the switch mcd is on";
if !*gcd then "the switch gcd is on";
;
% A new switch :
!*distribute;
%
% 2. THE "LIST" MANIPULATION FACILITIES" :
;
% generation of a new list
;
 t1:=mklist(4);

 for i:=1:4 do t1:= (t1.i:=mkid(a,i));
;
%   notice that part(t1,i) has become t1.i. as also shown  here :
;
t1.1;
t1:=(t1.1).t1;

% MKLIST does NEVER destroy anything
;
mklist(t1,3);
mklist(t1,10);

% 3. THE DEFINITION OF A BAG
;
% The atom "BAG" is an available (and reserved) name for a BAG envelope
% it is an OPERATOR. In what follows we mostly use it but we insist that
% ANY identifier (there are a few exceptions) may be used.
;
aa:=bag(x,1,"A");
% It is easy to construct NEW bag-like objects
;
putbag bg1,bg2;

% now one can verify that
;
aa:=bg1(x,y**2);
% is a bag by BAGP
;
if bagp aa then "this is a bag";
;
% One can erase the bag property of bg2 by the command
;
clearbag bg2;
;
% baglistp works in the same way for either a LIST OR a BAG
;
if baglistp aa then "this is a bag or list";
if baglistp list(x) then "this is a bag or list";
;
% Use of the DISPLAYFLAG command that we shall illustrate below is
% another way.
% "LIST" MAY NOT be a bag.
on errcont;
% The command below gives an error message:
;
putbag list;
% LISTS may be transformed to BAGS and vice versa
off errcont;
;
kernlist(aa);
listbag(list x,bg1);
%
%
% 4. BASIC MANIPULATION FUNCTIONS WORKING FOR BOTH STRUCTURES :
;
% define:
;
ab:=bag(x1,x2,x3);
al:=list(y1,y2,y3);
% We illustrate how the elementary functions do work DIFFERENTLY
;
first ab;  third ab;  first al;
last ab; last al;
% The subsequent one do act in the SAME way;
rest ab; rest al;
belast ab; belast al;
;
% depth determines if the depth of the list is uniform.
% when it is, it gives its deepness as an integer.
;
depth al; depth bg1(ab);
% It is very convenient to define the PICKUP function PART(x,n) by . :
;
ab.1; al.3;
on errcont;
ab.4;
off errcont;
% For bags, it is possible to avoid an error message when one
% has an index out of range using "first", "second" and "third".
% For instance:
;
second second ab;
% This is coherent because the envelope of a bag always remains.
;
size ab; length al;
remove(ab,3);
delete(y2,al);
reverse al;
member(x3,ab); % notice the output.
;
al:=list(x**2,x**2,y1,y2,y3);
;
elmult(x**2,al);
position(y3,al);
;
repfirst(xx,al);
represt(xx,ab);
insert(x,al,3);
insert( b,ab,2);
insert(ab,ab,1);
substitute (new,y1,al);
;
% Function that acts on TWO lists or bags :
;
append(ab,al);
append(al,ab);
;
% Association list or bag may be constructed and thoroughly used
;
l:=list(a1,a2,a3,a4);
b:=bg1(x1,x2,x3);
% PAIR is the CONSTRUCTOR of the ASSOCIATION LIST or BAG.
al:=pair(list(1,2,3,4),l);
ab:=pair(bg1(1,2,3),b);
;
% A BOOLEAN function abaglistp to test if it is an association
;
if abaglistp bag(bag(1,2)) then "it is an associated bag";
;
% Values associated to the keys can be extracted
% first occurence ONLY.
;
asfirst(1,al);
asfirst(3,ab);
;
assecond(a1,al);
assecond(x3,ab);
;
aslast(z,list(list(x1,x2,x3),list(y1,y2,z)));
asrest(list(x2,x3),list(list(x1,x2,x3),list(y1,y2,z)));
;


% All occurences.
asflist(x,bg1(bg1(x,a1,a2),bg1(x,b1,b2)));
asslist(a1,list(list(x,a1,a2),list(x,a1,b2),list(x,y,z)));
restaslist(bag(a1,x),bg1(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z)));
restaslist(list(a1,x),bag(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z)));

%********
% Mapping functions can be used with bags through
;
on errcont;
;
for each j in list(list(a),list(c)) join j;
for each j in list(bg1(a),bg1(b)) collect first j;
off errcont;
;
% The FOR EACH .. IN .. statement requires a LIST-LIKE object.;
;
% There are functions available for manipulating bags or lists
% as sets. (they exist in the symbolic mode).
;
ts:=mkset list(a1,a1,a,2,2);
;
% Again a boolean function to test the SET property
;
if setp ts then "this is a SET";
;
union(ts,ts);
diffset(ts,list(a1,a));
diffset(list(a1,a),ts);
symdiff(ts,ts);
intersect(listbag(ts,set1),listbag(ts,set2));


% 5. MISCELLANEOUS GENERAL PURPOSE FUNCTIONS :
;
clear a1,a2,a3,a,x,y,z,x1,x2,op;
%
% DETECTION OF A GIVEN VARIABLE IN A GIVEN SET
;
detidnum aa;
detidnum a10;
detidnum a1b2z34;
% A list of a finite number of randomly chosen integers can be
% generated:
%
randomlist(3,10);
%
combnum(8,3);
permutations(bag(a1,a2,a3));
combinations({a1,a2,a3},2);
;
% The "depend" command can be  traced and made EXPLICIT :
;
depatom a;
depend a,x,y;
depatom a;
% The second use of DEPEND
;
depend op,x,y,z;
implicit op;
explicit op;
depend y,zz;
explicit op;
aa:=implicit op;
% The ENTIRE dependence of OP becomes "IMPLICIT"
;
df(aa,y);
% These two last functions work properly ONLY when the command "DEPEND"
%involves ATOMIC  quantities.
;
% Detection of variables a given function depends on is possible
;
funcvar(x+y);
funcvar(sin log(x+y));
;
% Variables on which an expression depends :
%
funcvar(sin pi);
funcvar(x+e+i);
%
% CONSTANT and RESERVED identifiers are recognize and not taken
% as variables.
%
% Now we illustrate functions that give, display or erase
%            a "FLAG" or a "PROPERTY" :
;
% It is possible to give "flags" in the algebraic mode;
%
putflag(list(a1,a2),fl1,t);
putflag(list(a1,a2),fl2,t);
displayflag a1;
% to clear ALL flags created for a1 :
;
clearflag a1,a2;
displayflag a2;
putprop(x1,propname,value,t);
displayprop(x1,prop);
displayprop(x1,propname);
% To clear ONE property
;
putprop(x1,propname,value,0);
displayprop(x1,propname);
%
%
% 6. FUNCTIONS TO CONTROL THE ENVIRONMENT :
;
% Algebraic ATOMS detection
;
alatomp z;
z:=s1;
alatomp z;
% Algebraic KERNEL detection
;
alkernp z;
alkernp log sin r;
% PRECEDENCE detection
;
precp(difference,plus);
precp(plus,difference);
precp(times,.);
precp(.,times);
% STRING detection
;
if stringp x then "this is a string";
if stringp "this is a string" then "this is a string";
;
;
% A function which detects the dependence of u with respect
%to the ATOM or KERNEL v at ANY LEVEL
;
depvarp(log(sin(x+cos(1/acos rr))),rr);
;
operator op;
symmetric op;
op(x,y)-op(y,x);
remsym op;
op(x,y)-op(y,x);
;
clear y,x,u,v;
korder y,x,u,v;
korderlist;
;
for all x,y such that nordp(x,y) let op(x,y)=x+y;
op(a,b);
op(b,a);
clear op;
% DISPLAY and CLEARING of user's objects of various types entered
% to the console. Only TOP LEVEL assignments are considered up to now.
% The following statements must be made INTERACTIVELY. We put them
% as COMMENTS for the user to experiment with them. We do this because
% in a fresh environment all outputs are nil.
;
% THIS PART OF THE TEST SHOULD BE REALIZED INTERACTIVELY.
% SEE THE ** ASSIST LOG **  FILE .
%clear a1,a2,aa,ar,br,mm,m1,m2,f,tv;
%a1:=a2:=1;
%show scalars;
%x**2;
%saveas res;
%show scalars;
%aa:=list(a);
%show lists;
%array ar(2),br(3,3);
%show arrays;
%load matr$
%matrix mm; matrix m1(2,2); m2:=mat((1,1));
%show matrices;
%vector v1,v2;
%show vectors;
%load excalc; pform f=1; tvector tv;
%show vectors;
%show forms;
%show all;
%suppress vectors;
%show vectors;
%suppress all
%show all;
clear op;
operator op;
op(x,y,z);
clearop op;
clearfunctions abs,tan;
;
% THIS FUNCTION MUST BE USED WITH CARE !!"!!!
;

% 7. NEW POLYNOMIAL MANIPUKLATION FACILITIES
%
%
clear x,y,z;
% To see the internal representation :
%
off pri;
;
pol:=(x+2*y+3*z**2)**3;
;
% Notice the recursive form.
;
pold:=distribute pol;
;
% Now it is in a distributive form.
;
% Terms and reductums may be extracted individually :
on distribute;
polp:=pol$
leadterm (pold);
pold:=redexpr pold;
leadterm pold;
;
off distribute;
polp:=pol$
leadterm polp;
polp:=redexpr polp;
leadterm polp;
;
% "leadterm" and "redexpr" extract the leading term and reductum of a
% polynomial respectively WITHOUT specifying the variable.
% The default ordering is then assumed.
% They work both for the distributive and recursive representations.
%
% The function "monom" puts in a list all monoms of a multivariate
% polynomial.
monom polp;
% "lowestdeg" extracts the smallest power of a given indeterminate
% in a polynomial:
lowestdeg(pol,z);
;
on pri;
;
divpol(pol,x+2*y+3*z**2);
% This function gives the quotient AND the remainder directly inside a
% list.
;
% 8. MANIPUKLATIONS OF SOME ELEMENTARY TRANSCENDENTAL FUNCTIONS

trig:=((sin x)**2+(cos x)**2)**4;
trigreduce trig;
trig:=sin (5x);
trigexpand trig;
trigreduce ws;
trigexpand sin(x+y+z);
;
% The same functions exist for hyperbolic functions:
;
hypreduce (sinh x **2 -cosh x **2);
;
% For expressions containing log's. Expansion in terms of sums,
% differences, .. is given by "logplus" while concatenation is given
% by the function "concsumlog".
;
clear a,b;
pluslog log(a*log(x**b));
concsumlog((2*log x + a*b*log(x*y)+1)/(3*x**2*log(y)));
% Though these functions do use substitution rules, these are
% active only during the time they actually do their work.


%  9. VECTOR CALCULUS OPERATIONS
;
clear u1,u2,v1,v2,v3,v4,w3,w4;
u1:=list(v1,v2,v3,v4);
u2:=bag(w1,w2,w3,w4);
%
sumvect(u1,u2);
minvect(u2,u1);
scalvect(u1,u2);
crossvect(rest u1,rest u2);
mpvect(rest u1,rest u2, minvect(rest u1,rest u2));
scalvect(crossvect(rest u1,rest u2),minvect(rest u1,rest u2));
;
% 10. NEW OPERATIONS ON MATRICES
;
clear m,mm,b,b1,bb,cc,a,b,c,d;
matrix mm(2,2);
baglmat(bag(bag(a1,a2)),m);
m;
on errcont;
;
baglmat(bag(bag(a1),bag(a2)),m);
off errcont;
%    **** i.e. it cannot redefine the matrix! in order
%         to avoid accidental redefinition of an already given matrix;

clear m; baglmat(bag(bag(a1),bag(a2)),m);
m;
on errcont;
baglmat(bag(bag(a1),bag(a2)),bag);
off errcont;
% Right since a bag-like object cannot become a matrix.
coercemat(m,op);
coercemat(m,list);
;
on nero;
unitmat b1(2);
matrix b(2,2);
b:=mat((r1,r2),(s1,s2));
b1;b;
mkidm(b,1);
% Allows to relate matrices already defined.
;
% Convenient to replace or get a matrix element inside a procedure :
%
seteltmat(b,newelt,2,2);
geteltmat(b,2,1);
%
b:=matsubr(b,bag(1,2),2);
% It gives automatically a new matrix with the second row substituted.
;
submat(b,1,2);
% What is left when row 1 and column 2 are taken off the matrix.
bb:=mat((1+i,-i),(-1+i,-i));
cc:=matsubc(bb,bag(1,2),2);
% Second column substituted.
cc:=tp matsubc(bb,bag(1,2),2);
matextr(bb, bag,1);
% First row extracted and placed in a bag.
matextc(bb,list,2);
% Second column  extracted and placed in a bag.
;
hconcmat(bb,cc);
vconcmat(bb,cc);
% Horizontal an vertical concatenations.
;
tpmat(bb,bb);
% Tensor product.
%
% It is an INFIX operation :
bb tpmat bb;
;
clear hbb;
hermat(bb,hbb);
% id hbb changed to a matrix id and assigned to the hermitian matrix
% of bb.
;
showtime;
end;

Added r34.1/lib/camal.bib version [9bff0225c6].



















































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
% Bibliography entry for camal.tex.

@ARTICLE{Bourne,
        AUTHOR = {Stephen R. Bourne},
        TITLE = {Literal expressions for the co-ordinates of the moon.
                {I}. The first degree terms},
        JOURNAL = {Celestial Mechanics},
        VOLUME = {6},
        PAGES = {167--186},
        YEAR = {1972},
        GENERATED = {Mon Oct 23 19:42:01 GMT 1989 on fino}
}

@MISC{Fateman,
        AUTHOR = {Richard J. Fateman},
        TITLE = {On the multiplication of Poisson series},
        YEAR = {1973},
        MONTH = {Draft},
        GENERATED = {Mon Oct 23 19:42:01 GMT 1989 on fino}
}


@Manual{CAMALF,
  title =       "{CAMAL} {User's} {Manual}",
  author =      "J. P. Fitch",
  organization =        "University of Cambridge Computer Laboratory",
  edition =     "2nd",
  year =        "1983"
}

@Article{Barton67a,
  author =      "D. Barton",
  title =       "",
  journal =     "Astronomical Journal",
  year =        "1967",
  volume =      "72",
  pages =       "1281--7"
}

@Article{Barton67b,
  author =      "D. Barton",
  title =       "A scheme for manipulative algebra on a computer",
  journal =     "Computer Journal",
  year =        "1967",
  volume =      "9",
  pages =       "340--4"
}


@Book{Delaunay,
  author =      "C. Delaunay",
  title =       "Th\'eorie du Mouvement de la Lune",
  publisher =   "Mallet-Bachelier",
  year =        "1860",
  series =      "(Extraits des M\'em. Acad. Sci.)",
  address =     "Paris"
}


@Article{Barton72,
  author =      "D. Barton and J. P. Fitch",
  title =       "The Application of Symbolic Algebra System to Physics",
  journal =     "Reports on Progress in Physics",
  year =        "1972",
  volume =      "35",
  pages =       "235--314"
}


@Article{LectureNotes,
  author =      "J. P. Fitch",
  title =       "Syllabus for Algebraic Manipulation Lectures in Cambridge",
  journal =     "SIGSAM Bulletin",
  year =        "1975",
  volume =      "32",
  pages =       "15"
}

@InProceedings{Barnes,
  author =      "A. Barnes and J. A. Padget",
  title =       "Univariate Power Series Expansions in {Reduce}",
  booktitle =   "Proceedings of ISSAC'90",
  year =        "1990",
  editor =      "S. Watanabe and M. Nagata",
  pages =       "82--7",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@Book{Brown,
  author =      "E. W. Brown",
  title =       "An Introductory Treatise on the Lunar Theory",
  publisher =   "Cambridge University Press",
  year =        "1896"
}

@Article{Jefferys,
  author =      "W. H. Jeffereys",
  title =       "",
  journal =     "Celestial Mechanics",
  year =        "1970",
  volume =      "2",
  pages =       "474--80"
}

Added r34.1/lib/camal.log version [d6333a5700].

































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
REDUCE 3.4.1, 15-Jul-92 ...

1: 
(CAMAL)


n := 4;


N := 4


on rational, rat;


off allfac;



array p(n/2+2);



harmonic u,v,w,x,y,z;



weight e=1, b=1, d=1, a=1;



%% Step1: Solve Kepler equation
bige := fourier 0;


BIGE := 0

for k:=1:n do <<
  wtlevel k;
  bige:=fourier e * hsub(fourier(sin u), u, u, bige, k);
>>;


write "Kepler Eqn solution:", bige$


                             1   4                3   3
Kepler Eqn solution: - [( - ---*E )SIN[4U] + ( - ---*E )SIN[3U] + (
                             3                    8

 1   4    1   2             1   3
---*E  - ---*E )SIN[2U] + (---*E  - E)SIN[U]]
 6        2                 8


%% Ensure we do not calculate things of too high an order
wtlevel n;



%% Step 2: Calculate r/a in terms of e and l
dd:=-e*e;


          2
DD :=  - E
 hh:=3/2;


       3
HH := ---
       2
 j:=1;


J := 1
 cc := 1;


CC := 1

for i:=1:n/2 do <<
  j:=i*j; hh:=hh-1; cc:=cc+hh*(dd^i)/j
>>;



bb:=hsub(fourier(1-e*cos u), u, u, bige, n);


            1   4                3   3             1   4    1   2
BB := [( - ---*E )COS[4U] + ( - ---*E )COS[3U] + (---*E  - ---*E )COS
            3                    8                 3        2

               3   3                1   2
      [2U] + (---*E  - E)COS[U] + (---*E  + 1)]
               8                    2

aa:=fourier 1+hdiff(bige,u);


         4   4             9   3                1   4    2
AA := [(---*E )COS[4U] + (---*E )COS[3U] + ( - ---*E  + E )COS[2U] + 
         3                 8                    3

           1   3
      ( - ---*E  + E)COS[U] + 1]
           8
 ff:=hint(aa*aa*fourier cc,u);


               103   4                13   3             11   4
FF :=  - [( - -----*E )SIN[4U] + ( - ----*E )SIN[3U] + (----*E
               96                     12                 24

          5   2             1   3                  1   4
       - ---*E )SIN[2U] + (---*E  - 2*E)SIN[U] + (---*E  - 1)]
          4                 4                      8



%% Step 3: a/r and f
uu := hsub(bb,u,v);


            1   4                3   3             1   4    1   2
UU := [( - ---*E )COS[4V] + ( - ---*E )COS[3V] + (---*E  - ---*E )COS
            3                    8                 3        2

               3   3                1   2
      [2V] + (---*E  - E)COS[V] + (---*E  + 1)]
               8                    2
 uu:=hsub(uu,e,b);


            1   4                3   3             1   4    1   2
UU := [( - ---*B )COS[4V] + ( - ---*B )COS[3V] + (---*B  - ---*B )COS
            3                    8                 3        2

               3   3                1   2
      [2V] + (---*B  - B)COS[V] + (---*B  + 1)]
               8                    2

vv := hsub(aa,u,v);


         4   4             9   3                1   4    2
VV := [(---*E )COS[4V] + (---*E )COS[3V] + ( - ---*E  + E )COS[2V] + 
         3                 8                    3

           1   3
      ( - ---*E  + E)COS[V] + 1]
           8
 vv:=hsub(vv,e,b);


         4   4             9   3                1   4    2
VV := [(---*B )COS[4V] + (---*B )COS[3V] + ( - ---*B  + B )COS[2V] + 
         3                 8                    3

           1   3
      ( - ---*B  + B)COS[V] + 1]
           8

ww := hsub(ff,u,v);


               103   4                13   3             11   4
WW :=  - [( - -----*E )SIN[4V] + ( - ----*E )SIN[3V] + (----*E
               96                     12                 24

          5   2             1   3                  1   4
       - ---*E )SIN[2V] + (---*E  - 2*E)SIN[V] + (---*E  - 1)]
          4                 4                      8
 ww:=hsub(ww,e,b);


               103   4                13   3             11   4
WW :=  - [( - -----*B )SIN[4V] + ( - ----*B )SIN[3V] + (----*B
               96                     12                 24

          5   2             1   3                  1   4
       - ---*B )SIN[2V] + (---*B  - 2*B)SIN[V] + (---*B  - 1)]
          4                 4                      8


%% Step 4: Substitute f and f' into S
yy:=ff-ww;


         103   4             13   3                11   4    5   2
YY := [(-----*E )SIN[4U] + (----*E )SIN[3U] + ( - ----*E  + ---*E )
         96                  12                    24        4

                     1   3                     103   4
      SIN[2U] + ( - ---*E  + 2*E)SIN[U] + ( - -----*B )SIN[4V] + (
                     4                         96

          13   3             11   4    5   2             1   3
       - ----*B )SIN[3V] + (----*B  - ---*B )SIN[2V] + (---*B  - 2*B)
          12                 24        4                 4

                 1   4    1   4
      SIN[V] + (---*B  - ---*E )]
                 8        8
 zz:=ff+ww;


               103   4                13   3             11   4
ZZ :=  - [( - -----*E )SIN[4U] + ( - ----*E )SIN[3U] + (----*E
               96                     12                 24

          5   2             1   3                     103   4
       - ---*E )SIN[2U] + (---*E  - 2*E)SIN[U] + ( - -----*B )SIN[4V]
          4                 4                         96

              13   3             11   4    5   2             1   3
       + ( - ----*B )SIN[3V] + (----*B  - ---*B )SIN[2V] + (---*B
              12                 24        4                 4

                        1   4    1   4
       - 2*B)SIN[V] + (---*B  + ---*E  - 2)]
                        8        8

xx:=hsub(fourier((1-d*d)*cos(u)),u,u-v+w-x-y+z,yy,n)+
    hsub(fourier(d*d*cos(v)),v,u+v+w+x+y-z,zz,n);


               625   4                       4     3
XX :=  - [( - -----*E )COS[5U-V+W-X-Y+Z] + (---*B*E )COS[4U+W-X-Y+Z]
               384                           3

              4   3                          4     3
       + ( - ---*E )COS[4U-V+W-X-Y+Z] + ( - ---*B*E )COS[4U-2V+W-X-Y+
              3                              3

             9   2  2                       17   2  2
      Z] + (---*D *E )COS[3U+V+W+X+Y-Z] + (----*D *E )SIN[3U+V+W+X+Y-
             8                              12

             9    2  2                        9    4
      Z] + (----*B *E )COS[3U+V+W-X-Y+Z] + (-----*E )COS[3U+V-W+X+Y-Z
             64                              128

            9     2                     9   2  2    9   2  2
      ] + (---*B*E )COS[3U+W-X-Y+Z] + (---*B *E  + ---*D *E
            8                           8           8

          27   4    9   2                          9     2
       + ----*E  - ---*E )COS[3U-V+W-X-Y+Z] + ( - ---*B*E )COS[3U-2V+
          16        8                              8

                      81   2  2                          2
      W-X-Y+Z] + ( - ----*B *E )COS[3U-3V+W-X-Y+Z] + (B*D *E)COS[2U+2
                      64

                         2                          1    3
      V+W+X+Y-Z] + (2*B*D *E)SIN[2U+2V+W+X+Y-Z] + (----*B *E)COS[2U+2
                                                    12

                     1      3                        2
      V+W-X-Y+Z] + (----*B*E )COS[2U+2V-W+X+Y-Z] + (D *E)COS[2U+V+W+X
                     12

                2   2                         1   2
      +Y-Z] + (---*D *E)SIN[2U+V+W+X+Y-Z] + (---*B *E)COS[2U+V+W-X-Y+
                3                             8

             1    3                            2
      Z] + (----*E )COS[2U+V-W+X+Y-Z] + ( - B*D *E)COS[2U+W+X+Y-Z] + 
             12

               2                            2      5     3
      ( - 2*B*D *E)SIN[2U+W+X+Y-Z] + ( - B*D *E - ---*B*E  + B*E)COS[
                                                   4

                         1      3                     2      2
      2U+W-X-Y+Z] + ( - ----*B*E )COS[2U-W+X+Y-Z] + (B *E + D *E
                         12

          5   3                           5   3        2      5     3
       + ---*E  - E)COS[2U-V+W-X-Y+Z] + (---*B *E + B*D *E + ---*B*E
          4                               4                   4

                                       9   2
       - B*E)COS[2U-2V+W-X-Y+Z] + ( - ---*B *E)COS[2U-3V+W-X-Y+Z] + (
                                       8

          4   3                          9   2  2
       - ---*B *E)COS[2U-4V+W-X-Y+Z] + (---*B *D )COS[U+3V+W+X+Y-Z]
          3                              8

           17   2  2                        9    4
       + (----*B *D )SIN[U+3V+W+X+Y-Z] + (-----*B )COS[U+3V+W-X-Y+Z]
           12                              128

           9    2  2                         2
       + (----*B *E )COS[U+3V-W+X+Y-Z] + (B*D )COS[U+2V+W+X+Y-Z] + (
           64

       2     2                       1    3                       1
      ---*B*D )SIN[U+2V+W+X+Y-Z] + (----*B )COS[U+2V+W-X-Y+Z] + (---
       3                             12                           8

          2                          2  2    2  2    1   2
      *B*E )COS[U+2V-W+X+Y-Z] + ( - B *D  - D *E  + ---*D )COS[U+V+W+
                                                     3

                      2  2      2  2    2   2
      X+Y-Z] + ( - 2*B *D  - 2*D *E  + ---*D )SIN[U+V+W+X+Y-Z] + (
                                        3

          1    4    1   2  2    1   2  2    1   2
       - ----*B  - ---*B *D  - ---*B *E  + ---*B )COS[U+V+W-X-Y+Z] + 
          48        8           8           8

           1   2  2    1   2  2    1    4    1   2
      ( - ---*B *E  - ---*D *E  - ----*E  + ---*E )COS[U+V-W+X+Y-Z]
           8           8           48        8

                2                       2     2
       + ( - B*D )COS[U+W+X+Y-Z] + ( - ---*B*D )SIN[U+W+X+Y-Z] + (
                                        3

            2      2                           1     2
       - B*D  - B*E  + B)COS[U+W-X-Y+Z] + ( - ---*B*E )COS[U-W+X+Y-Z]
                                               8

              1   2  2                      7    2  2
       + ( - ---*B *D )COS[U-V+W+X+Y-Z] + (----*B *D )SIN[U-V+W+X+Y-Z
              8                             12

               7    4    2  2    2  2    2    2  2    2    7    4
      ] + ( - ----*B  - B *D  - B *E  + B  - D *E  + D  - ----*E
               64                                          64

               2                          1   4    1   4
            + E  - 1)COS[U-V+W-X-Y+Z] + (---*B  - ---*E )SIN[U-V+W-X-
                                          8        8

                  1    2  2                         1   2  2
      Y+Z] + ( - ----*B *E )COS[U-V-W+X+Y-Z] + ( - ---*D *E )COS[U-V-
                  64                                8

                      7    2  2                      5   3      2
      W-X-Y+Z] + ( - ----*D *E )SIN[U-V-W-X-Y+Z] + (---*B  + B*D
                      12                             4

            2                           27   4    9   2  2
       + B*E  - B)COS[U-2V+W-X-Y+Z] + (----*B  + ---*B *D
                                        16        8

          9   2  2    9   2                          4   3
       + ---*B *E  - ---*B )COS[U-3V+W-X-Y+Z] + ( - ---*B )COS[U-4V+W
          8           8                              3

                     625   4                       4   3
      -X-Y+Z] + ( - -----*B )COS[U-5V+W-X-Y+Z] + (---*B *E)COS[4V-W+X
                     384                           3

                9   2                            2
      +Y-Z] + (---*B *E)COS[3V-W+X+Y-Z] + ( - B*D *E)COS[2V+W+X+Y-Z]
                8

                  2                          1    3
       + ( - 2*B*D *E)SIN[2V+W+X+Y-Z] + ( - ----*B *E)COS[2V+W-X-Y+Z]
                                             12

              5   3        2                                2
       + ( - ---*B *E - B*D *E + B*E)COS[2V-W+X+Y-Z] + ( - D *E)COS[V
              4

                       2   2                         1   2
      +W+X+Y-Z] + ( - ---*D *E)SIN[V+W+X+Y-Z] + ( - ---*B *E)COS[V+W-
                       3                             8

                    2      2                            2
      X-Y+Z] + ( - B *E - D *E + E)COS[V-W+X+Y-Z] + (B*D *E)COS[W+X+Y

                  2                      2
      -Z] + (2*B*D *E)SIN[W+X+Y-Z] + (B*D *E - B*E)COS[W-X-Y+Z]]


%% Step 5: Calculate R
zz:=bb*vv;


            1   4                3      3                  3   3
ZZ := [( - ---*E )COS[4U] + ( - ----*B*E )COS[3U+V] + ( - ---*E )COS[
            3                    16                        8

                 3      3                  1   2  2
      3U] + ( - ----*B*E )COS[3U-V] + ( - ---*B *E )COS[2U+2V] + (
                 16                        4

          1     2               1   4    1   2                1     2
       - ---*B*E )COS[2U+V] + (---*E  - ---*E )COS[2U] + ( - ---*B*E
          4                     3        2                    4

                        1   2  2                   9    3
      )COS[2U-V] + ( - ---*B *E )COS[2U-2V] + ( - ----*B *E)COS[U+3V]
                        4                          16

              1   2                 1    3      3      3    1
       + ( - ---*B *E)COS[U+2V] + (----*B *E + ----*B*E  - ---*B*E)
              2                     16          16          2

                   3   3                1    3      3      3
      COS[U+V] + (---*E  - E)COS[U] + (----*B *E + ----*B*E
                   8                    16          16

          1                      1   2                    9    3
       - ---*B*E)COS[U-V] + ( - ---*B *E)COS[U-2V] + ( - ----*B *E)
          2                      2                        16

                    4   4             9   3                1   4
      COS[U-3V] + (---*B )COS[4V] + (---*B )COS[3V] + ( - ---*B
                    3                 8                    3

          1   2  2    2                1   3    1     2
       + ---*B *E  + B )COS[2V] + ( - ---*B  + ---*B*E  + B)COS[V] + 
          2                            8        2

        1   2
      (---*E  + 1)]
        2
 yy:=zz*zz*vv;


            1   4                3     3                  1   3
YY := [( - ---*E )COS[4U] + ( - ---*B*E )COS[3U+V] + ( - ---*E )COS[3
            6                    8                        4

                3     3                  9   2  2
      U] + ( - ---*B*E )COS[3U-V] + ( - ---*B *E )COS[2U+2V] + (
                8                        8

          3     2                  3   2  2    1   4    1   2
       - ---*B*E )COS[2U+V] + ( - ---*B *E  + ---*E  - ---*E )COS[2U]
          4                        4           6        2

              3     2                  9   2  2
       + ( - ---*B*E )COS[2U-V] + ( - ---*B *E )COS[2U-2V] + (
              4                        8

          53   3                    9   2                    27   3
       - ----*B *E)COS[U+3V] + ( - ---*B *E)COS[U+2V] + ( - ----*B *E
          8                         2                        8

          3     3                           2      1   3
       + ---*B*E  - 3*B*E)COS[U+V] + ( - 3*B *E + ---*E  - 2*E)COS[U]
          8                                        4

              27   3      3     3                         9   2
       + ( - ----*B *E + ---*B*E  - 3*B*E)COS[U-V] + ( - ---*B *E)COS
              8           8                               2

                    53   3                 77   4             53   3
      [U-2V] + ( - ----*B *E)COS[U-3V] + (----*B )COS[4V] + (----*B )
                    8                      8                  8

                  7   4    27   2  2    9   2             27   3
      COS[3V] + (---*B  + ----*B *E  + ---*B )COS[2V] + (----*B
                  2        4            2                 8

          9     2                  15   4    9   2  2    3   2
       + ---*B*E  + 3*B)COS[V] + (----*B  + ---*B *E  + ---*B
          2                        8         4           2

          3   2
       + ---*E  + 1)]
          2


on fourier;


*** Domain mode RATIONAL changed to FOURIER 


p(0):= fourier 1;


P(0) := [1]
 p(1) := xx;


                 625   4                       4     3
P(1) :=  - [( - -----*E )COS[5U-V+W-X-Y+Z] + (---*B*E )COS[4U+W-X-Y+Z
                 384                           3

                 4   3                          4     3
        ] + ( - ---*E )COS[4U-V+W-X-Y+Z] + ( - ---*B*E )COS[4U-2V+W-X
                 3                              3

                  9   2  2                       17   2  2
        -Y+Z] + (---*D *E )COS[3U+V+W+X+Y-Z] + (----*D *E )SIN[3U+V+W
                  8                              12

                    9    2  2                        9    4
        +X+Y-Z] + (----*B *E )COS[3U+V+W-X-Y+Z] + (-----*E )COS[3U+V-
                    64                              128

                     9     2                     9   2  2    9   2  2
        W+X+Y-Z] + (---*B*E )COS[3U+W-X-Y+Z] + (---*B *E  + ---*D *E
                     8                           8           8

            27   4    9   2                          9     2
         + ----*E  - ---*E )COS[3U-V+W-X-Y+Z] + ( - ---*B*E )COS[3U-2
            16        8                              8

                          81   2  2                          2
        V+W-X-Y+Z] + ( - ----*B *E )COS[3U-3V+W-X-Y+Z] + (B*D *E)COS[
                          64

                               2                          1    3
        2U+2V+W+X+Y-Z] + (2*B*D *E)SIN[2U+2V+W+X+Y-Z] + (----*B *E)
                                                          12

                               1      3                        2
        COS[2U+2V+W-X-Y+Z] + (----*B*E )COS[2U+2V-W+X+Y-Z] + (D *E)
                               12

                              2   2                         1   2
        COS[2U+V+W+X+Y-Z] + (---*D *E)SIN[2U+V+W+X+Y-Z] + (---*B *E)
                              3                             8

                              1    3                            2
        COS[2U+V+W-X-Y+Z] + (----*E )COS[2U+V-W+X+Y-Z] + ( - B*D *E)
                              12

                                   2                            2
        COS[2U+W+X+Y-Z] + ( - 2*B*D *E)SIN[2U+W+X+Y-Z] + ( - B*D *E

            5     3                              1      3
         - ---*B*E  + B*E)COS[2U+W-X-Y+Z] + ( - ----*B*E )COS[2U-W+X+
            4                                    12

                 2      2      5   3
        Y-Z] + (B *E + D *E + ---*E  - E)COS[2U-V+W-X-Y+Z] + (
                               4

         5   3        2      5     3
        ---*B *E + B*D *E + ---*B*E  - B*E)COS[2U-2V+W-X-Y+Z] + (
         4                   4

            9   2                             4   3
         - ---*B *E)COS[2U-3V+W-X-Y+Z] + ( - ---*B *E)COS[2U-4V+W-X-Y
            8                                 3

                9   2  2                       17   2  2
        +Z] + (---*B *D )COS[U+3V+W+X+Y-Z] + (----*B *D )SIN[U+3V+W+X
                8                              12

                   9    4                       9    2  2
        +Y-Z] + (-----*B )COS[U+3V+W-X-Y+Z] + (----*B *E )COS[U+3V-W+
                  128                           64

                     2                       2     2
        X+Y-Z] + (B*D )COS[U+2V+W+X+Y-Z] + (---*B*D )SIN[U+2V+W+X+Y-Z
                                             3

              1    3                       1     2
        ] + (----*B )COS[U+2V+W-X-Y+Z] + (---*B*E )COS[U+2V-W+X+Y-Z]
              12                           8

                2  2    2  2    1   2                           2  2
         + ( - B *D  - D *E  + ---*D )COS[U+V+W+X+Y-Z] + ( - 2*B *D
                                3

              2  2    2   2                         1    4
         - 2*D *E  + ---*D )SIN[U+V+W+X+Y-Z] + ( - ----*B
                      3                             48

            1   2  2    1   2  2    1   2
         - ---*B *D  - ---*B *E  + ---*B )COS[U+V+W-X-Y+Z] + (
            8           8           8

            1   2  2    1   2  2    1    4    1   2
         - ---*B *E  - ---*D *E  - ----*E  + ---*E )COS[U+V-W+X+Y-Z]
            8           8           48        8

                  2                       2     2
         + ( - B*D )COS[U+W+X+Y-Z] + ( - ---*B*D )SIN[U+W+X+Y-Z] + (
                                          3

              2      2                           1     2
         - B*D  - B*E  + B)COS[U+W-X-Y+Z] + ( - ---*B*E )COS[U-W+X+Y-
                                                 8

                  1   2  2                      7    2  2
        Z] + ( - ---*B *D )COS[U-V+W+X+Y-Z] + (----*B *D )SIN[U-V+W+X
                  8                             12

                     7    4    2  2    2  2    2    2  2    2
        +Y-Z] + ( - ----*B  - B *D  - B *E  + B  - D *E  + D
                     64

                     7    4    2                          1   4
                  - ----*E  + E  - 1)COS[U-V+W-X-Y+Z] + (---*B
                     64                                   8

            1   4                         1    2  2
         - ---*E )SIN[U-V+W-X-Y+Z] + ( - ----*B *E )COS[U-V-W+X+Y-Z]
            8                             64

                1   2  2                         7    2  2
         + ( - ---*D *E )COS[U-V-W-X-Y+Z] + ( - ----*D *E )SIN[U-V-W-
                8                                12

                   5   3      2      2
        X-Y+Z] + (---*B  + B*D  + B*E  - B)COS[U-2V+W-X-Y+Z] + (
                   4

         27   4    9   2  2    9   2  2    9   2
        ----*B  + ---*B *D  + ---*B *E  - ---*B )COS[U-3V+W-X-Y+Z] + 
         16        8           8           8

             4   3                          625   4
        ( - ---*B )COS[U-4V+W-X-Y+Z] + ( - -----*B )COS[U-5V+W-X-Y+Z]
             3                              384

             4   3                       9   2
         + (---*B *E)COS[4V-W+X+Y-Z] + (---*B *E)COS[3V-W+X+Y-Z] + (
             3                           8

              2                              2
         - B*D *E)COS[2V+W+X+Y-Z] + ( - 2*B*D *E)SIN[2V+W+X+Y-Z] + (

            1    3                          5   3        2
         - ----*B *E)COS[2V+W-X-Y+Z] + ( - ---*B *E - B*D *E + B*E)
            12                              4

                               2                         2   2
        COS[2V-W+X+Y-Z] + ( - D *E)COS[V+W+X+Y-Z] + ( - ---*D *E)SIN[
                                                         3

                          1   2                         2      2
        V+W+X+Y-Z] + ( - ---*B *E)COS[V+W-X-Y+Z] + ( - B *E - D *E
                          8

                                  2                        2
         + E)COS[V-W+X+Y-Z] + (B*D *E)COS[W+X+Y-Z] + (2*B*D *E)SIN[W+

                     2
        X+Y-Z] + (B*D *E - B*E)COS[W-X-Y+Z]]

for i := 2:n/2+2 do <<
  wtlevel n+4-2i;
  p(i) := fourier ((2*i-1)/i)*xx*p(i-1) - fourier ((i-1)/i)*p(i-2);
>>;



wtlevel n;


for i:=n/2+2 step -1 until 3 do p(n/2+2):=fourier(a*a)*zz*p(n/2+2)+p(i-1);



yy*p(n/2+2);


   27   4                               25     3
[(----*E )COS[6U-2V+2W-2X-2Y+2Z] + ( - ----*B*E )COS[5U-V+2W-2X-2Y+2Z
   32                                   64

      25   3                            75   2  2
] + (----*E )COS[5U-2V+2W-2X-2Y+2Z] + (----*A *E )COS[5U-3V+3W-3X-3Y+
      32                                64

        175     3                               13   2  2
3Z] + (-----*B*E )COS[5U-3V+2W-2X-2Y+2Z] + ( - ----*D *E )COS[4U+2W]
        64                                      8

          2  2                   1    4                3     2
 + ( - 2*D *E )SIN[4U+2W] + ( - ----*E )COS[4U] + ( - ---*B*E )COS[4U
                                 24                    8

                       15   2
-V+2W-2X-2Y+2Z] + ( - ----*A *B*E)COS[4U-2V+3W-3X-3Y+3Z] + (
                       16

    15   2  2    3   2  2    15   4    3   2
 - ----*B *E  - ---*D *E  - ----*E  + ---*E )COS[4U-2V+2W-2X-2Y+2Z]
    8            2           8         4

     15   2                              21     2
 + (----*A *E)COS[4U-3V+3W-3X-3Y+3Z] + (----*B*E )COS[4U-3V+2W-2X-2Y+
     16                                  8

        35   4                            75   2
2Z] + (----*A )COS[4U-4V+4W-4X-4Y+4Z] + (----*A *B*E)COS[4U-4V+3W-3X-
        64                                16

           51   2  2                               9     2
3Y+3Z] + (----*B *E )COS[4U-4V+2W-2X-2Y+2Z] + ( - ---*B*D *E)COS[3U+V
           8                                       4

            7     2                    1    3
+2W] + ( - ---*B*D *E)SIN[3U+V+2W] + (----*B *E)COS[3U+V+2W-2X-2Y+2Z]
            2                          64

        3      3                  3   2                     2
 + ( - ----*B*E )COS[3U+V] + ( - ---*D *E)COS[3U+2W] + ( - D *E)SIN[3
        32                        2

             1    3                5   2  2
U+2W] + ( - ----*E )COS[3U] + ( - ---*A *D )COS[3U-V+3W-X-Y+Z] + (
             16                    8

    5   2  2                        5    2  2
 - ---*A *D )SIN[3U-V+3W-X-Y+Z] + (----*A *B )COS[3U-V+3W-3X-3Y+3Z]
    4                               64

        9     2                    1     2
 + ( - ---*B*D *E)COS[3U-V+2W] + (---*B*D *E)SIN[3U-V+2W] + (
        4                          2

 3    3      3     2      57     3    3
----*B *E + ---*B*D *E + ----*B*E  - ---*B*E)COS[3U-V+2W-2X-2Y+2Z] + 
 64          4            64          8

     9    2  2                          3      3
( - ----*A *E )COS[3U-V+W-X-Y+Z] + ( - ----*B*E )COS[3U-V] + (
     64                                 32

    5   2                                 15   2      3   2
 - ---*A *B)COS[3U-2V+3W-3X-3Y+3Z] + ( - ----*B *E - ---*D *E
    8                                     8           2

    57   3    3                                  15   2  2
 - ----*E  + ---*E)COS[3U-2V+2W-2X-2Y+2Z] + ( - ----*A *B
    32        4                                  4

    15   2  2    15   2  2    5   2
 - ----*A *D  - ----*A *E  + ---*A )COS[3U-3V+3W-3X-3Y+3Z] + (
    8            4            8

    369   3      21     2      399     3    21
 - -----*B *E - ----*B*D *E - -----*B*E  + ----*B*E)COS[3U-3V+2W-2X-2
    64           4             64           8

          25   2                              51   2
Y+2Z] + (----*A *B)COS[3U-4V+3W-3X-3Y+3Z] + (----*B *E)COS[3U-4V+2W-2
          8                                   8

             635   2  2                            845   3
X-2Y+2Z] + (-----*A *B )COS[3U-5V+3W-3X-3Y+3Z] + (-----*B *E)COS[3U-5
             64                                    64

                      1   4                            1   4
V+2W-2X-2Y+2Z] + ( - ---*D )COS[2U+2V+2W+2X+2Y-2Z] + (---*D )SIN[2U+2
                      4                                3

                      11   2  2                      13   2  2
V+2W+2X+2Y-2Z] + ( - ----*B *D )COS[2U+2V+2W] + ( - ----*B *D )SIN[2U
                      4                              4

            1    4                            2  2
+2V+2W] + (----*B )COS[2U+2V+2W-2X-2Y+2Z] + (D *E )COS[2U+2V+2X+2Y-2Z
            32

         3   2  2                            9    2  2
] + ( - ---*D *E )SIN[2U+2V+2X+2Y-2Z] + ( - ----*B *E )COS[2U+2V] + (
         4                                   32

    3    4                               7     2
 - ----*E )COS[2U+2V-2W+2X+2Y-2Z] + ( - ---*B*D )COS[2U+V+2W] + (
    64                                   4

    3     2                  1    3
 - ---*B*D )SIN[2U+V+2W] + (----*B )COS[2U+V+2W-2X-2Y+2Z] + (
    2                        64

    3      2                  7   2  2    1   4    17   2  2    1   2
 - ----*B*E )COS[2U+V] + ( - ---*B *D  + ---*D  + ----*D *E  - ---*D
    16                        4           2        4            2

                1   2  2    4    9   2  2    2
)COS[2U+2W] + (---*B *D  + D  + ---*D *E  - D )SIN[2U+2W] + (
                2                2

    3    2                            3    2  2    3   2  2    1    4
 - ----*A *B*E)COS[2U+W-X-Y+Z] + ( - ----*B *E  + ---*D *E  + ----*E
    16                                16           4           24

    1   2             1     2                     3     2
 - ---*E )COS[2U] + (---*B*D )COS[2U-V+2W] + ( - ---*B*D )SIN[2U-V+2W
    8                 4                           2

      3    3    3     2    15     2    3
] + (----*B  + ---*B*D  + ----*B*E  - ---*B)COS[2U-V+2W-2X-2Y+2Z] + (
      64        4          16          8

    3    2                            3      2               45   2
 - ----*A *E)COS[2U-V+W-X-Y+Z] + ( - ----*B*E )COS[2U-V] + (----*A *B
    16                                16                     16

                              3   2  2                      13   2  2
*E)COS[2U-2V+3W-3X-3Y+3Z] + (---*B *D )COS[2U-2V+2W] + ( - ----*B *D
                              2                             4

                   5    4    39   4    15   2  2    75   2  2
)SIN[2U-2V+2W] + (----*A  + ----*B  + ----*B *D  + ----*B *E
                   16        64        4            16

                      15   2    3   4    15   2  2    3   2    69   4
                   - ----*B  + ---*D  + ----*D *E  - ---*D  + ----*E
                      8         4        4            2        64

                      15   2    3
                   - ----*E  + ---)COS[2U-2V+2W-2X-2Y+2Z] + (
                      8         4

    3    4    3    4                               9    2
 - ----*B  + ----*E )SIN[2U-2V+2W-2X-2Y+2Z] + ( - ----*A *B*E)COS[2U-
    16        16                                   16

                   9    2  2                1   2  2
2V+W-X-Y+Z] + ( - ----*B *E )COS[2U-2V] + (---*D *E )COS[2U-2V-2X-2Y+
                   32                       4

        3   2  2                            45   2
2Z] + (---*D *E )SIN[2U-2V-2X-2Y+2Z] + ( - ----*A *E)COS[2U-3V+3W-3X-
        4                                   16

              369   3    21     2    105     2    21
3Y+3Z] + ( - -----*B  - ----*B*D  - -----*B*E  + ----*B)COS[2U-3V+2W-
              64         4           16           8

                 225   2                                   115   4
2X-2Y+2Z] + ( - -----*A *B*E)COS[2U-4V+3W-3X-3Y+3Z] + ( - -----*B
                 16                                         8

    51   2  2    255   2  2    51   2                            845
 - ----*B *D  - -----*B *E  + ----*B )COS[2U-4V+2W-2X-2Y+2Z] + (-----
    4            16            8                                 64

  3                            1599   4                            1
*B )COS[2U-5V+2W-2X-2Y+2Z] + (------*B )COS[2U-6V+2W-2X-2Y+2Z] + (---
                                64                                 4

    2                          3     2
*B*D *E)COS[U+3V+2X+2Y-2Z] + (---*B*D *E)SIN[U+3V+2X+2Y-2Z] + (
                               2

    53   3                    49     3
 - ----*B *E)COS[U+3V] + ( - ----*B*E )COS[U+3V-2W+2X+2Y-2Z] + (
    32                        64

    1   2                          2
 - ---*D *E)COS[U+2V+2X+2Y-2Z] + (D *E)SIN[U+2V+2X+2Y-2Z] + (
    2

    9   2                    7    3                           23
 - ---*B *E)COS[U+2V] + ( - ----*E )COS[U+2V-2W+2X+2Y-2Z] + (----*B
    8                        32                               4

  2                   13     2                      3    3
*D *E)COS[U+V+2W] + (----*B*D *E)SIN[U+V+2W] + ( - ----*B *E)COS[U+V+
                      2                             64

                    3   2  2                         3   2  2
2W-2X-2Y+2Z] + ( - ---*A *D )COS[U+V+W+X+Y-Z] + ( - ---*A *D )SIN[U+V
                    4                                2

              33   2  2                         7     2
+W+X+Y-Z] + (----*A *B )COS[U+V+W-X-Y+Z] + ( - ---*B*D *E)COS[U+V+2X+
              64                                4

           3     2                            27   3      9     2
2Y-2Z] + (---*B*D *E)SIN[U+V+2X+2Y-2Z] + ( - ----*B *E + ---*B*D *E
           2                                  32          2

    3      3    3                   33   2  2
 + ----*B*E  - ---*B*E)COS[U+V] + (----*A *E )COS[U+V-W+X+Y-Z] + (
    32          4                   64

 7      3                          5   2                   2
----*B*E )COS[U+V-2W+2X+2Y-2Z] + (---*D *E)COS[U+2W] + (3*D *E)SIN[U+
 64                                2

        3   2                         3   2        2      1    3
2W] + (---*A *B)COS[U+W-X-Y+Z] + ( - ---*B *E + 3*D *E + ----*E
        8                             4                   16

    1               7     2                   5     2
 - ---*E)COS[U] + (---*B*D *E)COS[U-V+2W] + (---*B*D *E)SIN[U-V+2W]
    2               4                         2

        9    3      9     2      39     3    9
 + ( - ----*B *E - ---*B*D *E - ----*B*E  + ---*B*E)COS[U-V+2W-2X-2Y+
        64          4            64          8

        3   2  2    33   2  2    3   2  2    3   2
2Z] + (---*A *B  - ----*A *D  + ---*A *E  + ---*A )COS[U-V+W-X-Y+Z]
        4           8            4           8

        27   3      9     2      3      3    3
 + ( - ----*B *E + ---*B*D *E + ----*B*E  - ---*B*E)COS[U-V] + (
        32          2            32          4

    3     2                         5     2
 - ---*B*D *E)COS[U-V-2X-2Y+2Z] + (---*B*D *E)SIN[U-V-2X-2Y+2Z] + (
    4                               2

 45   2      9   2      39   3    9                              9
----*B *E + ---*D *E + ----*E  - ---*E)COS[U-2V+2W-2X-2Y+2Z] + (---
 8           2          32        4                              8

  2                            9   2                 3   2
*A *B)COS[U-2V+W-X-Y+Z] + ( - ---*B *E)COS[U-2V] + (---*D *E)COS[U-2V
                               8                     2

                  2                          285   2  2
-2X-2Y+2Z] + ( - D *E)SIN[U-2V-2X-2Y+2Z] + (-----*A *E )COS[U-3V+3W-3
                                             64

             1107   3      63     2      273     3    63
X-3Y+3Z] + (------*B *E + ----*B*D *E + -----*B*E  - ----*B*E)COS[U-3
              64           4             64           8

                   159   2  2                          5   2  2
V+2W-2X-2Y+2Z] + (-----*A *B )COS[U-3V+W-X-Y+Z] + ( - ---*A *D )COS[U
                   64                                  8

                    5   2  2                             53   3
-3V+W-3X-3Y+3Z] + (---*A *D )SIN[U-3V+W-3X-3Y+3Z] + ( - ----*B *E)COS
                    4                                    32

           21     2                             11     2
[U-3V] + (----*B*D *E)COS[U-3V-2X-2Y+2Z] + ( - ----*B*D *E)SIN[U-3V-2
           4                                    2

                153   2                                2535   3
X-2Y+2Z] + ( - -----*B *E)COS[U-4V+2W-2X-2Y+2Z] + ( - ------*B *E)COS
                 8                                      64

                          63   2  2                         19   2  2
[U-5V+2W-2X-2Y+2Z] + ( - ----*B *D )COS[4V+2X+2Y-2Z] + ( - ----*B *D
                          8                                 2

                      77   4             255   2  2
)SIN[4V+2X+2Y-2Z] + (----*B )COS[4V] + (-----*B *E )COS[4V-2W+2X+2Y-2
                      32                 16

          11     2                         7     2
Z] + ( - ----*B*D )COS[3V+2X+2Y-2Z] + ( - ---*B*D )SIN[3V+2X+2Y-2Z]
          4                                2

     53   3             105     2                         17   2  2
 + (----*B )COS[3V] + (-----*B*E )COS[3V-2W+2X+2Y-2Z] + (----*B *D
     32                 16                                4

    1   4    7   2  2    1   2                      9   2  2    4
 + ---*D  - ---*D *E  - ---*D )COS[2V+2X+2Y-2Z] + (---*B *D  + D
    2        4           2                          2

    1   2  2    2                      7   4    27   2  2
 + ---*D *E  - D )SIN[2V+2X+2Y-2Z] + (---*B  - ----*B *D
    2                                  8        4

    27   2  2    9   2                45   2
 + ----*B *E  + ---*B )COS[2V] + ( - ----*A *B*E)COS[2V-W+X+Y-Z] + (
    16           8                    16

    75   2  2    15   2  2    15   2                         5     2
 - ----*B *E  - ----*D *E  + ----*E )COS[2V-2W+2X+2Y-2Z] + (---*B*D )
    16           4            8                              4

                    1     2                     27   3    9     2
COS[V+2X+2Y-2Z] + (---*B*D )SIN[V+2X+2Y-2Z] + (----*B  - ---*B*D
                    2                           32        2

    9     2    3                  15   2
 + ---*B*E  + ---*B)COS[V] + ( - ----*A *E)COS[V-W+X+Y-Z] + (
    8          4                  16

    15     2                           25   2  2
 - ----*B*E )COS[V-2W+2X+2Y-2Z] + ( - ----*D *E )COS[2W] + (
    16                                 8

    7   2  2                15   2                      5   2  2
 - ---*D *E )SIN[2W] + ( - ----*A *B*E)COS[W-X-Y+Z] + (---*B *D )COS[
    2                       16                          8

                 2  2                   9    4    15   4    9   2  2
2X+2Y-2Z] + ( - B *D )SIN[2X+2Y-2Z] + (----*A  + ----*B  - ---*B *D
                                        64        32        4

    9    2  2    3   2    7   4    9   2  2    3   2    3   2    1
 + ----*B *E  + ---*B  + ---*D  - ---*D *E  - ---*D  + ---*E  + ---)]
    16           8        6        4           2        8        4


showtime;


Time: 15232 ms  plus GC time: 578 ms
end;


Time: 0 ms


Quitting

Added r34.1/lib/camal.red version [3c88890c55].





































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
%%off comp;
lisp;
%%module foursupport;

%% This section is to define macros and simple functions to handle the
%% data structures for harmonic forms.
%% The structure is a vector:
%% Coeff | FN | Angle | Next
%
%% This version only allows 8 angles.  Consider extending this later.

switch fourier;


%% A vector and counter to record link between angle names and index

global '(next!-angle!* fourier!-name!*);
next!-angle!* := 0;
if vectorp fourier!-name!* then <<
        for i :=0:7 do remprop(getv(fourier!-name!*, i), 'fourier!-angle)
>>;
fourier!-name!* := mkvect 7;

%% For non Cambridge LISP add 
smacro procedure putv!.unsafe(x,y,z); putv(x,y,z);
smacro procedure getv!.unsafe(x,y); getv(x,y);

%% Data abtraction says that we should define macros for access to 
%% the parts of the Fourier structure

smacro procedure fs!:set!-next(f,p); putv!.unsafe(f, 3, p);

smacro procedure fs!:next(f); getv!.unsafe(f,3);

smacro procedure fs!:set!-coeff(f,p); putv!.unsafe(f, 0, p);

smacro procedure fs!:coeff(f); getv!.unsafe(f, 0);

smacro procedure fs!:set!-fn(f,p); putv!.unsafe(f, 1, p);

smacro procedure fs!:fn(f); getv!.unsafe(f, 1);

smacro procedure fs!:set!-angle(f,p); putv!.unsafe(f, 2, p);

smacro procedure fs!:angle(f); getv!.unsafe(f, 2);

%% Some support functions for angle expressions

symbolic procedure fs!:make!-nullangle();
begin scalar ans;
    ans := mkvect 7;
    for i:=0:7 do putv!.unsafe(ans,i,0);
    return ans;
end;

symbolic procedure fs!:null!-angle!: u;
  fs!:null!-angle cdr u;

symbolic procedure fs!:null!-angle u;
begin scalar ans, i, x;
    x := fs!:angle u;
    ans := t;
    i := 0;
top:
    if not(getv!.unsafe(x,i)=0) then return nil;
    i := i+1;
    if (i<8) then go to top;
    return ans;
end;


%%module fourdom; % Domain definitions for angles and fourier series

% Authors: John Fitch 1991

global '(domainlist!*);

domainlist!*:=union('(!:fs!:),domainlist!*);

put('fourier,'tag,'!:fs!:);
put('!:fs!:,'dname,'fourier);
flag('(!:fs!:),'field); %% Should be ring really
put('!:fs!:,'i2d,'i2fourier);
put('!:fs!:,'minusp,'fs!:minusp!:);
put('!:fs!:,'plus,'fs!:plus!:);
put('!:fs!:,'times,'fs!:times!:);
put('!:fs!:, 'expt,'fs!:expt!:);
put('!:fs!:,'difference,'fs!:difference!:);
put('!:fs!:,'quotient,'fs!:quotient!:);
put('!:fs!:, 'divide, 'fs!:divide!:);
put('!:fs!:, 'gcd, 'fs!:gcd!:);
put('!:fs!:,'zerop,'fs!:zerop!:);
put('!:fs!:,'onep,'fs!:onep!:);
put('!:fs!:,'prepfn,'fs!:prepfn!:);
put('!:fs!:,'specprn,'fs!:prin!:);
put('!:fs!:,'prifn,'fs!:prin!:);
put('!:fs!:,'intequivfn,'fs!:intequiv!:);
flag('(!:fs!:),'ratmode);
% conversion functions

put('!:fs!:,'!:mod!:,mkdmoderr('!:fs!:,'!:mod!:));
% put('!:fs!:,'!:gi!:,mkdmoderr('!:fs!:,'!:gi!:));
% put('!:fs!:,'!:bf!:,mkdmoderr('!:fs!:,'!:bf!:));
% put('!:fs!:,'!:rn!:,mkdmoderr('!:fs!:,'!:rn!:));
put('!:rn!:,'!:fs!:,'!*d2fourier);
put('!:ft!:,'!:fs!:,'cdr);
put('!:bf!:,'!:fs!:,'!*d2fourier);
put('!:gi!:,'!:fs!:,'!*d2fourier);
put('!:gf!:,'!:fs!:,'!*d2fourier);

put('expt, '!:fs!:, 'fs!:expt!:);

% Conversion functions

symbolic procedure i2fourier u; 
  if dmode!*='!:fs!: then !*d2fourier u else u;

symbolic procedure !*d2fourier u;
if null u then nil else
begin scalar fourier;
      fourier:=mkvect 3;
      fs!:set!-coeff(fourier,(u . 1)); 
      fs!:set!-fn(fourier,'cos);
      fs!:set!-angle(fourier,fs!:make!-nullangle()); 
      fs!:set!-next(fourier,nil); 
     return get('fourier,'tag) . fourier
end;

symbolic procedure !*sq2fourier u;
if null car u then nil else
begin scalar fourier;
      fourier:=mkvect 3;
      fs!:set!-coeff(fourier,u); 
      fs!:set!-fn(fourier,'cos);
      fs!:set!-angle(fourier,fs!:make!-nullangle()); 
      fs!:set!-next(fourier,nil); 
     return get('fourier,'tag) . fourier
end;

symbolic procedure fs!:minusp!:(x); fs!:minusp cdr x;

symbolic procedure fs!:minusp x; 
if null x then nil else 
   if null fs!:next x then minusf car fs!:coeff x
   else fs!:minusp fs!:next x;

%% Basic algebraic operations

symbolic procedure fs!:times!:(x,y);
% This function seems to be called with numeric values as well
   if null x then nil else if null y then nil
   else if numberp y then get('fourier,'tag) . fs!:timescoeff(y ./ 1, cdr x)
   else if numberp x then get('fourier,'tag) . fs!:timescoeff(x ./ 1, cdr y)
   else if not eqcar(x, get('fourier,'tag)) then
        get('fourier,'tag) . fs!:timescoeff(x,cdr y)
   else if not eqcar(y, get('fourier,'tag)) then
        get('fourier,'tag) . fs!:timescoeff(y,cdr x)
   else get('fourier,'tag) . fs!:times(cdr x, cdr y);

symbolic procedure fs!:timescoeff(x, y);
if null y then nil
   else begin scalar ans, coeff;
      coeff := multsq(x,fs!:coeff y); 
      if coeff = '(nil . 1) then <<
        print "zero in times";
        return fs!:timescoeff(x, fs!:next y) >>;
      ans := mkvect 3;
      fs!:set!-coeff(ans,coeff);
      fs!:set!-fn(ans,fs!:fn y);
      fs!:set!-angle(ans,fs!:angle y); 
      fs!:set!-next(ans, fs!:timescoeff(x, fs!:next y));
      return ans
   end;

symbolic procedure fs!:times(x,y);
if null x then nil else if null y then nil else
begin scalar ans;
        ans := fs!:timesterm(x, y);
        return fs!:plus(ans, fs!:times(fs!:next  x, y));
end;

symbolic procedure fs!:timesterm(x,y);
% Treat x as a term and y as a tree
if null y then nil else if null x then nil else
begin scalar ans;
        ans := fs!:timestermterm(x,y);
        return fs!:plus(ans, fs!:timesterm(x, fs!:next y));
end;

symbolic procedure fs!:timestermterm(x,y);
% x and y are terms.  Generate the two answer terms.
begin scalar sum, diff, ans, xv, yv, coeff;
        sum := mkvect 7;
        xv := fs!:angle x;
        yv := fs!:angle y;
        for i:=0:7 do putv!.unsafe(sum,i,
                                   getv!.unsafe(xv,i)+getv!.unsafe(yv,i));
        diff := mkvect 7;
        for i:=0:7 do putv!.unsafe(diff,i, 
                                   getv!.unsafe(xv,i)-getv!.unsafe(yv,i));
        coeff := multsq(fs!:coeff x, fs!:coeff y);
        coeff := multsq(coeff, '(1 . 2));
        if null car coeff then return nil;
        if fs!:fn x = 'sin then
            if fs!:fn y = 'sin then
                % sin x*sin y => [-cos(x+y)+cos(x-y)]/2
                return fs!:plus(make!-term('cos, sum, negsq coeff),
                                make!-term('cos,diff, coeff))
            else % fs!:fn y = 'cos
                % sin x * cos y => [sin(x+y)+sin(x-y)]/2
                return fs!:plus(make!-term('sin, sum, coeff),
                                make!-term('sin, diff,coeff))
        else % fs!:fn x='cos
            if fs!:fn y = 'sin then
                % cos x*sin y => [sin(x+y)-sin(x-y)]/2
                return fs!:plus(make!-term('sin, sum, coeff),
                                make!-term('sin,diff, negsq coeff))
            else % fs!:fn y = 'cos
                % cos x * cos y => [cos(x+y)+cos(x-y)]/2
                return fs!:plus(make!-term('cos, sum, coeff),
                                make!-term('cos, diff,coeff))
            
end;

symbolic procedure fs!:expt!:(x,n);
begin scalar ans, xx;
    ans := cdr !*d2fourier 1;
    x := cdr x;
    for i:=1:n do ans := fs!:times(ans,x);
    return get('fourier,'tag) . ans;
end;

symbolic procedure make!-term(fn, ang, coeff);
begin scalar fourier, sign, i;
      sign := 0;
      i:=0;
top:  if getv!.unsafe(ang,i)<0 then sign := -1
      else if getv!.unsafe(ang,i)>0 then sign := 1
      else if i=7 then <<
        if fn ='sin then return nil >>
      else << i := i #+ 1; goto top >>;
      fourier:=mkvect 3;
      if sign = 1 or fn = 'cos then fs!:set!-coeff(fourier,coeff)
      else fs!:set!-coeff(fourier, multsq('(-1 . 1), coeff));
      fs!:set!-fn(fourier,fn);
      if sign = -1 then << sign := mkvect 7;
        for i:=0:7 do putv!.unsafe(sign,i,-getv!.unsafe(ang,i));
        ang := sign
      >>;
      fs!:set!-angle(fourier,ang); 
      fs!:set!-next(fourier,nil); 
     return fourier
end;

symbolic procedure fs!:quotient!:(x,y);
if numberp y then fs!:times!:(x, !*sq2fourier (1 ./ y))
else rerror(fourier, 98, "Unimplemented");

symbolic procedure fs!:divide!:(x,y);
rerror(fourier, 98, "Unimplemented");

symbolic procedure fs!:gcd!:(x,y);
rerror(fourier, 98, "Unimplemented");

symbolic procedure fs!:difference!:(x,y);
   fs!:plus!:(x, fs!:negate!: y);

symbolic procedure fs!:negate!: x;
  get('fourier,'tag) . fs!:negate cdr x;

symbolic procedure fs!:negate x;
   if null x then nil
   else begin scalar ans;
      ans := mkvect 3;
      fs!:set!-coeff(ans,negsq fs!:coeff x); 
      fs!:set!-fn(ans,fs!:fn x);
      fs!:set!-angle(ans,fs!:angle x); 
      fs!:set!-next(ans, fs!:negate fs!:next x); 
      return ans
   end;

symbolic procedure fs!:zerop!:(u);
  null u or
  (not numberp u and
   null cdr u or
   (null fs!:next cdr u and 
   ((numberp v and zerop v) where v=fs!:coeff cdr u)));

symbolic procedure fs!:onep!:(u); fs!:onep cdr u;

symbolic procedure fs!:onep u;
  null fs!:next u and 
  onep fs!:coeff u and fs!:null!-angle u and fs!:fn(u) = 'cos;

symbolic procedure fs!:prepfn!:(x); x;

symbolic procedure simpfs u; u;

put('!:fs!:,'simpfn,'simpfs);

%% PRINTING FUNCTIONS

%% We have all the usual problems of unit coefficients, and zero angles

smacro procedure zeroterm x; fs!:coeff x = '(nil  . 1);

symbolic procedure fs!:prin!:(x);
  << prin2!* "["; fs!:prin cdr x; prin2!* "]" >>;

symbolic procedure fs!:prin x;
   if null x then prin2!* " 0 " else <<
   while x do <<
     fs!:prin1 x;
     x := fs!:next x;
     if x then prin2!* " + "
   >>
>>;

symbolic procedure fs!:prin1 x;
begin scalar first, u, v;
   first := t;
   if not(fs!:coeff x = '(1 . 1)) then <<
      prin2!* "("; sqprint fs!:coeff x;
      prin2!* ")" >>;
   if not(fs!:null!-angle x) then <<
     prin2!* fs!:fn x;
     prin2!* "[";
     u := fs!:angle x;
     for i:=0:7 do
         if not((v := getv!.unsafe(u,i)) = 0) then <<
            if v<0 then << first := t; prin2!* "-"; v := -v >>;
            if not first then prin2!* "+";
            if not(v=1) then prin2!* v;
            first := nil;
            prin2!* getv!.unsafe(fourier!-name!*, i)
     >>;
     prin2!* "]"
  >>
  else if fs!:coeff x = '(1 . 1) then prin2!* "1"
end;

symbolic procedure fs!:intequiv!:(u);
   null fs!:next x and 
   fs!:null!-angle x and
   fs!:fn(x) = 'cos and 
   fixp car fs!:coeff x and
   cdr fs!:coeff x = 1
        where x = cdr u;

%%module fourplus;

%% ARITHMETIC

%% Addition of Fourier expressionsis really a merge operation

symbolic procedure fs!:plus!:(x,y);
 %% Top level addition of two fourier series
    if fs!:zerop!: y then x
    else if fs!:zerop!: x then y
    else get('fourier,'tag) . fs!:plus(copy!-tree cdr x, copy!-tree cdr y);

% I cannot rely on the CAMAL selective copy, so I take the coward's way out
symbolic procedure copy!-tree x;
   if null x then nil
   else begin scalar ans;
      ans := mkvect 3;
      fs!:set!-coeff(ans,fs!:coeff x); 
      fs!:set!-fn(ans,fs!:fn x);
      fs!:set!-angle(ans,fs!:angle x); 
      fs!:set!-next(ans, copy!-tree fs!:next x); 
      return ans
   end;

symbolic procedure fs!:plus(x, y);
  %% The real addition.  x is a new tree to which y must be merged.
  if null y then x
  else if null x then y
  else if fs!:fn x = fs!:fn y and angles!-equal(fs!:angle x, fs!:angle y) then
        begin scalar coef;
            coef := addsq(fs!:coeff x, fs!:coeff y);
        % Really I should deal with the zero case here
            if null car coef then return fs!:plus(fs!:next x, fs!:next y);
            fs!:set!-coeff(x, coef);
            fs!:set!-next(x, fs!:plus(fs!:next x, fs!:next y));
            return x 
        end
    else if fs!:angle!-order(x, y) then <<
          fs!:set!-next(x, fs!:plus(fs!:next x, y));
          x >>
    else <<
          fs!:set!-next(y, fs!:plus(fs!:next y,x));
          y >>;

symbolic procedure angles!-equal(x, y);
% Are all angles the same?
begin scalar i;
    i := 0;
top:
    if not(getv!.unsafe(x,i)=getv!.unsafe(y,i)) then return nil;
    i := i+1;
    if (i<8) then go to top;
    return t;
end;

symbolic procedure fs!:angle!-order(x, y);
% Ordering function for angle expressions, also taking account of angle.
begin scalar ans, i, xx, yy;
    i := 0;
    xx := fs!:angle x;
    yy := fs!:angle y;