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!*;