summaryrefslogtreecommitdiff
path: root/web/reduce
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /web/reduce
Initial commit
Diffstat (limited to 'web/reduce')
-rw-r--r--web/reduce/rweb/Makefile144
-rw-r--r--web/reduce/rweb/Makefile3.3152
-rw-r--r--web/reduce/rweb/README35
-rw-r--r--web/reduce/rweb/appl/integrator.web1230
-rw-r--r--web/reduce/rweb/appl/liesuper.web4287
-rw-r--r--web/reduce/rweb/appl/liesuperconvert.web51
-rw-r--r--web/reduce/rweb/appl/list2vector.ch107
-rw-r--r--web/reduce/rweb/appl/source/integrator.red991
-rw-r--r--web/reduce/rweb/appl/source/liesuper.red2908
-rw-r--r--web/reduce/rweb/appl/source/supervf.red330
-rw-r--r--web/reduce/rweb/appl/source/tools.red446
-rw-r--r--web/reduce/rweb/appl/supervf.web569
-rw-r--r--web/reduce/rweb/appl/sym_cond_example200
-rw-r--r--web/reduce/rweb/appl/symmetry.tex974
-rw-r--r--web/reduce/rweb/appl/tools.web1032
-rw-r--r--web/reduce/rweb/make3
-rw-r--r--web/reduce/rweb/make3.33
-rw-r--r--web/reduce/rweb/reduce.spider302
-rw-r--r--web/reduce/rweb/reduce33.spider298
-rw-r--r--web/reduce/rweb/rtangle10
-rw-r--r--web/reduce/rweb/rtangle.ch135
-rw-r--r--web/reduce/rweb/rweave.ch209
-rw-r--r--web/reduce/rweb/texinputs/specification.tex10
-rw-r--r--web/reduce/rweb/underscore.web32
24 files changed, 14458 insertions, 0 deletions
diff --git a/web/reduce/rweb/Makefile b/web/reduce/rweb/Makefile
new file mode 100644
index 0000000000..fb2f271003
--- /dev/null
+++ b/web/reduce/rweb/Makefile
@@ -0,0 +1,144 @@
+# Copyright 1989 by Norman Ramsey, Odyssey Research Associates.
+# To be used for research purposes only.
+# For more information, see file COPYRIGHT in the parent directory.
+
+HOME=/users/redusers# # Make no longer inherits environment vars
+
+THETANGLE=tangle
+THEWEAVE=weave
+SPIDER=any.spider
+#
+DVI=dvi
+CFLAGS=-DDEBUG -g -DSTAT
+
+# CPUTYPE is a grim hack that attempts to solve the problem of multiple
+# cpus sharing a file system. In my environment I have to have different
+# copies of object and executable for vax, sun3, next, iris, and other
+# cpu types. If you will be using Spidery WEB in a homogenous processor
+# environment, you can just set CPUTYPE to a constant, or eliminate it
+# entirely.
+#
+# In my environment, the 'cputype' program returns a string that
+# describes the current processor. That means that the easiest thing
+# for you to do is to define a 'cputype' program that does something
+# sensible. A shell script that says 'echo "vax"' is fine.
+
+CPUTYPE=`cputype`
+
+# Change the following three directories to match your installation
+#
+# the odd placement of # is to prevent any trailing spaces from slipping in
+
+WEBROOT=$(HOME)/spider# # root of the WEB source distribution
+DEST=$(HOME)/bin# # place where the executables go
+MACROS=$(HOME)/tex/inputs# # place where the macros go
+
+MASTER=$(WEBROOT)/master# # master source directory
+OBDIR=$(MASTER)/$(CPUTYPE)# #common object files
+
+TANGLESRC=tangle
+CTANGLE=ceetangle -I$(MASTER)
+CWEAVE=ceeweave -I$(MASTER)
+AWKTANGLE=awktangle -I$(MASTER)
+COMMONOBJS=$(OBDIR)/common.o $(OBDIR)/pathopen.o
+COMMONC=$(MASTER)/common.c $(MASTER)/pathopen.c
+COMMONSRC=$(COMMONC) $(MASTER)/spider.awk
+
+
+# Our purpose is to make tangle and weave
+
+web: tangle weave
+
+tangle: mktangle
+
+mktangle: $(COMMONOBJS) $(TANGLESRC).o
+ $(CC) $(CFLAGS) -o $(DEST)/$(THETANGLE) $(COMMONOBJS) $(TANGLESRC).o
+
+weave: $(COMMONOBJS) weave.o
+ $(CC) $(CFLAGS) -o $(DEST)/$(THEWEAVE) $(COMMONOBJS) weave.o
+
+source: $(TANGLESRC).c $(COMMONSRC) # make tangle.c and common src, then clean
+ if [ -f WebMakefile ]; then exit 1; fi # don't clean the master!
+ if [ -f spiderman.tex ]; then exit 1; fi # don't clean the manual
+ -rm -f tangle.web weave.* common.* # remove links that may be obsolete
+ -rm -f *.unsorted *.list grammar.web outtoks.web scraps.web
+ -rm -f cycle.test spider.slog
+ -rm -f *.o *.tex *.toc *.dvi *.log *.makelog *~ *.wlog *.printlog
+
+# Here is how we make the common stuff
+
+$(MASTER)/common.c: $(MASTER)/common.web # no change file
+ $(CTANGLE) $(MASTER)/common
+
+$(OBDIR)/common.o: $(MASTER)/common.c
+ $(CC) $(CFLAGS) -c $(MASTER)/common.c
+ mv common.o $(OBDIR)
+
+$(MASTER)/pathopen.c: $(MASTER)/pathopen.web # no change file
+ $(CTANGLE) $(MASTER)/pathopen
+ mv pathopen.h $(MASTER)
+
+$(OBDIR)/pathopen.o: $(MASTER)/pathopen.c
+ $(CC) $(CFLAGS) -c $(MASTER)/pathopen.c
+ mv pathopen.o $(OBDIR)
+
+$(OBDIR):
+ if /bin/test ! -d $(OBDIR) ; then mkdir $(OBDIR) ; fi
+
+## Now we make the tangle and weave source locally
+
+$(TANGLESRC).c: $(MASTER)/$(TANGLESRC).web $(MASTER)/common.h grammar.web rtangle.ch
+ -/bin/rm -f $(TANGLESRC).web
+ ln $(MASTER)/$(TANGLESRC).web $(TANGLESRC).web
+# chmod -w $(TANGLESRC).web
+ $(CTANGLE) $(TANGLESRC) rtangle.ch
+
+weave.c: $(MASTER)/weave.web $(MASTER)/common.h grammar.web rweave.ch
+ -/bin/rm -f weave.web
+ ln $(MASTER)/weave.web weave.web
+# chmod -w weave.web
+ $(CTANGLE) weave rweave.ch
+
+## Here's where we run SPIDER to create the source
+
+grammar.web: $(MASTER)/cycle.awk $(MASTER)/spider.awk $(SPIDER)
+ echo "date" `date` | cat - $(SPIDER) | awk -f $(MASTER)/spider.awk
+ cat $(MASTER)/transcheck.list trans_keys.unsorted | awk -f $(MASTER)/transcheck.awk
+ awk -f $(MASTER)/cycle.awk < cycle.test
+ sort *.unsorted | awk -f $(MASTER)/nodups.awk
+ mv *web.tex $(MACROS)
+
+## We might have to make spider first.
+
+$(MASTER)/spider.awk: $(MASTER)/spider.web
+ $(AWKTANGLE) $(MASTER)/spider
+ mv cycle.awk nodups.awk transcheck.awk $(MASTER)
+ rm junk.list
+
+
+# $(MASTER)/cycle.awk: $(MASTER)/cycle.web # making spider also makes cycle
+# $(AWKTANGLE) $(MASTER)/cycle
+
+
+# This cleanup applies to every language
+
+clean:
+ if [ -f WebMakefile ]; then exit 1; fi # don't clean the master!
+ if [ -f spiderman.tex ]; then exit 1; fi # don't clean the manual
+ -rm -f tangle.* weave.* common.* # remove links that may be obsolete
+ -rm -f *.unsorted *.list grammar.web outtoks.web scraps.web
+ -rm -f cycle.test spider.slog
+ -rm -f *.c *.o *.tex *.toc *.dvi *.log *.makelog *~ *.wlog *.printlog
+
+
+
+# booting the new distribution
+boot:
+ cd ../master; rm -f *.o; for i in $(COMMONC); do \
+ $(CC) $(CFLAGS) -c $$i; \
+ mv *.o $(OBDIR) ; \
+ done; cd ../c
+ $(CC) $(CFLAGS) -c $(TANGLESRC).c; \
+ $(CC) $(CFLAGS) -o $(DEST)/$(THETANGLE) $(COMMONOBJS) $(TANGLESRC).o
+
+
diff --git a/web/reduce/rweb/Makefile3.3 b/web/reduce/rweb/Makefile3.3
new file mode 100644
index 0000000000..0ed80e2775
--- /dev/null
+++ b/web/reduce/rweb/Makefile3.3
@@ -0,0 +1,152 @@
+# Copyright 1989 by Norman Ramsey, Odyssey Research Associates.
+# To be used for research purposes only.
+# For more information, see file COPYRIGHT in the parent directory.
+
+HOME=/users/redusers# # Make no longer inherits environment vars
+
+THETANGLE=tangle
+THEWEAVE=weave
+SPIDER=any.spider
+#
+DVI=dvi
+CFLAGS=-DDEBUG -g -DSTAT
+
+# CPUTYPE is a grim hack that attempts to solve the problem of multiple
+# cpus sharing a file system. In my environment I have to have different
+# copies of object and executable for vax, sun3, next, iris, and other
+# cpu types. If you will be using Spidery WEB in a homogenous processor
+# environment, you can just set CPUTYPE to a constant, or eliminate it
+# entirely.
+#
+# In my environment, the 'cputype' program returns a string that
+# describes the current processor. That means that the easiest thing
+# for you to do is to define a 'cputype' program that does something
+# sensible. A shell script that says 'echo "vax"' is fine.
+
+CPUTYPE=`cputype`
+
+# Change the following three directories to match your installation
+#
+# the odd placement of # is to prevent any trailing spaces from slipping in
+
+WEBROOT=$(HOME)/spider# # root of the WEB source distribution
+DEST=$(HOME)/bin# # place where the executables go
+MACROS=$(HOME)/tex/inputs# # place where the macros go
+
+MASTER=$(WEBROOT)/master# # master source directory
+OBDIR=$(MASTER)/$(CPUTYPE)# #common object files
+
+TANGLESRC=tangle
+CTANGLE=ceetangle -I$(MASTER)
+CWEAVE=ceeweave -I$(MASTER)
+AWKTANGLE=awktangle -I$(MASTER)
+COMMONOBJS=$(OBDIR)/common.o $(OBDIR)/pathopen.o
+COMMONC=$(MASTER)/common.c $(MASTER)/pathopen.c
+COMMONSRC=$(COMMONC) $(MASTER)/spider.awk
+
+
+# Our purpose is to make tangle and weave
+
+web: tangle weave
+
+tangle: mktangle underscore
+
+mktangle: $(COMMONOBJS) $(TANGLESRC).o
+ $(CC) $(CFLAGS) -o $(DEST)/$(THETANGLE) $(COMMONOBJS) $(TANGLESRC).o
+
+weave: $(COMMONOBJS) weave.o
+ $(CC) $(CFLAGS) -o $(DEST)/$(THEWEAVE) $(COMMONOBJS) weave.o
+
+underscore: $(DEST)/underscore underscore.web
+
+$(DEST)/underscore:
+ $(CTANGLE) underscore.web
+ $(CC) $(CFLAGS) -o $(DEST)/underscore underscore.c
+ cp rtangle $(DEST)/rtangle3.3
+
+source: $(TANGLESRC).c $(COMMONSRC) # make tangle.c and common src, then clean
+ if [ -f WebMakefile ]; then exit 1; fi # don't clean the master!
+ if [ -f spiderman.tex ]; then exit 1; fi # don't clean the manual
+ -rm -f tangle.web weave.* common.* # remove links that may be obsolete
+ -rm -f *.unsorted *.list grammar.web outtoks.web scraps.web
+ -rm -f cycle.test spider.slog
+ -rm -f *.o *.tex *.toc *.dvi *.log *.makelog *~ *.wlog *.printlog
+
+# Here is how we make the common stuff
+
+$(MASTER)/common.c: $(MASTER)/common.web # no change file
+ $(CTANGLE) $(MASTER)/common
+
+$(OBDIR)/common.o: $(MASTER)/common.c
+ $(CC) $(CFLAGS) -c $(MASTER)/common.c
+ mv common.o $(OBDIR)
+
+
+$(MASTER)/pathopen.c: $(MASTER)/pathopen.web # no change file
+ $(CTANGLE) $(MASTER)/pathopen
+ mv pathopen.h $(MASTER)
+
+$(OBDIR)/pathopen.o: $(MASTER)/pathopen.c
+ $(CC) $(CFLAGS) -c $(MASTER)/pathopen.c
+ mv pathopen.o $(OBDIR)
+
+$(OBDIR):
+ if /bin/test ! -d $(OBDIR) ; then mkdir $(OBDIR) ; fi
+
+## Now we make the tangle and weave source locally
+
+$(TANGLESRC).c: $(MASTER)/$(TANGLESRC).web $(MASTER)/common.h grammar.web rtangle.ch
+ -/bin/rm -f $(TANGLESRC).web
+ ln $(MASTER)/$(TANGLESRC).web $(TANGLESRC).web
+# chmod -w $(TANGLESRC).web
+ $(CTANGLE) $(TANGLESRC) rtangle.ch
+
+weave.c: $(MASTER)/weave.web $(MASTER)/common.h grammar.web rweave.ch
+ -/bin/rm -f weave.web
+ ln $(MASTER)/weave.web weave.web
+# chmod -w weave.web
+ $(CTANGLE) weave rweave.ch
+
+## Here's where we run SPIDER to create the source
+
+grammar.web: $(MASTER)/cycle.awk $(MASTER)/spider.awk $(SPIDER)
+ echo "date" `date` | cat - $(SPIDER) | awk -f $(MASTER)/spider.awk
+ cat $(MASTER)/transcheck.list trans_keys.unsorted | awk -f $(MASTER)/transcheck.awk
+ awk -f $(MASTER)/cycle.awk < cycle.test
+ sort *.unsorted | awk -f $(MASTER)/nodups.awk
+ mv *web.tex $(MACROS)
+
+## We might have to make spider first.
+
+$(MASTER)/spider.awk: $(MASTER)/spider.web
+ $(AWKTANGLE) $(MASTER)/spider
+ mv cycle.awk nodups.awk transcheck.awk $(MASTER)
+ rm junk.list
+
+
+# $(MASTER)/cycle.awk: $(MASTER)/cycle.web # making spider also makes cycle
+# $(AWKTANGLE) $(MASTER)/cycle
+
+
+# This cleanup applies to every language
+
+clean:
+ if [ -f WebMakefile ]; then exit 1; fi # don't clean the master!
+ if [ -f spiderman.tex ]; then exit 1; fi # don't clean the manual
+ -rm -f tangle.* weave.* common.* # remove links that may be obsolete
+ -rm -f *.unsorted *.list grammar.web outtoks.web scraps.web
+ -rm -f cycle.test spider.slog
+ -rm -f *.c *.o *.tex *.toc *.dvi *.log *.makelog *~ *.wlog *.printlog
+
+
+
+# booting the new distribution
+boot:
+ cd ../master; rm -f *.o; for i in $(COMMONC); do \
+ $(CC) $(CFLAGS) -c $$i; \
+ mv *.o $(OBDIR) ; \
+ done; cd ../c
+ $(CC) $(CFLAGS) -c $(TANGLESRC).c; \
+ $(CC) $(CFLAGS) -o $(DEST)/$(THETANGLE) $(COMMONOBJS) $(TANGLESRC).o
+
+
diff --git a/web/reduce/rweb/README b/web/reduce/rweb/README
new file mode 100644
index 0000000000..5e4c2c321b
--- /dev/null
+++ b/web/reduce/rweb/README
@@ -0,0 +1,35 @@
+This directory contains all the necessary stuff for making RWEB, the
+REDUCE version of WEB.
+
+Currently I maintain two versions, one for the old REDUCE version 3.3
+and one for the new version 3.4. It should be noted, however, that I only
+make improvements on the new 3.4 version. The main difference until
+now in both versions, is the removing of underscores in the 3.3 version.
+
+Along with these files you need a version of SPIDERY WEB, which can be
+obtained by anonymous ftp from princeton.edu (128.112.128.1).
+
+After you have installed SPIDERY WEB you know what it means to put the
+files contained in this directory into a new directory $(WEBROOT)/reduce.
+Do it. You might as well want to change the variable HOME in
+$(WEBROOT)/reduce/Makefile (which is in fact an adapted version of
+$(MASTER)/WebMakefile).
+
+In order to make RWEB, go to $(WEBROOT)/reduce and type 'make weave',
+'make tangle' or 'make web', if you want to make rweave, rtangle or
+both. The documentation needed for using RWEB is
+$(WEBROOT)/doc/spiderwebman.tex.
+
+Have fun,
+
+Old address:
+
+Marcel Roelofs,
+University of Twente,
+Department of applied mathematics,
+P.O. Box 217,
+7500 AE Enschede,
+The Netherlands.
+E-mail: roelofs@math.utwente.nl
+
+New (941105) roelofs@cwi.nl
diff --git a/web/reduce/rweb/appl/integrator.web b/web/reduce/rweb/appl/integrator.web
new file mode 100644
index 0000000000..abdfb6a1d2
--- /dev/null
+++ b/web/reduce/rweb/appl/integrator.web
@@ -0,0 +1,1230 @@
+% Copyright (c) 1991 Marcel Roelofs, University of Twente, Enschede,
+% The Netherlands.
+%
+% $Header: integrator.web,v 0.92 91/12/18 17:39:37 roelofs Exp $
+%
+\input specification
+\def\Version$#1Revision: #2 ${Version #2}
+\def\title{INTEGRATOR}
+\font\titlefont=cmcsc10 scaled\magstep3
+\font\ttitlefont=cmtt10 scaled\magstep4
+\def\topofcontents{\null\vfill
+\centerline{\titlefont The {\ttitlefont INTEGRATOR} package for REDUCE}
+\vskip15pt\centerline{\Version$Revision: 0.92 $}
+\vskip15pt\centerline{\sc Marcel Roelofs}\vfill}
+\def\enditem{\medskip\noindent\ignorespaces}
+\def\pde{p.d.e.}
+
+@*=Introduction. In this \.{WEB} file we shall describe a REDUCE package for
+the integration of overdetermined systems of partial differential
+equations (p.d.e.'s). This work is mainly based on a similar package by Paul
+Kersten for just the determination of symmetry groups and an extension
+by myself which also allows the determination of Wahlquist and
+Estabrook prolongation algebras.
+
+The main reasons for the implementation of this package, are our
+improved insight in the internals of REDUCE, the wish to have one
+combined integrator for both cases and the availability of substantially
+improved versions of some the procedures used in the former packages.
+
+\medskip
+
+The ``banner line'' defined here is intended for indentification
+purposes on loading. It should be changed whenever this file is
+modified. System dependent changes, however, should be made in a
+separate change file.
+
+@d banner="Integrator package for REDUCE 3.4, $Revision: 0.92 $"
+
+@ We define the following macros for clarity.
+@d change_to_symbolic_mode =symbolic
+@d change_to_algebraic_mode =algebraic
+@d stop_with_error(string_1,expr_1,string_2,expr_2) = @/
+ msgpri(string_1,expr_1,string_2,expr_2,t) @;
+@d message(string_1,expr_1,string_2,expr_2) = @/
+ msgpri(string_1,expr_1,string_2,expr_2,nil) @;
+@d operator_name_of=car
+@d arguments_of=cdr
+@d first_argument_of=cadr
+@d second_argument_of=caddr
+@d first_element_of=car
+@d rest_of=cdr
+@d skip_list=cdr %Skip the |'list| in front of an algebraic list%
+@f function = identifier
+
+@ The following macros are intended as common programming idioms.
+@d incr(x) = (x:=x+1)@;
+@d decr(x) = (x:=x-1)@;
+
+@ A new REDUCE switch can be introduced using the following code.
+
+@d initialize_global(global_name,value)=@/
+global '(global_name)$@/
+global_name:=value
+@d initialize_fluid(fluid_name,value)=@/
+fluid '(fluid_name)$@/
+fluid_name:=value
+@d new_switch(switch_name,value)=@/
+initialize_fluid(!* @& switch_name,value)$@/
+flag('(switch_name),'switch)
+
+@ We do all initializations in the beginning of the package.
+@u
+change_to_symbolic_mode$@/
+write banner$terpri()$@/
+@<Lisp initializations@>@/
+change_to_algebraic_mode$
+
+@*=Integration of overdetermined systems of \pde's.
+For the determination of symmetry groups or prolongation structures of
+(systems of) partial differential equations, the defining relations
+give rise to an overdetermined system of \pde's. Finding the symmetry
+group or prolongation structure boils down to solving such a system.
+
+There are, however, some differences between the determination of a
+symmetry group or the determination of a prolongation structure. These
+differences are:\medskip
+
+\item{1.} The differential equations for the determination of the
+symmetry group are linear, the equations for the determination of a
+prolongation structure are nonlinear. This nonlinearity, however, is
+of a special kind, namely, the only occuring nonlinear terms are
+(possibly nested) liebrackets of the functions to be integrated.
+
+\item{2.} For the determination of symmetry groups, the functions to be
+determined integrate to polynomials with constant coefficients. For
+the determination of prolongation structures, functions integrate to
+polynomials, coefficients of which are generators of some unknown Lie
+algebra. The defining relations of this algebra are the remaining
+(nonlinear) relations which have no dependency on the independent
+variables involved.
+
+\enditem
+From the above it is clear that integration has to be treated slightly
+different in either of the cases. The differences are however small
+enough to allow the implementation of one integrator for both cases.
+
+@ In order to explain all possible p.d.e.'s which can be integrated, we make
+the following assumptions:\medskip
+
+\item{1.} Functions are represented by expressions $f(n)$, where $f$ is
+some specified operator and $n$ is an integer. Since we intend to use
+the package for computations for supersymmetric p.d.e.'s, we shall use
+the notion the elements with $n$ positive must integrate to an even
+polynomial and elements with negative $n$ must integrate to an odd
+polynomial (this is only useful for computations in prolongation
+theory, where coefficients can be even or odd Lie algebra generators).
+
+\item{2.} The dependencies of functions are solely listed on the
+dependency list, i.e.\ must be stated by the 'depend' statement of REDUCE.
+Notice, however, that we do not allow dependencies of odd variables.
+The reason for this is a pragmatic one: due to the anticommutivity of
+odd variables, $n$ odd variables can only produce $2^n$ different
+terms containing these variables, hence can be stated explicitly
+provided that $n$ is not too big. On the other hand, if we allow
+dependencies of odd variables, a lot of additional operators have to
+be implemented to take care of e.g. partial differentation w.r.t. odd
+variables.
+\medskip
+
+@ If $f$ is the operator denoting functions, $x$ the operator denoting
+Lie algebra generators (or, in the case of a symmetry group, just
+constants), then following the description above, a p.d.e.\
+has the following possible terms (any coefficient $c$ is always some polynomial
+in the independent variables):\medskip
+
+\item{A.} terms of the form $c_n \hbox{df}(f(n),\dots)$.
+
+\item{B.} terms of the form $c_n f(n)$.
+
+\item{C.} terms of the form $c_{1,2}[z_1,z_2]$ where $z_1,z_2$ are
+either functions $f(n)$ or Lie algebra generators $x(n)$.
+
+\item{D.} terms of the form $c_n x(n)$.
+\medskip
+
+These possibilities lead, in a natural way, to the following strategy
+of solving the p.d.e.'s:\medskip
+
+\item{1.} If there is only one term of type A, we can integrate this
+equation homogeneously, i.e. give a polynomial expression for $f(n)$
+using the variables involved in the differential term.
+
+\item{2.} If the p.d.e.\ is a polynomial in one or more independent
+variables on which none of the occuring functions depend, all
+coefficients of this polynomial have to be zero, i.e., the p.d.e.\
+splits up into a set of smaller p.d.e.'s.
+
+\item{3.} If there are only terms of type C and D we have a Lie
+algebra relation, which can be solved by the LIESUPER package, if
+solvable.
+
+\item{4.} If there is a function of type B depending on all variables
+occuring in the p.d.e.\ and not occuring in a term of type A, we can
+solve for this function.
+
+\item{5.} If there is one term of type A depending on all variables
+occuring the p.d.e.\ and the remaining terms are polynomial in the
+variables occuring in the derivative, the p.d.e.\ can be integrated
+inhomogeneously.
+
+\item{6.} If there is just one function in the p.d.e.\ which depends on a
+variable only occuring polynomially in the rest of the p.d.e., such
+that the p.d.e.\ can not be integrated inhomogeneously since the
+dependencies of the various occuring functions do not match, we can
+introduce new equations of type 1 by appropriately differentiating the
+p.d.e.
+
+@*1 Initializing an equation set.
+The integrator will be implemented in such a way that integration
+can be performed on different sets of p.d.e.'s at the same time.
+Different sets of p.d.e.'s will be distinguished by the name of the
+operator in which they are stored.
+
+For each operator representing a set of p.d.e.'s we must know: the
+name of the operator(s) representing the functions and the operator
+that must be used to represent constants coefficients during the
+integration. If this last operator is of rtype 'algebra\_generator' we
+know that we are in the prolongation case and the name of the
+associated liebracket can be found on the property list of this
+operator.
+
+Moreover, we have to know the total number of equations used, in view of
+the additional equations that may be generated and which must be
+numbered subsequently.
+In connection with the integrations taking place we also have to know the
+number of functions, resp. constants (generators) being in use.
+
+This is all taken care of by the procedure |initialize_equations|,
+which assigns to an operator |operator_name|, the total number of used
+equations |total_used|, the list |variable_list| of all occuring independent
+variables, the operator |constant_operator|, elements of
+which act as constants, and an arbitrary number of operators
+|function_operator| acting as functions.
+|constant_operator| and each |function_operator| should be given a an
+algebraic list of the form $\{$operator, number of even elements used,
+number of odd elements used$\}$.
+
+In order to allow an arbitrary number of parameters we make
+|initialize_equations| a |psopfn|. How |psopfn|'s are dealt with
+internally is explained in the documentation of either the TOOLS
+package or the LIESUPER package.
+
+@<Lisp ini...@>=@/
+put('initialize_equations,'psopfn,'initialize_equations1)$
+
+@
+@u
+lisp procedure initialize_equations1 specification_list;
+begin scalar operator_name,total_used,variable_list,
+ specification,even_used,odd_used,
+ constant_operator,bracketname,function_name,function_list;
+ if length specification_list<5 then
+ rederr("INITIALIZE_EQUATIONS: wrong number of parameters");
+ if not idp(operator_name:=first_element_of specification_list) then
+ rederr("INITIALIZE_EQUATIONS: equations operator must be identifier");
+ if not fixp(total_used:=
+ reval first_element_of(specification_list:=rest_of specification_list))
+ or total_used<0 then
+ rederr("INITIALIZE_EQUATIONS: total number of equations must be positive");
+ put(operator_name,'total_used,total_used);
+ variable_list:=reval first_element_of(
+ specification_list:=rest_of specification_list);
+ if atom variable_list or operator_name_of variable_list neq 'list then
+ rederr("INITIALIZE_EQUATIONS: variable list must be algebraic list");
+ put(operator_name,'variable_list,skip_list variable_list);
+ @<Check and initialize |constant_operator|@>;
+ @<Check and initialize |function_list|@>;
+end$
+
+@ The |constant_operator| can either be of rtype |algebra_generator|
+or not. If so, we also have to assign the associated liebracket to
+|operator_name| and used the procedure |define_used| to take care of
+the assignment of the used dimensions to the liebracket. If
+|constant_operator| is not an |algebra_generator|, we store these
+dimensions in the same way as happens for liebrackets.
+
+@d check_valid_function_declaration(op_list,op_name)=@/
+if atom op_list or length op_list neq 4 or operator_name_of op_list neq 'list@|
+ or not idp(op_name:=first_argument_of op_list) or
+ not fixp(even_used:=reval caddr op_list) @| or
+ not fixp(odd_used:=reval cadddr op_list)
+ or even_used<0 or odd_used<0 then @/
+ stop_with_error("INITIALIZE_EQUATIONS: invalid declaration of",
+ op_list,nil,nil)
+
+@d put_used_dimensions(op_name,even_used,odd_used)=@/
+ if get(op_name,'rtype)='algebra_generator then@/
+ define_used(bracketname,list('list,even_used,odd_used))
+ else
+ begin
+ put(op_name,'even_used,even_used);@/
+ put(op_name,'odd_used,odd_used);
+ end
+
+@<Check and initialize |constan...@>=@/
+specification_list:=rest_of specification_list;
+specification:=first_element_of specification_list;
+check_valid_function_declaration(specification,constant_operator);
+put(operator_name,'constant_operator,constant_operator);
+if get(constant_operator,'rtype)='algebra_generator then@/
+ put(operator_name,'bracketname,
+ bracketname:=get(constant_operator,'bracketname));
+put_used_dimensions(constant_operator,even_used,odd_used)
+
+@
+@<Check and initialize |fu...@>=@/
+for each function_specification in rest_of specification_list do
+begin
+ check_valid_function_declaration(function_specification,function_name);
+ put_used_dimensions(function_name,even_used,odd_used);
+ function_list:=function_name . function_list;
+end;
+put(operator_name,'function_list,function_list)
+
+@ Since we can apparently choose different sets of p.d.e.'s for
+solving, we must tell the integrator which set to take. This is done
+via a global variable |current_equation_set!*|. We will take the
+operator |equ| as the default |current_equation_set!*|.
+In this file we will use the abbreviation |ces!*| for
+|current_equation_set!*|.
+
+@d ces!*=current_equation_set!*
+
+@<Lisp ini...@>=@/
+initialize_global(ces!*,'equ)$
+
+@
+@u
+lisp operator use_equations;@/
+lisp procedure use_equations operator_name;
+begin
+ if idp operator_name then
+ ces!*:=operator_name
+ else rederr("USE_EQUATIONS: argument must be identifier");
+end$
+
+@*1 The integration procedure.
+The implementation of the integrator follows the description of all
+the possible steps given above.
+
+\noindent For the use of the fluid variable |listpri_depth!*|, see below. Its
+local rebinding is necessary for a proper printing of the messages
+given by the procedure.
+
+@u
+lisp operator integrate_equation;
+lisp procedure integrate_equation n;
+begin scalar listpri_depth!*,total_used,equation,denominator,
+ solvable_kernel,solvable_kernels,df_list,df_kernel,
+ function_list,present_functions_list,variable_list,absent_variables,
+ polynomial_variables,equations_list,linear_functions_list,constants_list,
+ bracketname,df_terms,df_functions,@|
+ linear_functions,functions_and_constants_list,commutator_functions,
+ present_variables,@|
+ inhomogeneous_term,nr_of_variables,integration_variables,
+ forbidden_functions,differentiations_list,polynomial_order;
+ listpri_depth!*:=200;
+ terpri!* t;
+ @<Find the equation to be integrated@>;
+ @<Step 1: search for homogeneous integration@>;
+ @<Step 2: search for polynomial behaviour@>;
+ @<Step 3: search for a Lie relation@>;
+ @<Step 4: search for a solvable function@>;
+ @<Step 5: search for inhomogeneous integration@>;
+ @<Step 6: search for a useful differentation@>;
+ @<Step 7: print a ``Not solved'' message@>;
+solved: %Go here when the equation is solved or its type is determined%
+end$
+
+@ The part of the equation containing all necessary information is its
+numerator. For reasons that will become clear in the sequel we need,
+however, also know its denominator. If the equation is zero, no
+analysis has to be performed.
+
+@d nullify_equation(n)=@/
+ setk(list(ces!*,n),0)
+
+@<Find the equation...@>=
+ if null(total_used:=get(ces!*,'total_used)) or
+ n>total_used then
+ stop_with_error("INTEGRATE_EQUATIONS: properly initialize",
+ ces!*,nil,nil);
+ if null (equation:=cadr assoc(list(ces!*,n),
+ get(ces!*,'kvalue))) then
+ stop_with_error("INTEGRATE_EQUATION:", list(ces!*,n),
+ "is non-existent",nil);
+ denominator:=denr(equation:=simp!* equation);
+ equation:=numr equation;
+ if null equation then
+ <<write ces!*,"(",n,") = 0"; terpri!* t;
+ nullify_equation(n); goto solved>>
+
+@*1 Homogeneous integration.
+Homogeneous integration must be performed if the equation consists
+of just one |df| term. In order to find all possible |df| terms we
+apply |split_form| to |equation|. This returns a list the |car| of
+which is the part of |equation| independent of the |df| operator, the
+|cdr| of which is a list of all linear |df| terms, together with their
+coefficients. |split_form| will return with an error if nonlinear |df|
+terms occur.
+
+@d independent_part_of=car
+@d kc_list_of=cdr
+@d kernel_of=car %For use with a kernel-coefficient list%
+@d coefficient_of=cdr %For use with a kernel-coefficient list%
+
+@ If there is one |df| term, we only solve it if its coefficient is a
+number, by default. This behaviour is governed by the switch
+|coefficient_check|, which is |on| by default. In order to check the coefficient
+we will use the procedure |find_solvable_kernel| to be explained below.
+
+@<Lisp ini...@>=
+new_switch(coefficient_check,t)$
+
+@
+@d assoc_delete(kernel,assoc_list)=@/
+ delete(assoc(kernel,assoc_list),assoc_list)
+@d successful_message_for(action,kernel)=@/
+<<write ces!*,"(",n,"): ",action; maprin kernel; terpri!* nil;@/
+ nullify_equation(n); goto solved>>
+@d not_a_number_message_for(action,kernel)=@/
+<<write "*** ",ces!*,"(",n,"): ",action," failed:"; terpri!* t;@/
+ write " coefficient not a number for ";
+ maprin kernel; terpri!* nil;@/
+ write " Solvable with 'off coefficient_check'";@/
+ terpri!* t; goto solved>>
+
+@<Step 1...@>=@/
+ df_list:=split_form(equation,'(df));
+ if null independent_part_of df_list and
+ (kc_list_of df_list) and length(kc_list_of df_list)=1
+ then
+ if (solvable_kernel:=find_solvable_kernel(@|
+ solvable_kernels:=list(kernel_of first_element_of kc_list_of df_list),@|
+ kc_list_of df_list,denominator)) then
+ <<df_kernel:=first_argument_of solvable_kernel;@/
+ setk(df_kernel,homogeneous_integration_of(solvable_kernel));@/
+ depl!*:=assoc_delete(df_kernel,depl!*);
+ %Remove |df_kernel| from the |depl!*| list%
+ successful_message_for("Homogeneous integration of ",solvable_kernel)>>
+ else not_a_number_message_for("Homogeneous integration",
+ first_element_of solvable_kernels)
+
+@ The procedure |find_solvable_kernel| tries to find the first element
+of |kernel_list| which has a number as coefficient.
+If |coefficient_check| is |off| we can simply take the first element
+of |kernel_list|, otherwise we can most conveniently implement a
+recursive procedure |first_solvable_kernel|, which finds the first
+element of |kernel_list| with a number as coefficient.
+
+@u
+lisp procedure find_solvable_kernel(kernel_list,kc_list,denominator);
+if !*coefficient_check then first_solvable_kernel(kernel_list,kc_list,denominator)
+else first_element_of kernel_list$
+
+@#
+lisp procedure first_solvable_kernel(kernel_list,kc_list,denominator);
+if kernel_list then @/
+ (if numberp coefficient_of kc_pair or
+ numberp !*ff2a(coefficient_of kc_pair,denominator)
+ then @/ kernel_of kc_pair
+ else first_solvable_kernel(rest_of kernel_list,kc_list,denominator))
+ where kc_pair=assoc(first_element_of kernel_list,kc_list)$
+
+@ The equation
+\def\dd#1#2{{\partial^{#2}\over\partial{#1}^{#2}}}
+$$
+\dd{x_1}{k_1}\cdots\dd{x_m}{k_m} f(x_1,\dots,x_n)=0\qquad (m\leq n)
+$$
+has general solution
+$$
+f=\sum_{j=1}^{m}\sum_{i_j=0}^{k_j-1}
+x_j^{i_j}f_{j,i_j}(x_1,\dots,\hat{x_j},\dots,x_n).
+$$
+Thus, given a homogenous p.d.e., |homogeneous_integration_of| has to
+return the REDUCE equivalent of the last expression.
+
+If $f$ depends on only one variable the $f_{j,i_j}$ are constants,
+otherwise they are new functions with dependency on one less variable.
+In the Lie algebra case the constants are generators of the Lie
+algebra. Since the dimensions of a |liebracket| in REDUCE have to be
+given on beforehand, there may not be enough generators left to
+generate $f$. In this case, we have to enlarge the |liebracket|.
+
+@d get_dependencies_of(kernel)=@/
+ ((if depl_entry then cdr depl_entry)@| where depl_entry=assoc(kernel,depl!*))
+
+@u
+lisp procedure homogeneous_integration_of df_term;
+begin scalar df_function,function_number,dependency_list,integration_list,
+ coefficient_name,bracketname,even_used,odd_used,
+ integration_variable,@|
+ number_of_integrations,solution,new_dependency_list;
+@<Check if |df_term| can be integrated, find |df_function| and
+|function_number|@>;
+dependency_list:=get_dependencies_of(df_function);
+if length dependency_list=1 then
+ coefficient_name:=get(ces!*,'constant_operator)
+ else coefficient_name:=operator_name_of df_function;
+@<Get |even_used|, |odd_used| and if necessary |bracketname|@>;
+integration_list:=rest_of arguments_of df_term;
+@<Find the next |integration_variable| and |number_of_integrations|@>;
+if bracketname then
+ @<Check and possibly enlarge dimensions of |bracketname|@>;
+@<Perform the integration@>;
+return solution
+end$
+
+@ We required |df_term| to be of the form |df|($f(k),\dots$) where
+$f$ is a function occuring on the |function_list| of |ces!*| and $k$
+is an integer not equal to zero.
+
+@<Check if |df_term|...@>=@/
+df_function:=first_argument_of df_term;
+if not member(operator_name_of df_function,get(ces!*,'function_list)) @|
+or not fixp(function_number:=first_argument_of df_function) or function_number=0 then
+@/stop_with_error("PERFORM_HOMOGENEOUS_INTEGRATION: integration of",
+ df_function, "not allowed",nil)
+
+@ In the liebracket case |even_used| and |odd_used| are stored as
+properties of |bracketname| instead of |coefficient_name|.
+
+@<Get |even_used|, |odd...@>=
+ if get(coefficient_name,'rtype)='algebra_generator then
+ begin bracketname:=get(ces!*,'bracketname);@/
+ even_used:=get(bracketname,'even_used);
+ odd_used:=get(bracketname,'odd_used);
+ end
+ else
+ begin
+ even_used:=get(coefficient_name,'even_used);@/
+ odd_used:=get(coefficient_name,'odd_used);
+ end
+
+@ Finding the integration variables is rather straightforward.
+
+@<Find the next |int...@>=
+if integration_list then integration_variable:=first_element_of
+integration_list else integration_variable:=nil;
+if integration_variable and (integration_list:=rest_of integration_list) @|
+ and fixp first_element_of integration_list then
+ <<number_of_integrations:=first_element_of integration_list;
+ integration_list:=rest_of integration_list>>
+else number_of_integrations:=1
+
+@ If |df_function| depends on only one variable, the number of
+constants being introduced is equal to the |number_of_integrations|.
+The even and odd dimension of |bracketname| are stored as the
+properties |even_dimension| and |odd_dimension|.
+
+@<Check and poss...@>=
+if function_number > 0 then @/
+ (if even_used+number_of_integrations>get(bracketname,'even_dimension) then@/
+ change_dimensions_of(bracketname,even_used+number_of_integrations,@|
+ get(bracketname,'odd_dimension)))
+else @/
+ (if odd_used+number_of_integrations>get(bracketname,'odd_dimension) then@/
+ change_dimensions_of(bracketname,get(bracketname,'even_dimension),
+ odd_used+number_of_integrations))
+
+@ The actual integration is fairly straightforward by now: for all the
+possible integration variables we can simply add new terms to
+|solution|.
+
+@d new_coefficient=@/
+list(coefficient_name,if function_number>0 then
+ incr(even_used) else -incr(odd_used))
+@d ext_mksq(kernel,power)=@/
+if power=0 then 1 ./ 1 else mksq(kernel,power)
+@d depend_new_coefficient(dependency_list)=@/
+ depl!*:= (list(coefficient_name,if function_number>0 then even_used
+else -odd_used) . dependency_list) . depl!*;
+
+@<Perform the integration@>=@/
+solution:=nil ./ 1;
+while integration_variable do
+begin new_dependency_list:=delete(integration_variable,dependency_list);
+ for i:=0:number_of_integrations-1 do
+ <<solution:=addsq(solution,multsq(ext_mksq(integration_variable,i),
+ mksq(new_coefficient,1)));
+ if new_dependency_list then depend_new_coefficient(new_dependency_list)
+ >>;
+ @<Find the next |int...@>
+end;
+solution:=mk!*sq subs2 solution;@/
+put_used_dimensions(coefficient_name,even_used,odd_used)
+
+@*1 Splitting polynomial equations.
+For the polynomial behaviour of |equation| we need to know the
+dependencies of all the functions occuring in |equation| at any level.
+If there occur any other variables in |equation| and |equation| is
+polynomial in these variables, the coefficients of this polynomial
+give rise to a new set of equations.
+
+@d pc_list_of=kc_list_of %power-coefficient list%
+@d powers_of=kernel_of
+
+@<Step 2...@>=@/
+@<Find |present_functions_list| and the |absent_variables|@>;
+@<Find the |polynomial_variables| and test for polynomial behaviour@>;
+@<If possible, split up |equation| into smaller equations@>
+
+@ Finding all the functions in |equation| can be done by applying the
+procedure |get_recursive_kernels| of the TOOLS package.
+
+@<Find |present_functions_list| and the |absent_variables|@>=@/
+function_list:=get(ces!*,'function_list);@/
+present_functions_list:=get_recursive_kernels(equation,function_list);@/
+variable_list:=get(ces!*,'variable_list);
+absent_variables:=variable_list;
+for each function in present_functions_list do
+ for each variable in get_dependencies_of(function) do@/
+ absent_variables:=delete(variable,absent_variables)
+
+@ In most cases the equations under consideration are polynomial in any
+of the variables and therefore we shall by default not test for
+polynomial behaviour. This testing is governed by the switch
+|polynomial_check| which, be default, is |off|. If it is |on| testing
+is done by the procedure |polynomialp| to be defined below.
+
+@<Find the |polynomial_variables| and test for polynomial behaviour@>=@/
+polynomial_variables:=absent_variables;
+if !*polynomial_check then@/
+ polynomial_variables:=for each variable in polynomial_variables join@/
+ if polynomialp(equation,variable) then list(variable)
+
+@ @<Lisp ini...@>=
+new_switch(polynomial_check,nil)$
+
+@ Checking a standard form for polynomial behaviour in some kernel can
+be done by checking the main variable, the leading coefficient and the
+reductum, respectively.
+
+@u
+lisp procedure polynomialp(expression,kernel);
+if domainp expression then t
+else ((main_variable=kernel or not depends(main_variable,kernel)) @|and
+ polynomialp(lc expression,kernel) and polynomialp(red expression,kernel)) @|
+ where main_variable=mvar expression$
+
+@ The coefficients of a polynomial can be found by
+applying the procedure |multi_split_form| from the TOOLS package.
+
+@<If possible, split up |equation| into smaller equations@>=@/
+equations_list:=multi_split_form(equation,polynomial_variables);
+if length equations_list>1 then
+<<for each pc_pair in pc_list_of equations_list do@/
+ setk(list(ces!*,incr(total_used)),
+ mk!*sq((coefficient_of pc_pair) ./ 1));
+ if independent_part_of equations_list then @/
+ setk(list(ces!*,incr(total_used)),
+ mk!*sq((independent_part_of equations_list) ./ 1));
+ write ces!*,"(",n,") breaks into ",
+ ces!*,"(",get(ces!*,'total_used)+1,@|
+ "),...,",ces!*,"(",total_used,") by ";@/
+ maprin partial_list(polynomial_variables,5);
+ terpri!* nil;@/
+ nullify_equation(n);
+ put(ces!*,'total_used,total_used);
+ goto solved
+>>
+
+@ In order to get messages in a readable form, we sometimes need to
+print lists partially. This is taken care of the following procedures.
+
+@u
+lisp procedure partial_list(printed_list,nr_of_items);
+'list . broken_list(printed_list,nr_of_items)$
+@#
+lisp procedure broken_list(list,n);
+if list then if n=0 then '(!.!.!.)
+else car list . broken_list(cdr list,n-1)$
+
+@*1 Solving Lie algebra relations.
+If the first two steps have failed, we need to analyze |equation| in
+a more drastic way: we need to find all functions occuring linearly in
+|equation|, and if a liebracket is specified, all commutators and
+algebra generators occuring in |equation| as well.
+Since we have already looked for |df| terms in |equation| in each next
+step we only have to examine the independent part of the previous step.
+
+@<Step 3...@>=@/
+linear_functions_list:=split_form(independent_part_of df_list,
+ function_list);@/
+df_list:=kc_list_of df_list;
+constants_list:=split_form(independent_part_of linear_functions_list,
+ list get(ces!*,'constant_operator));@/
+linear_functions_list:=kc_list_of linear_functions_list;
+if (bracketname:=get(ces!*,'bracketname)) then
+ @<Solve |equation| if it is a Lie expression@>
+
+@ In the Lie algebra case we can try to solve the Lie expression if
+there are no |df| terms or linearly occuring functions. Solving Lie
+expression can be done using the procedure |relation_analysis| of the
+LIESUPER package. |relation_analysis| returns either the kernel for which
+the relation is solved or an atom indicating the nature of the
+non-solvability.
+
+@<Solve |equation| if it is a Lie expression@>=
+ if length(df_list)=0 and
+ length(linear_functions_list)=0 then
+ <<
+ if atom(solvable_kernel:=
+ relation_analysis(!*ff2a(equation,denominator),bracketname))
+ then <<write ces!*,"(",n,") is a non-solvable Lie relation";
+ terpri!* t >>
+ else <<write ces!*,"(",n,") solved for "; maprin solvable_kernel;
+ terpri!* t; nullify_equation(n)>>;
+ goto solved
+ >>
+
+@*1 Solving a function.
+If |equation| is not a Lie expression, there may be a function or a
+constant for which we can solve it. In order to do this we need to
+\medskip
+
+\item{$-$} find all variables |present_variables|, on which at
+least one of the present functions |recursive_functions_list| depends;
+of course it is the complement of |absent_variables| in |variable_list|.
+
+\item{$-$} find all linearly occuring functions |solvable_kernels| which
+depend on all of the |present_variables|; these are the possible
+candidates for solving. If there are no |present_variables|,
+|equation| is apparently a relation between some constants and we can
+try to solve one.
+
+\item{$-$} remove all functions from |solvable_kernels|, which also
+occur in a |df| term, or in the liebracket case, in a commutator.
+
+\item{$-$} if |coefficient_check| is |on| we must only solve for those
+functions which have a number as coefficient. This is checked by the procedure
+|find_solvable_kernel|.
+
+\enditem
+Before doing anything we shall, however, construct lists containing
+all functions occuring in |df| terms, occuring linearly (and the
+constants) and, if necessary, occuring in commutators. These lists
+will also come in handy in the next steps.
+
+@<Step 4...@>=
+@<Construct |df_terms|, |df_functions|, |linear_functions| and
+|commutator_functions|@>;
+@<Get |present_variables| and |nr_of_variables|@>;
+for each kernel in linear_functions do if length
+ get_dependencies_of(kernel)=nr_of_variables then@/
+ solvable_kernels:=kernel . solvable_kernels;
+for each kernel in append(df_functions,commutator_functions) do @/
+ solvable_kernels:=delete(kernel,solvable_kernels);
+if solvable_kernels then
+ @<Try to solve a function@>
+
+@ Of course we are only interested in |df| terms of functions occuring
+on |function_list|.
+
+@<Construct |df_terms|, |df_functions|, ...@>=
+df_terms:=for each df_term in df_list join
+ if member(operator_name_of first_argument_of kernel_of df_term,function_list)
+ then @/list kernel_of df_term;
+for each df_term in df_terms do if not member(first_argument_of
+df_term,df_functions) then@/ df_functions:=first_argument_of(df_term) . df_functions;
+functions_and_constants_list:=append(linear_functions_list,
+ kc_list_of constants_list);@/
+linear_functions:=for each linear_function in
+ functions_and_constants_list collect kernel_of linear_function;
+if bracketname then commutator_functions:=@|
+ get_recursive_kernels(independent_part_of constants_list,
+ get(ces!*,'function_list));
+
+@ @<Get |present_variables| and |nr_of_variables|@>=
+present_variables:=variable_list;
+for each variable in absent_variables do
+ present_variables:=delete(variable,present_variables);
+nr_of_variables:=length present_variables
+
+@ @<Try to solve a function@>=
+ <<solvable_kernel:=
+ find_solvable_kernel(solvable_kernels,functions_and_constants_list,denominator);
+ if solvable_kernel then
+ <<linear_solve_and_assign(!*ff2a(equation,1),solvable_kernel);
+ depl!*:=assoc_delete(solvable_kernel,depl!*);
+ %Remove the dependencies of the solved function%
+ successful_message_for("Solved for ",solvable_kernel)
+ >>
+ else not_a_number_message_for("Solving a function",
+ partial_list(solvable_kernels,3))
+ >>
+
+@*1 Inhomogeneous integration.
+For an inhomogeneous integration, we are looking for a maximal |df| term,
+i.e. which has dependency on all the |present_variables|, such that
+the remaining part of |equation| is polynomial in the
+variables, w.r.t.\ which the function in the |df| term is
+differentiated, i.e.\ {\it a}) we only have to look at |df| terms
+which are differentiated w.r.t.\ variables on which none of the
+non-maximally occuring functions in |equation| depend, and {\it b}) if
+|polynomial_check| is |on|, we must check explicitly if the rest of
+|equation| is polynomial in these variables.
+
+We shall collect the list of ``integrable'' variables in the list
+|integration_variables|.
+
+@<Step 5...@>=
+@<Find the possible |integration_variables|@>;
+@<If possible find and integrate the integrable |df| term |solvable_kernel|@>
+
+@ Finding the |integration_variables| is rather easy using the lists
+|df_functions|, |linear_functions| and |commutator_functions|.
+Starting with |present_variables| we have to
+delete all variables on which on of the |linear_functions| or
+|commutator_functions| depend, or one of the |df_functions|, which do
+not have maximal dependency, i.e. which do no depend on
+|nr_of_variables| variables.
+
+@<Find the possible |int...@>=@/
+integration_variables:=present_variables;
+for each kernel in append(linear_functions,commutator_functions) do
+ for each variable in get_dependencies_of(kernel) do@/
+ integration_variables:=delete(variable,integration_variables);
+for each df_function in df_functions do
+ if not length get_dependencies_of(df_function)=nr_of_variables then
+ for each variable in get_dependencies_of(df_function) do@/
+ integration_variables:=delete(variable,integration_variables)
+
+@ Finding the integrable |df| terms is rather easy know: find all
+the |df| terms which have maximal dependency and are only
+differentiated w.r.t.\ variables occuring on |integration_variables|.
+In order to check this last item we need to know the form of |df|
+term: it is a list |'(df @tfunction@> @tdifferentiation\_sequence@>)|, where
+differentiation\_sequence is a sequence of variables, each variable optionally
+followed by a integer indicating the number of differentiations
+w.r.t.\ to that variable. The procedure
+|check_differentiation_sequence| checks whether all variables in a
+differentiation\_sequence are member of the second argument
+|variable_list|.
+
+@u
+lisp procedure check_differentiation_sequence(sequence,variable_list);
+if null sequence then t
+else @+if fixp first_element_of sequence or
+ member(first_element_of sequence,variable_list) then@/
+check_differentiation_sequence(rest_of sequence,variable_list)$
+
+@ @<If possible find and integrate...@>=
+@<Find the integrable |df_terms|@>;
+@<Find a |solvable_kernel|, check the |inhomogeneous_term| and possibly integrate@>
+
+@ There one situation we have to take care of specifically: if there
+are more |df_terms| for the same function, only one of which is
+differentiated just w.r.t. |integration_variables|, we are not allowed
+to integrate, since the function would be expressed in itself. In this
+case, we will make |solvable_kernels| a list of at least length 2
+in order to prevent integration.
+
+@<Find the integrable |df_terms|@>=
+for each df_term in df_terms do
+ <<if length get_dependencies_of(first_argument_of df_term)=nr_of_variables @|
+ and (check_differentiation_sequence(rest_of arguments_of df_term,
+ integration_variables)@|
+ or member(first_argument_of df_term,forbidden_functions))
+ then @/solvable_kernels:=if member(first_argument_of df_term,forbidden_functions)
+ then list(nil,nil) else df_term . solvable_kernels;
+ forbidden_functions:=(first_argument_of df_term) . forbidden_functions>>;
+
+@ @<Find a |solvable_kernel|, check the |inhomogeneous_term| and possibly integrate@>=
+if solvable_kernels then
+if length(solvable_kernels)=1 then
+ if (solvable_kernel:=find_solvable_kernel(solvable_kernels,df_list,denominator))
+ then
+ if (inhomogeneous_term:=linear_solve(mk!*sq(equation ./ 1),solvable_kernel))@|
+ and (not !*polynomial_check @|or
+ check_polynomial_integration(solvable_kernel,inhomogeneous_term))
+ then
+ <<df_kernel:=first_argument_of solvable_kernel;@/
+ setk(df_kernel,
+ inhomogeneous_integration_of(solvable_kernel,inhomogeneous_term));
+ depl!*:=assoc_delete(df_kernel,depl!*);
+ %Remove |df_kernel| from the |depl!*| list%
+ successful_message_for("Inhomogeneous integration of ",solvable_kernel)>>
+ else
+ <<write ces!*,"(",n,"): Inhomogeneous integration failed: "; terpri!* t;
+ write "inhomogeneous term not polynomial in integration variables";
+ terpri!* t; goto solved>>
+ else not_a_number_message_for("Inhomogeneous integration",
+ first_element_of solvable_kernels)
+else <<write ces!*,"(",n,"): Inhomogeneous integration failed: "; terpri!* t;
+ write "more terms with maximal dependency"; terpri!* t; goto solved>>
+
+@ Checking that the inhomogeneous term is polynomial in the
+integration variables is fairly easy. For all the integration
+variables we have to check that the denominator does not depend on it
+and the numerator should be polynomial.
+
+@u lisp procedure check_polynomial_integration(df_term,integration_term);
+begin scalar numerator,denominator,integration_variables,variable,ok;
+ numerator:=numr simp integration_term;
+ denominator:=denr simp integration_term;@/
+ integration_variables:=
+ for each argument in rest_of arguments_of df_term join
+ if not fixp argument then list argument;
+ ok:=t;
+ while ok and integration_variables do
+ <<variable:=first_element_of integration_variables;
+ ok:=(not depends(denominator,variable) and polynomialp(numerator,variable));
+ integration_variables:=rest_of integration_variables
+ >>;
+ return ok;
+end$
+
+@ We can perform the inhomogeneous integration by applying
+|multi_split_form| to find all the
+polynomial components of the inhomogeneous term and
+|homogeneous_integration_of| for solving the homogeneous equation.
+
+@u
+lisp procedure inhomogeneous_integration_of(df_term,inhomogeneous_term);
+begin scalar df_sequence,integration_variables,int_sequence,
+ variable,nr_of_integrations,integration_terms,solution,
+ powers,coefficient,int_factor,solution_term,n,k;
+ df_sequence:=rest_of arguments_of df_term;
+ @<Find the |integration_variables| and |int_sequence|@>;
+ integration_terms:=multi_split_form(numr simp inhomogeneous_term,
+ integration_variables);
+ integration_terms:=(nil . independent_part_of integration_terms) .
+ pc_list_of integration_terms;
+ %Make |integration_terms| a full blown |pc_list|%
+ @<Perform the inhomogeneous integration of the numerator of |inhomogeneous_term|@>;
+ solution:=multsq(solution,1 ./ denr simp inhomogeneous_term);
+ solution:=mk!*sq subs2 addsq(solution,simp homogeneous_integration_of df_term);
+ return solution
+end$
+
+@ We must analyze |df_sequence| to get all the integration variables,
+together with the number of integrations belonging to them.
+
+@<Find the |integration_variables| and ...@>=
+ while df_sequence do
+ <<variable:=first_element_of df_sequence;
+ df_sequence:=rest_of df_sequence;
+ if df_sequence and fixp first_element_of df_sequence then
+ <<nr_of_integrations:=first_element_of df_sequence;
+ df_sequence:=rest_of df_sequence>>
+ else nr_of_integrations:=1;
+ integration_variables:=variable . integration_variables;
+ int_sequence:=(variable . nr_of_integrations) . int_sequence
+ >>
+
+@ The particular solution of the equation $F^{(k)}(x)=x^n$ is
+$$
+F(x)={1\over(n+1)\cdots(n+k)}x^{n+k}.
+$$
+This process has to be performed for all the terms in
+|integration_terms| and for all integrations in |int_sequence|.
+
+@<Perform the inhomogeneous integration ...@>=
+solution:=nil ./ 1;
+for each term in integration_terms do
+<<powers:=powers_of term; coefficient:=coefficient_of term;
+ int_factor:=1; solution_term:=1 ./ 1;
+ for each integration in int_sequence do
+ <<variable:=car integration; k:=cdr integration;@/
+ n:=(if power then cdr power @+else 0) where power=assoc(variable,powers);
+ %If |variable| does not occur in |term|, |n=0|%
+ for i:=1:k do int_factor:=(n+i)*int_factor;
+ solution_term:=multsq(solution_term,mksq(variable,n+k))
+ >>;
+ solution_term:=multsq(solution_term,coefficient ./ int_factor);
+ solution:=addsq(solution,solution_term)
+>>
+
+@*1 Generation of new equations by differentiation.
+As a last method of solving we notice the following: if there is a
+variable, such that just one |df| term or just one linearly occuring
+function depends on it and all the other terms are polynomial in this
+variable, let's say of degree $n$, then we can differentiate
+|equation| $n+1$ times to get a new equation of type A.
+
+Experience has proven, however, that applying the above mentioned
+method, generally will lead to multiple generation of equivalent
+terms in the answer. Therefore we will only generate a new equation if
+the switch |allow_differentiation| is |on|, otherwise we will only
+generate a message that it is possible to generate a new equation of
+type A. Solving of such a new equation is always left to the responsibility
+of the user.
+
+@<Lisp ini...@>=@/
+new_switch(allow_differentiation,nil)$
+
+@ After this introduction it is clear what we have to do for step 6:
+
+@<Step 6...@>=
+@<Count the number of occurences of all |present_variables|@>;
+@<If possible and allowed, generate new equations@>
+
+@ Counting the occurence of variables is rather easy. For all
+functions in |df_terms|, |linear_functions| and
+|commutator_functions|, we have to count the occurences of all the
+variables in their respective entries on the dependency list |depl!*|.
+
+For this purpose we rebuild |present_variables| to an association list
+with entries of the form |variable . origin . number_of_occurences|
+where |origin| indicates the |df_term|, |linear_function| or
+|commutator_function| in which |variable| occured last.
+
+The action of the following macros, which harmlessly make use of the
+procedure |rplacd|, is clear.
+
+@d reinitialize_present_variables=@/
+present_variables:=for each variable in present_variables collect
+ (variable . nil . 0)
+@d variable_of=car
+@d origin_of=cadr
+@d counter_of=cddr
+@d update_variable(variable,origin)=
+rplacd(entry,origin . (counter_of entry + 1))
+ where entry=assoc(variable,present_variables)
+@d update_variables_using(kernel_list,kernel_selector,flag_function)=@/
+for each kernel in kernel_list do
+ for each variable in get_dependencies_of(kernel_selector(kernel)) do@/
+ update_variable(variable,flag_function(kernel));
+@d identity_function(kernel)=kernel
+@d empty_function(kernel)=nil
+
+@<Count the number ...@>=@/
+reinitialize_present_variables;@/
+update_variables_using(df_terms,first_argument_of,identity_function);@/
+update_variables_using(linear_functions,identity_function,identity_function);
+if bracketname then update_variables_using(commutator_functions,
+ identity_function,empty_function)
+
+@ After the preceding step we can generate new equations by
+differentiating |equation| w.r.t.\ to all those variables which occur
+in only one |df_term| or |linear_function| and for which all other
+terms of |equation| are polynomial. Using the above code one can check
+that these variables are exactly the ones for which the |origin| has a
+value and the |counter| is 1.
+
+@<If possible and ...@>=
+differentiations_list:=
+ for each entry in present_variables join
+ if origin_of entry and counter_of entry=1 @|and
+ (polynomial_order:=@|get_polynomial_order(
+ linear_solve(mk!*sq(equation ./ 1),origin_of entry),variable_of entry))@|
+ then list(variable_of entry . origin_of entry . (polynomial_order+1));
+if differentiations_list then
+ if !*allow_differentiation then
+ <<for each entry in differentiations_list do @/
+ setk(list(ces!*,incr(total_used)),@|
+ mk!*sq simpdf list(mk!*sq(equation ./ 1),
+ variable_of entry,counter_of entry));
+ write ces!*,"(",n,"): Generation of ",ces!*,"(",get(ces!*,'total_used)+1,
+ "),...,",@|ces!*,"(",total_used,") by differentiation w.r.t. ";
+ terpri!* t;@/
+ maprin partial_list(for each entry in differentiations_list collect@|
+ list('list, variable_of entry,counter_of entry),10);@/
+ terpri!* nil;
+ put(ces!*,'total_used,total_used);
+ goto solved
+ >>
+ else <<
+ write "*** ",ces!*,"(",n,
+ "): Generation of new equations by differentiation possible.";
+ terpri!* t; write " Solvable with 'on allow_differentiation'";
+ terpri!* t; goto solved>>
+
+@ An algebraic expression is polynomial in a variable if the
+denominator does not depend on it and if the numerator is polynomial
+(we only have to check this if |polynomial_check| is |on|).
+The polynomial order we can obtain by simply reordering the numerator
+w.r.t. the variable involved.
+
+@u
+lisp procedure get_polynomial_order(expression,variable);
+if not depends(denr(expression:=simp expression),variable) @|and
+ (not !*polynomial_check or polynomialp(numr expression,variable)) then
+ begin scalar kord!*;
+ setkorder list !*a2k variable;
+ expression:=reorder numr expression;
+ return @+if mvar expression=variable then ldeg expression @+else 0;
+ end$
+
+@ If none of the above methods can be applied, we cannot solve
+|equation|.
+
+@<Step 7...@>=@/
+write ces!*,"(",n,") not solved"; terpri!* t
+
+@*=Additional tools.
+The following procedure are meant for solving more equations at a
+time or solving ``exceptional'' equations, which need the least restrictive
+setting of the switches |coefficient_check|, |polynomial_check| or
+|allow_differentiation|.
+
+@u
+algebraic procedure integrate_equations(m,n);
+for i:=m:n do integrate_equation(i)$
+
+@#
+lisp operator integrate_exceptional_equation;
+lisp procedure integrate_exceptional_equation(n);
+integrate_equation(n)
+where @|
+ !*coefficient_check=nil,@|
+ !*polynomial_check=nil,@|
+ !*allow_differentiation=t$
+
+
+@ As a last set of tools, we shall give a procedure to print
+an equation together with all the functions occuring in it and their
+dependencies, and some procedures for showing and changing the properties
+of an equation set and a the functions/constants used.
+
+As a side effect the procedure |show_equation| will reassign the shown
+equation to its current value.
+
+@u lisp operator show_equation;
+lisp procedure show_equation n;
+begin scalar equation,total_used,function_list;
+ if null(total_used:=get(ces!*,'total_used)) or
+ n>total_used then
+ stop_with_error("SHOW_EQUATION: properly initialize",
+ ces!*,nil,nil);
+ if (equation:=assoc(list(ces!*,n),get(ces!*,'kvalue))) then
+ begin
+ equation:=setk(list(ces!*,n),aeval cadr equation);
+ varpri(equation,list('setk,mkquote list(ces!*,n),mkquote equation),'only);
+ function_list:=get_recursive_kernels(numr simp equation,
+ get(ces!*,'function_list));
+ if function_list then
+ <<terpri!* t;
+ for each fn in function_list do
+ <<maprin(fn . get_dependencies_of(fn)); terpri!* nil>>
+ >>
+ else terpri!* nil
+ end
+end$
+
+@#
+algebraic procedure show_equations(m,n);
+for i:=m:n do show_equation i$
+
+@
+@u
+lisp operator functions_used,put_functions_used,equations_used,put_equations_used;
+
+@#
+lisp procedure functions_used function_name;
+list('list,get(function_name,'even_used),get(function_name,'odd_used))$
+
+@#
+lisp procedure put_functions_used(function_name,even_used,odd_used);
+begin
+ if not fixp even_used or even_used<0 or
+ not fixp odd_used or odd_used<0 then@/
+ stop_with_error("PUT_FUNCTIONS_USED: used functions number invalid",nil,nil,nil);
+ put(function_name,'even_used,even_used);
+ put(function_name,'odd_used,odd_used);
+end$
+
+@#
+lisp procedure equations_used;
+get(ces!*,'total_used)$
+
+@#
+lisp procedure put_equations_used(n);
+if not fixp n or n<0 then@/
+ stop_with_error("PUT_EQUATIONS_USED: used equation number invalid",nil,nil,nil)
+else put(ces!*,'total_used,n)$
+
+@ There is one slight detail which we have not dealt with yet: in
+prolongation theory differentiation should act as a derivation on the
+arguments of a (eventually nested) commutator. In REDUCE 3.4 there is
+a hook which can take care of this situation. In the procedure
+|diffp|, which takes care of differentiation of standard powers, if
+this standard power is an operator kernel, the property |dfform| is
+checked for operator concerned. If this property has a value, it
+should be a function which takes care of the differentiation of such a
+standard power.
+
+@u
+lisp operator df_acts_as_derivation_on;
+
+lisp procedure df_acts_as_derivation_on operator_name;
+begin
+ put(operator_name,'dfform,'df_as_derivation);
+end$
+
+@ The procedure |df_as_derivation| is quite straightforward: apply
+|df| to all the arguments of the operator, one at a time, leaving the
+other ones untouched.
+
+@u
+lisp procedure df_as_derivation(kernel,variable,power);
+begin scalar left_part,right_part,argument,derivative;
+ if power neq 1 then
+ stop_with_error("DF_AS_DERIVATION:",kernel,"must occur linearly",nil);
+ left_part:=list operator_name_of kernel;@/ right_part:=arguments_of kernel;@/
+ derivative:=nil . 1;
+ while right_part do
+ <<argument:=first_element_of right_part; @/right_part:= rest_of right_part;@/
+ derivative:=addsq(derivative,
+ simp append(reverse left_part,list('df,argument,variable) . right_part));@/
+ left_part:=argument . left_part;
+ >>;
+ return derivative;
+end$
+
+@ In order to get nice output of some of the messages given by
+|integrate_equation| we redefine the print function |listpri| for
+algebraic lists. Namely, we want don't want algebraic lists to split
+over multiple lines in the messages we give. For this purpose, we
+introduce a fluid variable |listpri_depth!*| which governs the depth
+for which algebraic lists are split along lines. The default value is
+the same as the value in the used in REDUCE.
+
+@<Lisp ini...@>=
+initialize_fluid(listpri_depth!*,40)$
+
+@ The following procedure can be used at algebraic level to change
+|listpri_depth!*|.
+
+@u
+lisp operator listlength$
+lisp procedure listlength l;
+listpri_depth!*:=l$
+
+@ The definition of |listpri| is basically that of |inprint|, except
+that it decides when to split at the comma by looking at the size of
+the argument, using the global variable |listpri_depth!*|.
+
+@u
+symbolic procedure listpri l;
+ begin scalar orig,split,u;
+ u := l;
+ l := cdr l;
+ prin2!* get('!*lcbkt!*,'prtch);
+ % Do it this way so table can change%
+ orig := orig!*;@/
+ orig!* := if posn!*<18 then posn!* @+else orig!*+3;
+ if null l then go to b;
+ split := treesizep(l,listpri_depth!*);
+ a: maprint(negnumberchk car l,0);
+ l := cdr l;
+ if null l then go to b;
+ oprin '!*comma!*;
+ if split then terpri!* t;
+ go to a;
+ b: prin2!* get('!*rcbkt!*,'prtch);
+ orig!* := orig;
+ return u
+ end$
+
+@ The end of a REDUCE input file must be marked with |end|.
+
+@u end;
+
+@*=Index. This section contains a cross reference index of all
+identifiers, together with the numbers of the mdules in which they are
+used. Underlined entries correspond to module numbers where the
+identifier was declared.
+
diff --git a/web/reduce/rweb/appl/liesuper.web b/web/reduce/rweb/appl/liesuper.web
new file mode 100644
index 0000000000..c760f2da6e
--- /dev/null
+++ b/web/reduce/rweb/appl/liesuper.web
@@ -0,0 +1,4287 @@
+% Copyright (c) 1991 Marcel Roelofs, University of Twente, Enschede,
+% The Netherlands.
+%
+% $Header: liesuper.web,v 1.5 92/02/26 14:22:25 roelofs Exp $
+%
+\input specification
+\def\Version$#1Revision: #2 ${Version #2}
+\def\title{LIESUPER}
+\font\titlefont=cmcsc10 scaled\magstep3
+\font\ttitlefont=cmtt10 scaled\magstep4
+\def\topofcontents{\null\vfill
+\centerline{\titlefont The {\ttitlefont LIESUPER} package for REDUCE}
+\vskip15pt\centerline{\Version$Revision: 1.5 $}
+\vskip15pt\centerline{\sc Marcel Roelofs}\vfill}
+\def\concl{\bigskip\narrower\narrower\narrower\noindent
+ {\bf SPECIFICATIONS}:\hskip1em\ignorespaces}
+\def\endconcl{\par\leftskip=0pt\rightskip=0pt\noindent\ignorespaces}
+\def\enditem{\medskip\noindent\ignorespaces}
+\def\lie{{\it lie}}
+\def\newpage{\vfill\eject}
+
+@*= Introduction. In this \.{WEB} file we will describe a REDUCE package for
+symbolic computations in (free) Lie (super)algebras. For this purpose
+we will introduce a new rtype liebracket, which satisfies the
+bilinearity and the (graded) skew-symmetry of the liebracket.
+Moreover, we will implement a mechanism to check the (graded) Jacobi
+identity and add sufficient bells and whistles to facilitate the usage
+of various kinds of gradings.
+
+Although we call it a rtype there is a difference with the usual
+rtypes in REDUCE like arrays or matrices. Elements of an array or a
+matrix can be accessed through a get-element-function and always have
+a value (which can be and actually is simplified before returning it).
+Elements of a liebracket, however, need not always have a value, in
+which case the element itself should be returned in a canonical form
+(in this way it resembles the REDUCE operator |df|). Hence access to
+elements of a liebracket must necessarily be through a simplification
+function, in order to avoid infinite loops on simplification.
+
+On the other hand a liebracket isn't an algebraic operator in the
+usual sense either, because we don't want to use the standard
+mechanism for storing elements of algebraic operators, since this
+generates a linear list containing all values, which is too time
+consuming if a large number of values have to be stored. Instead we
+will use a vector structure which is better suited to the structure of
+a liebracket. Therefore we are enforced to use a set-element-function
+to assign values to elements of a liebracket. The only way to
+accomplish this is to define liebracket to be a rtype.
+
+Another bottleneck for operators with a large number of used elements
+is the use of the so called klist. On this list all operator elements
+are stored which at least have occured once in an algebraic expression.
+Therefore we shall extend some standard REDUCE procedures which take
+care of or use the klist mechanism, in such a way that for liebrackets
+the klist is replaced by an additional field in the vector structure.
+
+It is well known that commutators are normally represented by a pair
+of square brackets $[\,\ldotp\,,\,\ldotp\,]$ in mathematics. Since we
+explicitly want to allow more liebrackets at a time, it is impossible
+for us to denote all commutators in this notation. We will, however,
+facilitate the use of square brackets for a specific liebracket, which
+can be used in all cases where one only needs to work with one
+liebracket.
+
+\medskip
+The ``banner line'' defined here is intended for indentification
+purposes on loading. It should be changed whenever this file is
+modified. System dependent changes, however, should be made in a
+separate change file.
+
+@d banner="Lie (super)algebra package for REDUCE 3.4, $Revision: 1.5 $"
+
+@ We define the following macros for clarity.
+@d change_to_symbolic_mode =symbolic
+@d change_to_algebraic_mode =algebraic
+@d stop_with_error(string_1,expr_1,string_2,expr_2) = @/
+ msgpri(string_1,expr_1,string_2,expr_2,t) @;
+@d message(string_1,expr_1,string_2,expr_2) = @/
+ msgpri(string_1,expr_1,string_2,expr_2,nil) @;
+@d operator_name_of=car
+@d arguments_of=cdr
+@d first_argument_of=cadr
+@d second_argument_of=caddr
+@d first_element_of=car
+@d second_element_of=cadr
+@d rest_of=cdr
+@d skip_list=cdr %Skip the |'list| in front of an algebraic list%
+@d independent_part_of=cadr %For use with lists returned by |operator_coeff|%
+@d kernel_coeff_list_of=cddr %For use with lists returned by |operator_coeff|%
+@d kernel_of=cadr %For use with a kernel-coefficient list%
+@d coefficient_of=caddr %For use with a kernel-coefficient list%
+
+@ The following macros are intended as common programming idioms.
+@d incr(x) = (x:=x+1)@;
+@d decr(x) = (x:=x-1)@;
+
+@ A new REDUCE switch can be introduced using the following code.
+
+@d initialize_global(global_name,value)=@/
+global '(global_name)$@/
+global_name:=value
+
+@d new_switch(switch_name,value)=@/
+initialize_global(!* @& switch_name,value)$@/
+flag('(switch_name),'switch)
+
+@ We do all initializations in the beginning of the package.
+@u
+change_to_symbolic_mode$@/
+write banner$terpri()$@/
+@<Check if the TOOLS package is already loaded@>$
+@<Lisp initializations@>@/
+change_to_algebraic_mode$
+
+@ For a proper function of some procedures of this \.{WEB} file we
+need a number of procedures from the TOOLS package. Therefore we will
+check if the TOOLS package has already been loaded. We do this by
+verifying that |operator_coeff| is defined as function.
+
+@<Check if the TOOLS...@>=
+if not getd 'operator_coeff then
+message("LIESUPER_INIT: load the TOOLS package before continuing",nil,nil,nil) @;
+
+
+@*= Implementing free Lie superalgebras. For $m,n\geq 0$ let ${\sl
+Lib}={\sl Lib}(x_1,\dots,x_m,\xi_1,\dots,\xi_n)$ be the free algebra
+on generators $x_1,\dots,x_m,\xi_1,\dots,\xi_n$. We introduce a {\bf
+Z}$_2$-grading $\vert\,\ldotp\vert$ on {\sl Lib\/} by defining $\vert
+x_i\vert=0$ $(i=1,\dots,m)$, $\vert \xi_j\vert=1$ $(j=1,\dots,n)$ and
+$\vert xy\vert=\vert x\vert+\vert y\vert$ for all homogeneous $x,y\in
+{\sl Lib}$. We define $L=L(x_1,\dots,x_m,\xi_1,\dots,\xi_n)$ to be the
+quotient algebra ${\sl Lib}/I$ where $I$ is the ideal, which for all
+homogeneous $x,y,z\in {\sl Lib}$ is generated by the elements
+$xy+(-1)^{\vert x\vert \cdot\vert y\vert}yx$ and $(-1)^{\vert
+ x\vert\cdot\vert z\vert }x(yz)+
+ (-1)^{\vert y\vert \cdot\vert x\vert}y(zx)+
+ (-1)^{\vert z\vert \cdot\vert y\vert }z(xy)$.
+
+On $L$ we define a bracket $[x,y]\equiv xy$. Then from the definition
+above it is clear that this bracket satisfies the graded skew-symmetry
+$$[x,y]=-(-1)^{\vert x\vert \cdot\vert y\vert}[y,x]$$
+and the graded Jacobi identity
+$$(-1)^{\vert x\vert\cdot\vert z\vert }[x,[y,z]]+
+ (-1)^{\vert y\vert \cdot\vert x\vert}[y,[z,x]]+
+ (-1)^{\vert z\vert \cdot\vert y\vert }[z,[x,y]]=0.$$
+Moreover it is bilinear because of the bilinearity of the multiplication
+in {\sl Lib}. Therefore $L$ defines a Lie superalgebra, the so called
+{\it free Lie superalgebra\/} on even generators $x_1,\dots,x_m$ and odd
+generators $\xi_1,\dots,\xi_n$. It is obvious that for $m>1$ or $n>1$
+$L$ is infinite dimensional.
+
+From this free Lie superalgebra we can get some specific Lie
+(super)algebra by imposing additional relations on top of the graded
+skew-symmetry and the graded Jacobi identity. For instance, we can get a
+finite dimensional simple Lie algebra by imposing appropriate Serre
+relations.
+
+As a last point we have to mention gradings of Lie (super)algebras,
+because these can be very helpful when working on Lie (super)algebras.
+A Lie (super)algebra can admit more than one grading, for example,
+the free Lie (super)algebra on $n$ generators admits a {\bf
+Z}$_2$-grading, but also admits the length of ``words'' as a grading,
+or a multigrading where the degree of $x_i$ is the $n$-tuple
+$(0,\dots,1,\dots,0)$ (1 on the $i$-th place).
+
+\bigskip
+There is one fact about free Lie superalgebras which is very useful if
+we want to implement a free Lie superalgebra in REDUCE. To explain
+this, let $L_1=L(x_1,\dots,x_n)$ be the free Lie superalgebra on
+generators $x_1,\dots,x_n$ for some $n>1$. Then it is easy to prove
+that $L_1$ is isomorphic to
+$L_2=L(x_1,\dots,x_{n+1})/I(x_{n+1}-[x_1,x_2])$ where
+$I(x_{n+1}-[x_1,x_2])$ is the ideal in $L_2$ generated by
+$x_{n+1}-[x_1,x_2]$.
+This means that we can avoid expressions containing commutators like
+$[x_1,x_2]$ just by introducing a new generator $x_{n+1}$ and imposing
+one additional relation $[x_1,x_2]=x_{n+1}$.
+\newpage
+@ In the sections that follow we will take some decisions about how we are
+planning to introduce a structure in REDUCE suitable to deal with free
+Lie superalgebras. From what we have said in the previous section it is
+clear that the following points have to be taken into account:\medskip
+
+\item{1.} the bilinearity of the bracket.
+\item{2.} the graded skew-symmetry of the bracket.
+\item{3.} the number of generators and the possibility to introduce new
+ generators as new names for unknown commutators.
+\item{4.} the Jacobi identity.
+\item{5.} the ability to use various kinds of gradings.
+
+@*2 Representation of Lie algebras. The first point we have to take
+care of is how to represent commutators and generators in REDUCE.
+Generators we want to represent by an algebraic operator. For example,
+we could represent $x_i$ by an operator $x(i)$. We should, however, be
+able to discriminate between even and odd generators. There are a few
+solutions to this problem:\medskip
+\item{1.} use different operators for even and odd generators.
+\item{2.} for each generator keep record of its grade. \item{3.} use
+different ranges for even and odd generators. For instance, use $x(i)$
+with $i>0$ for even generators and $x(i)$ with $i<0$ for odd
+generators. \enditem We have chosen the third solution, since it
+seems the most practical one. Namely, it offers a very easy way to
+test whether a generator is odd or even.
+
+@ Commutators can simply be represented by an algebraic operator with
+two arguments. If we use, for example, the operator \lie\ for
+commutators and $x$ for generators, $[x_i,x_j]$ will be represented by
+$\lie(x(i),x(j))$. For this kind of expression, however, it seems
+useful to introduce a shorthand notation $\lie(i,j)$, since these
+expressions will be playing a very important role. We have found:
+
+\concl To each liebracket we assign two algebraic operators to
+represent the commutators and the generators, respectively. If $x$ is
+the operator assigned to some liebracket as generator, the elements
+$x(i)$ for $i<0$ represent the odd generators of the Lie superalgebra,
+the elements $x(i)$ for $i>0$ represent the even generators.
+Commutators are represented by an algebraic operator with two
+arguments. If \lie\ is this operator, $\lie(i,j)$ with $i$ and $j$
+integer will be a shorthand notation for $\lie(x(i),x(j))$.
+\bigskip
+\endconcl
+If in the sequel we want to explain things about liebrackets by giving
+an example, we will always use the pair |@!lie|, |@!x| to represent
+the commutators and generators, respectively.
+
+@ We have seen that we are allowed to set an unknown commutator
+$\lie(i,j)$ equal to $x(p)$ for some new generator $x(p)$ and still
+keep the same algebra (up to isomorphism). Hence in ordinary cases we
+need not assign values to expressions like $\lie(\lie(i,j),q)$, because
+with the above substitution for $\lie(i,j)$ it can be simplified to
+$\lie(p,q)$.
+
+It seems like a good idea to adopt the introduction of new generators
+for unknown commutators as a very useful strategy, because it prevents
+nested commutators to be represented in REDUCE by very lengthy and
+deeply nested expressions. This may become very important for it
+takes significantly more time to simplify deeply nested expressions
+than simple expressions like $\lie(i,j)$ with $i$ and $j$ integer.
+Moreover, the points raised above make the following simplifications
+possible:\medskip
+\item{1.} Using the bilinearity we see that $\lie(10*x(1),x(2)+x(3))$
+is equal to $10*\lie(1,2)+10*\lie(1,3)$. This means that there is no
+need to store commutators of linear combinations of generators.
+\item{2.} From the graded skew-symmetry we see that $\lie(j,i)$ is
+equal to $-\lie(i,j)$ if $\vert x_i\vert\cdot\vert x_j\vert=0$ and
+equal to $\lie(i,j)$ otherwise. So our first observation is that there
+must be a mechanism to store values of $\lie(i,j)$ for $j\geq i$.
+\enditem
+Although most Lie (super)algebras under consideration will be infinite
+dimensional, it will only be possible to compute a finite dimensional
+part of it by computer. Following our strategy of introducing new
+generators for unknown commutors, this boils down to the fact that we
+can only compute finitely many commutators of two generators.
+So it's no real restriction to impose upperbounds on the number of
+generators beforehand.
+
+For practical problems, however, these upperbounds may still be
+rather big, let's say 100 odd and 100 even generators. In principle
+all commutators of these generators may get a value, but if we assume
+that only a quarter of all commutators is known, in our example with
+200 generators this still means that about 5000 values have to be
+stored.
+
+This already indicates that it isn't a good idea to store the values
+of commutators of generators on the standard REDUCE kvalue list, which
+is an association list. Access to an association list is by comparing
+the |car| of all its elements with the wanted expression until both
+are equal. Hence it will take more and more time to access an element
+of an association list as it grows.
+
+For practical problems like the example above, access to an
+association list will already be too time consuming. Therefore we
+will choose to store values of commutators of generators in a vector
+structure, a lisp object which is more directly accessible. Because a
+vector is a static object, we need the upperbounds on the number of
+generators right at this place. Resuming we have found:
+
+\concl We impose upperbounds on the number of even and odd
+generators (these upperbounds should include the number of generators
+which we want to introduce as new names for unknown commutators).
+If these upperbounds are $m$ and $n$, respectively, we store
+the values of $\lie(i,j)$ for $-n\leq i\leq j\leq m$ in a vector
+structure.
+\endconcl
+
+@ For some applications we sometimes need to allow more general
+expressions as element of a Lie (super)algebra than just the
+generators. For instance, this is the case if we want to do
+computations in (super)prolongation theory, where we are working with
+Lie (super)algebra valued functions.
+
+Nevertheless we should be able to assign values to commutators
+containing such expressions or to commutators containing nested
+commutators, to which we don't want or cannot assign a value, for
+whatever reason. But this means that we can't just do with the vector
+structure, because these ``irregular'' commutators don't fit into it.
+The most appropriate way to store such kind of commutators is to use
+the standard REDUCE kvalue list.
+
+However, we have to impose some restrictions on the kind expressions
+which we allow to act as algebra elements. We should, for instance, be
+able to recognize it as an algebra element. In view of the way we
+will decompose a commutator into its smallest components later on, the
+first restriction must be that we can only allow operator expressions
+to act as algebra elements.
+Therefore the easiest way to allow for more general algebra elements
+is to add to a liebracket a list of operatornames, elements of which
+are regarded to be elements of that Lie (super)algebra.
+
+There is one more restriction we have to impose, namely for each
+algebra element we want to know if it is odd or even (nonhomogenous
+elements we can split up into an odd and an even part). The reason that
+we want to know this will become clear in the following section.
+This can also be achieved very easily: if $f(a_1,\dots)$ is some
+general algebra element, not being a commutator or a generator, we
+demand its first argument $a_1$ to be a positive or negative integer,
+indicating if the algebra element is even or odd, respectively.
+
+\concl To each liebracket we add a list of operators, elements of
+which will be regarded to be elements of the Lie (super)algebra. The
+first argument of such an element should be a positive or negative
+integer, indicating if it is an even or even algebra element. The
+values of commutators containing algebra elements, which are not
+generators, will be stored on the standard REDUCE kvalue list.
+\endconcl
+
+@ Now we know how all possible algebra elements look like, we want to
+have a canonical representation of all commutators. In this way REDUCE
+will always correctly recognize sums of commutators to be zero, which
+otherwise might possibly have slipped through because of the
+bilinearity or the skew-symmetry of the bracket.
+To get a commutator in canonical representation we apply the
+following rules:\medskip
+\item{1.} decompose the commutator into its smallest components
+using the bilinearity of the bracket.
+\item{2.} commutators $\lie(x(i),f(a_1,\dots))$, where $f$ is
+some operator allowed as algebra element (including generators and nested
+commutators), are represented by its shorthand notation
+$\lie(i,f(a_1,\dots))$. The same applies to the second argument.
+\item{3.} if one of the arguments is 0, the commutator is 0. This
+follows directly from the bilinearity. From this we see the necessity
+not to allow $x(0)$ as a generator, because its shorthand notation in
+a commutator would be 0 and all commutators with $x(0)$ would become 0
+applying the rule stated above.
+\item{4.} using the standard REDUCE procedure |ordp(x,y)|, the
+arguments $x$ and $y$ of $\lie(x,y)$ are orderded canonically.
+If we have to switch $x$ and $y$ the result is
+provided with a minus sign if not both $x$ and $y$ are odd algebra
+elements. This actually is the reason, why for every algebra element
+we need to know if it is odd or even.
+
+@*1 Jacobi identities. The Jacobi identity expresses the fact that not
+all commutators are linear independent. To explain this, we look at
+the Jacobi identity for $x(1)$, $x(2)$ and $x(3)$. It reads
+$\lie(1,\lie(2,3))-\lie(2,\lie(1,3))+\lie(3,\lie(1,2))=0$, where we
+have used graded skew-symmetry to get the second term. Further suppose
+that we have introduced new generators $\lie(1,2)=x(4)$,
+$\lie(1,3)=x(5)$ and $\lie(2,3)=x(6)$, then this Jacobi identity
+implies that $\lie(1,6)-\lie(2,5)+\lie(3,4)=0$. But this is nothing
+else than to say that $\lie(1,6)$, $\lie(2,5)$ and $\lie(3,4)$ are
+linear dependent. If, moreover, $\lie(1,6)$, $\lie(2,5)$ and
+$\lie(3,4)$ all are a sum of generators, the Jacobi identity might
+either be zero or otherwise lead to a linear dependency for some
+generators of the Lie (super)algebra.
+
+It is clear that for each triple of algebra elements the
+Jacobi identity is either zero or leads to a relation between algebra
+elements and/or commutators of algebra elements. If we have $N$ linear
+independent and homogeneous (w.r.t.\ the {\bf Z}$_2$ grading) algebra
+elements (generators as well as the more general operator expressions
+allowed as algebra element), the number of Jacobi identities amounts
+to $N\choose 3$ if all algebra elements are even, and slightly more if
+some of the elements are odd. Hence we conclude that the number of
+Jacobi identities grows very fast for increasing $N$.
+
+Just if only a small part of the Jacobi identities would lead to new
+relations this still means that quite a lot of values would have to be
+stored. If we were to store these values on the kvalue list of the
+operator representing the commutator, we would be facing an increasing
+access time for that kvalue list very soon. This indicates that it is
+only useful to compute and solve those Jacobi identities which don't
+lead to storing of values on the kvalue list of the commutator.
+Therefore we should only check those Jacobi identities that
+(eventually) lead to new relations for commutators of two generators
+(since these are stored in a vector structure) or to relations between
+some generators (since this kind of relation cannot be avoided).
+
+Hence the first remark that can be made, is that we only have to check
+Jacobi identities for triples of generators $x(i)$, $x(j)$ and $x(k)$,
+since these are the only ones to lead without too much difficulty to
+the desired kind of relation.
+Furthermore, if we want to satisfy the condition stated above, it is
+easy to see that all three commutators $\lie(i,j)$, $\lie(j,k)$ and
+$\lie(i,k)$ are to be entirely expressed in terms of some other
+generators. Therefore we have found:
+
+\concl
+There must be a mechanism to compute and solve the Jacobi
+identities for all triples of generators $x(i)$, $x(j)$ and $x(k)$
+which satisfy the condition that all three commutators $\lie(i,j)$,
+$\lie(j,k)$ and $\lie(i,k)$ are a linear combination of generators.
+
+\bigskip \endconcl It is well known that one can give a basis of a
+free Lie (super)algebra seen as a linear space, the so called Hall
+basis. Consequently, this Hall basis respects the linear dependencies
+caused by the Jacobi identity and the graded skew-symmetry.
+
+Now suppose that we start off with a free Lie (super)algebra on $n$
+generators, i.e., a Lie (super)algebra without any additional
+relations, and suppose that we want to compute a basis of this algebra
+as a linear space in REDUCE. It is not difficult to see that we can
+construct this basis upto ``words'' of a certain length $L$ by
+executing a cycle of introducing new generators for still unknown
+commutators of length $l$ and trying to solve Jacobi identities for
+$l=2,\dots,L$. The result in each step of solving the Jacobi
+identities is that all linear dependencies for commutators of length
+$l+1$ are found and solved. Hence in the step for $l+1$ only the
+remaining independent commutators will be renamed.
+
+From this we see that solving Jacobi identities the way we are
+planning to, is a means to get a minimal set of generators of a Lie
+(super)algebra up to a certain length.
+
+@*2 Gradings. The next point we should say something about are
+gradings. As we have already seen, a Lie (super)algebra can have more
+than one grading. However, all gradings together constitute a
+multigrading. Although not all gradings adopt integer values (for
+example the grading belonging to the root space decomposition of
+Kac-Moody algebras), we can, at least for finitely generated algebras,
+represent them by an appropriate multigrading with integer values.
+
+If for each generator we store its multigrade, we can retrieve the
+grade of every commutator (of two generators), since it is the sum of
+the grades of its arguments.
+
+\concl
+There must be a mechanism to store and retrieve integer valued
+multigrades of every generator of the Lie (super)algebra. With help of
+these the multigrade of every commutator can be determined.
+\endconcl
+
+@ Then finally, we want to introduce a shorthand notation to be able
+to input nested commutators more easily, which can be very useful when
+actually working on Lie (super)algebras. For this suppose, for
+example, that we want to compute the commutator
+$[[x_1,x_2],[x_2,[x_3,x_4]]]$. Using the rules described above, it can
+be represented by the expression $\lie(\lie(1,2),\lie(2,\lie(3,4)))$
+in REDUCE. This is a rather lengthy expression and, moreover, it
+doesn't express the structure of the commutator very clearly. If we
+denote the bracket by a $\cdot$, the above commutator reads $(x_1\cdot
+x_2)\cdot(x_2\cdot(x_3\cdot x_4))$ or $(x_1\cdot x_2)\cdot x_2\cdot
+x_3\cdot x_4$, if we define $\cdot$ to be right associative (by this
+we mean that $x_1\cdot x_2\cdot x_3\equiv x_1\cdot(x_2\cdot x_3)$).
+
+In our opinion this is the most simple and easy to understand
+expression representing the above commutator, and we want to introduce
+a counterpart of this representation in REDUCE. Therefore, let for
+$N\geq 3$ the expression $\lie(x_1,\dots,x_N)$ be a shorthand notation for
+$\lie(x_1,\lie(x_2,\dots,\lie(x_{N-1},x_N)\dots))$, where
+$x_1,\dots,x_N$ are algebra elements.
+Moreover, to avoid lengthy expressions, we will allow (algebraic) list
+expression as nested commutators.
+With these simplifications the above commutator may be represented by
+the REDUCE expression $\lie(\{1,2\},2,3,4)$.
+
+Of course, if one is working with the ``default'' liebracket which may
+be represented by square brackets (mentioned in the introduction), it
+may also be represented by $[[1,2],2,3,4]$ or even by
+$[\{1,2\},2,3,4]$.
+
+\concl
+For $N\geq 3$ the expression
+$\lie(x_1,\dots,x_N)$ is defined to be a shorthand notation for
+$\lie(x_1,\lie(x_2,\dots,\lie(x_{N-1},x_N)\dots))$, where
+$x_1,\dots,x_N$ are algebra elements.
+Algebraic list expressions are allowed as nested commutators.
+\endconcl
+
+@*= Simplification of commutators. In the introduction we have already
+explained that the requirements stated above, force us to use a
+simplification function to retrieve values of commutators. We have
+gathered enough material now to outline this simplification function.
+It should be noted that the procedure |simp_liebracket| expects the
+|car| of its argument to be the name of the liebracket. To achieve
+this, the liebracket under consideration must be flagged |full|.
+
+A simplification function, hence also the procedure |simp_liebracket|,
+should return the value of its argument as a standard quotient.
+
+@u
+lisp procedure simp_liebracket val;
+if length val=3 then @<Simplify commutator |val|@>
+else if length val>3 then @<Simplify nested commutator |val|@>
+else rederr("SIMP_LIEBRACKET: wrong number of arguments")$
+
+@ We simplify a commutator as explained in the previous sections. The
+procedure |simp_liebracket_vector| checks if a commutator with two
+integer arguments has a value, or otherwise returns it in canonical
+form. We simplify both arguments before continuing in order to be able
+to recognize negative integer arguments. It is easily verified that
+this has almost no influence on the timings.
+
+@<Simplify commutator |val|@>=
+begin scalar bracketname,arg1,arg2;
+ bracketname:=operator_name_of val;
+ arg1:=mk!*sq simp!* first_argument_of val;
+ arg2:=mk!*sq simp!* second_argument_of val;
+ return
+ if fixp arg1 and fixp arg2 then simp_liebracket_vector(bracketname,arg1,arg2)
+ else @<Simplify |bracketname(arg1,arg2)| using the bilinearity@>;
+end @;
+
+@ To decompose a commutator into its smallest components using the
+bilinearity we will use the procedures of the TOOLS package
+implemented to deal with operators which are multilinear w.r.t.\ some
+specified operators. We recall that this implementation consists of a
+simplification procedure |simp_multilinear| together with a
+resimplification procedure for the smallest constituent parts of the
+operator $O$ under consideration, which name is to be found on the
+property list of $O$ as the property |resimp_fn|. The list of operators
+w.r.t.\ which $O$ is multilinear has to be stored as the property
+|oplist|. Hence essentially it suffices to write an appropriate
+resimplification procedure in our case.
+
+There are, however, a few minor points which have to be taken into
+account. First we allowed sole integers as a shorthand notation for
+generators. To make |simp_multilinear| work properly we have to undo
+this simplification temporarily. The name of this generator is stored
+on the property list of the liebracket as the property |generatorname|.
+Moreover, we allowed algebraic lists to denote nested commutators.
+Since algebraic list are represented by the operator |list|
+internally, this can be dealt with by putting |list| on the |oplist|
+of a liebracket.
+
+@<Simplify |bracketname(arg1,arg2)| using the bilinearity@>=
+simp_multilinear list(bracketname,
+ if fixp arg1 and arg1 neq 0 then list(generatorname,arg1) @+else arg1,
+ if fixp arg2 and arg2 neq 0 then list(generatorname,arg2) @+else arg2)@/
+where generatorname=get(bracketname,'generatorname) @;
+
+@ The resimplification procedure |resimp_liebracket| is rather simple.
+Each of the arguments can be:\medskip
+\item{1.} an integer: since the shorthand notation of generators is
+hidden before simplification, this can only occur if there is an unwanted
+mixing of the full and the shorthand notation for generators. Hence we
+must stop with an error message in this case.
+\item{2.} a generator: we have to strip off the generatorname and
+represent it by its shorthand notation.
+\item{3.} an algebraic list representing a nested commutator: we have
+to replace |list| by the name of the liebracket and simplify the
+whole commutator again.
+\item{4.} any other algebra element: nothing special has to be done.
+\enditem
+The definition |update_argument| takes care of the necessary
+actions. The variable |resimplify| indicates the necessity of
+resimplification due to case 3.\ and should be local to the procedure
+|resimp_liebracket|.
+
+@d update_argument(arg)=@/
+if fixp arg then rederr("SIMP_LIEBRACKET: argument contains a non algebra element")
+else if operator_name_of arg=generatorname then arg:=first_argument_of arg
+else if operator_name_of arg='list then @/
+ <<resimplify:=t;arg:=bracketname . arguments_of arg>> @;
+
+@ If both arguments are generators we have to check the vectorstructure
+for further simplification, otherwise the kvalue list. This is done in
+the procedures |simp_liebracket_vector| and |simp_liebracket_kvalue|,
+respectively.
+
+@u lisp procedure resimp_liebracket val;
+begin scalar bracketname,generatorname,arg1,arg2,resimplify;
+ bracketname:=operator_name_of val;
+ generatorname:=get(bracketname,'generatorname);
+ arg1:=first_argument_of val;arg2:=second_argument_of val;
+ update_argument(arg1);update_argument(arg2);
+ return
+ if resimplify then simp_liebracket list(bracketname,arg1,arg2)
+ else
+ if fixp arg1 and fixp arg2
+ then simp_liebracket_vector(bracketname,arg1,arg2)
+ else simp_liebracket_kvalue(bracketname,arg1,arg2);
+end$
+
+@ Now we have dealt with ordinary commutators satisfactorily, it's
+time to aim our attention to the nested commutators. Notice that we
+have defined an expression like $\lie(\{1,2\},2,3,4)$ to be nothing but
+the expression $\lie(\lie(1,2),\lie(2,\lie(3,4)))$. Since we have already
+treated list expressions as part of ordinary commutators, we only have
+to reverse the list of arguments and compute the commutators
+repeatedly.
+
+@<Simplify nested commutator |val|@>=
+begin scalar bracketname,arguments,result;
+ bracketname:=operator_name_of val;
+ arguments:=reverse arguments_of val;
+ result:=simp_liebracket list(bracketname,second arguments,first arguments);@/
+ arguments:=cddr arguments; %Chop first two arguments%
+ for each arg in arguments do
+ result:=simp_liebracket list(bracketname,arg,mk!*sq result);
+ return result;
+end @;
+
+@*= Storing and retrieving values of commutators. In the following
+sections we will explain how we are planning to store values of
+commutators exactly. We recall that we have to make a clear
+distinction between commutators of two generators, in which case we
+want to store the values in a vector structure, and all other cases,
+for which we want to store the values on the kvalue list.
+
+@ We have seen in one of the previous sections that we have to store
+$\lie(i,j)$ for $-n\leq i\leq j\leq m$, if $lie$ is a liebracket and
+$m$ and $n$ the number even and odd generators, respectively. There
+are a few ways to store the values of these commutators in a vector
+structure:\medskip
+\item{1.} put them all together in one vector and
+supply a procedure to compute the index for a tuple $(i,j)$.
+\item{2.} make a vector of vectors: put for all $i$ the vectors
+containing the values of $\lie(i,j)$ for $i\leq j\leq m$ in a vector.
+\enditem
+The second alternative has the advantage, that it is rather easy to
+compute the indices, but we have to access two vectors to get the
+value of a commutator. For the first alternative the index has a more
+complex structure, but we have only to access one vector. We have
+compiled and tested both alternatives in a REDUCE version built on top
+of Innovus Lisp on a HP9000 series at our site. In this
+configuration the second alternative has proven to be the fastest.
+Therefore we will use this one to store the values of commutators of
+two generators.
+
+The indices of a vector of dimension $N$ run from $0,\dots,N$. Hence
+the dimension of the outer vector structure must be $m+n$, which must
+have for $-n\leq i\leq m$ as value at index $n+i$ the vector of
+dimension $m-i$ containing the values of $\lie(i,j)$ for $i\leq j\leq
+m$. For each $-n\leq i\leq j\leq m$ we can add to the tuple $(i,j)$ a
+couple of indices $(n+i,m-j)$ for the outer and the inner vector,
+respectively. Note that we use the inner vector structure in a
+reverse way to keep the indices as short as possible.
+
+@ We will store the vector structure of a liebracket |bracketname| on
+the property list as the property |vector_structure|. The dimensions
+$m$ and $n$ of a liebracket are stored on the property list as the
+properties |even_dimension| and |odd_dimension|, respectively.
+
+Access to a vector is through the procedures |getv|, to
+get a value, and |putv|, to store a value. One
+should be aware of the fact that |putv| doesn't make a new copy of the
+vector, but replaces the value at the required index directly in the
+physical memory. Therefore it is unnecessary to do a |putv| for the
+outer vector structure when storing a commutator, because a |getv| for
+the outer vector structure will return a vector, which we can change
+directly in the physical memory at the right index with a |putv|.
+
+There is one point which we haven't explained so far, but which
+already has to be used here. Namely, to enable the computation of
+Jacobi identities to be as efficient as possible, it is not enough for
+each commutator just to store its value, but we have to store some
+more information. Moreover, as explained in the introduction, we shall
+also put the information about possible occurences of commutators in
+the vector structure. For ordinary algebraic operators this kind of
+information is recorded on the klist.
+Therefore for each commutator we will store a dotted
+pair of length 3, the |car| being additional information about the
+commutator, the |cadr| being the replacement for the klist mechanism,
+the |cddr| being its value.
+
+Although we won't explain the meaning of the two first items right
+away, it is enough to know here that the additional information must
+be initialized to |nil|. The part meant as the replacement for the klist
+mechanism must must be initialized to |nil|, if it is not present,
+otherwise the old value must be taken.
+
+We think that it is convenient to have procedures both to access the
+entire vector structure as well as just the values of commutators.
+Access to the vector structure is through the macros
+|get_vector_structure| and |put_vector_structure|, access to the
+values of commutators of two generators is through the macros
+|get_commutator| and |put_commutator|, where the last two
+simply use the first two. The procedures don't perform range checking
+on their parameters.
+
+@d informative_part_of=car
+@d k_info_and_commutator_part_of=cdr
+@d k_info_of=cadr
+@d commutator_part_of=cddr
+@d get_vector_structure(bracketname,i,j)=@/
+getv(getv(get(bracketname,'vector_structure),
+ get(bracketname,'odd_dimension)+i),@|
+ get(bracketname,'even_dimension)-j) @;
+@d put_vector_structure(bracketname,i,j,value)=@/
+putv(getv(get(bracketname,'vector_structure),
+ get(bracketname,'odd_dimension)+i),@|
+ get(bracketname,'even_dimension)-j,value) @;
+@d get_commutator(bracketname,i,j)=@/
+(if entry then commutator_part_of entry)
+ where entry=get_vector_structure(bracketname,i,j) @;
+@d put_commutator(bracketname,i,j,value)=@/
+(if old_value then
+ put_vector_structure(bracketname,i,j,nil . (k_info_of old_value) . value)
+ else put_vector_structure(bracketname,i,j,nil . nil . value))
+where old_value=get_vector_structure(bracketname,i,j) @;
+
+@ Before we can write the procedures |simp_liebracket_vector| and
+|simp_liebracket_kvalue| we have to explain how to get the arguments of a
+commutator in a canonical order.
+
+The macro |not_ordered_commutator| checks whether or not
+the arguments of a commutator are well ordered. It uses the standard
+REDUCE procedure |ordp| and is written in such a way that a pair
+$(i,j)$ for $i$,$j$ integer, $i\leq j$ is well ordered.
+
+@d not_ordered_commutator(arg1,arg2)= @/
+(if fixp arg1 and fixp arg2 then arg1>arg2 @+else
+ordp(arg1,arg2) and arg1 neq arg2) @;
+
+@ If the two arguments are not well ordered they must be switched.
+Moreover, if not both arguments are odd a minus sign should be added.
+Therefore we must have a function |even_element| to check if an
+argument is even or not.
+
+We have explained earlier that an argument of a commutator should be
+an integer (namely, the number of the generator), a commutator with
+two arguments, or another algebra element for which we have to check
+the first parameter. Unfortunately, that is not the whole truth. There
+is one exceptional situation for some specific application, which
+should be added: in prolongation theory we will use Lie (super)algebra
+valued functions. So far no problems, but these functions may also be
+differentiated, in which case one will get other algebra elements.
+However, an expression like |df(f(1),x)| doesn't belong in any of the
+classes stated above. We can test if it is even or odd, by testing the
+differentiated function. We add this as a special case.
+
+@u
+lisp procedure even_element(bracketname,exprn);
+ if fixp exprn then exprn>0
+ else if operator_name_of exprn=bracketname then
+ ((b1 and b2) or (not b1 and not b2)) @| where
+ b1=even_element(bracketname,first_argument_of exprn),
+ b2=even_element(bracketname,second_argument_of exprn)
+ else if operator_name_of exprn='df then
+ even_element(bracketname,first_argument_of exprn)
+ else if fixp first_argument_of exprn then
+ first_argument_of exprn>0
+ else stop_with_error("EVEN_ELEMENT: impossible to determine sign of",
+ exprn,nil,nil)$
+
+@ Both in |simp_liebracket_vector| and |simp_liebracket_kvalue| the
+arguments must be ordered canonically, hence we make that part a
+module. Both procedures should have a local variable |sign|,
+indicating if a sign must be added.
+
+@<Order |arg1| and |arg2| canonically and possibly set |sign| to |t|@>=
+if not_ordered_commutator(arg1,arg2) then
+begin scalar h;
+ sign:=(even_element(bracketname,arg1) or even_element(bracketname,arg2));@/
+ h:=arg1;arg1:=arg2;arg2:=h; %Switch |arg1| and |arg2|%
+end @;
+
+@ Once |arg1| and |arg2| are ordered (i.e., |arg1|${}\leq{}$|arg2|), we
+still have to check for integer valued |arg1| and |arg2| that
+$-n\leq{}$|arg1| and |arg2|${}\leq m$, if $m$ and $n$ are the number
+of even and odd generators, respectively.
+
+@<Check if |arg1| and |arg2| are not out of range@>=
+if arg1<-get(bracketname,'odd_dimension) or arg2>get(bracketname,'even_dimension) then
+ stop_with_error("SIMP_LIEBRACKET:",list(bracketname,arg1,arg2),"out of range",nil) @;
+
+@ After the preparations above the implementation of the procedure
+|simp_liebracket_vector| is quite straightforward. If the commutator
+has a value, this value is simplified and returned as a standard
+quotient, otherwise the commutator itself is returned as a standard
+quotient. This last step is done by the standard REDUCE procedure
+|mksq(kernel,pow)|, which returns |kernel| to the power |pow| as a
+standard quotient, but also has a side effect that we will explain in
+due time.
+
+There is, however, one thing, which we should be well aware of.
+Namely, if one of the arguments is zero, the commutator must be zero.
+This can be achieved by initializing both $\lie(i,0)$ for
+$i=-n,\dots,-1$ and $\lie(0,i)$ for $i=0,\dots,m$ to zero. Moreover
+the commutators $\lie(i,i)$ with $i>0$ are zero. Hence these should
+also be initialized to zero. Moreover, as we will explain later on,
+in some cases it will be necessary to resimplify the resulting
+commutator, in order the get a well ordered standard quotient, which
+will be treated in the right way by REDUCE. This case will be treated
+in due time.
+
+@u
+lisp procedure simp_liebracket_vector(bracketname,arg1,arg2);
+begin scalar sign,commutator;
+ @<Order |arg1| ...@>;
+ @<Check if |arg1| and |arg2|...@>;
+ @<Get commutator |bracketname(arg1,arg2)| as a canonical standard quotient@>;
+ return
+ if sign then negsq commutator
+ else commutator;
+end$
+
+@ The kvalue list of an algebraic operator is an association list, the
+|car| of an element of which is a kernel of that operator, the |cadr|
+its value. The kvalue list of an operator is stored on its propery
+list as the property |kvalue|. As already explained, access to an
+association list is through the procedure |assoc|. Knowing this, we
+can write the procedure |simp_liebracket_kvalue| without difficulty.
+
+@u
+lisp procedure simp_liebracket_kvalue(bracketname,arg1,arg2);
+begin scalar sign,commutator;
+ @<Order |arg1| ...@>;
+ commutator:=assoc(list(bracketname,arg1,arg2),get(bracketname,'kvalue));@/
+ commutator:=
+ if commutator then simp cadr commutator
+ else mksq(list(bracketname,arg1,arg2),1);
+ return
+ if sign then negsq commutator
+ else commutator;
+end$
+
+@*= Assignment to commutators. With the simplification
+procedure written above, we are able to retrieve values of
+commutators. As we have explained in the introduction, we need a
+set-element-function |set_liebracket| to assign values to commutators.
+
+This seems to be the appropriate moment to explain how one can assign
+|value| to |kernel|. This is done by calling the procedure
+|setk(kernel,value)|. If |kernel| is of the form $f(a_1,\dots)$,
+where $f$ possesses the property |rtype|, which on its turn possesses a
+property |setelemfn| (the set-element-function for that rtype), the
+assignment is done by this set-element-function. In all other cases
+the procedure |setk1| takes care of it. So to
+make the construction work in our case, we have to declare
+any liebracket to be of rtype |liebracket| and assign to |liebracket| the
+property |setelemfn|.
+
+@ There is, however, one more thing to explain about rtypes:
+commutators should not be recognized as objects of rtype |liebracket|
+since this will lead to type mismatch problems throughout REDUCE. To
+get the rtype of an object REDUCE almost anywhere uses the procedure
+|getrtype|, which, if provided, uses a rtypefn, to determine the rtype
+of an object. Rtypefn's have one argument, which are the arguments of
+the object, if this is not an atom, |nil| otherwise.
+So if we do not want commutators to be recognized as objects of rtype
+|liebracket|, we can simply return |nil| in all cases;
+
+@<Lisp ini...@>=@/
+put('liebracket,'rtypefn,'liebracket_rtypefn)$@/
+put('liebracket,'setelemfn,'set_liebracket)$
+
+@
+@u
+lisp procedure liebracket_rtypefn u;@/ nil$
+
+@ There are, however, some points, which should be taken into
+account, before we can write the procedure. The first of this is,
+that we want commutators only to adopt values which are actually
+algebra elements. Hence we should check this condition if an
+assignment is made.
+
+The most convenient way to check if some expression is is an element
+of the Lie (super)algebra is to use the procedure |independent_part|
+of the TOOLS package. If the variable |algebra_elements| is the list
+of all operators allowed as algebra elements, then the result of
+calling |independent_part(value,algebra_elements)| is the part of
+|value| independent of operator allowed as algebra element, hence for
+a {\it valid\/} algebra element |value| 0.
+
+@<Check if |value| is a valid algebra element@>=
+if independent_part(value,algebra_elements) neq 0 then
+ rederr("SET_LIEBRACKET: assigned value invalid as algebra element") @;
+
+@ We have already explained that it is not necessary or even
+undesirable to assign values to commutators, which can be decomposed
+into smaller components, using the bilinearity. For such an assignment
+will never be used, since the simplification procedure of a liebracket
+actually decomposes a commutator into is smallest components, before
+trying to find any value.
+
+Therefore both arguments of a commutator, which we want to assign a
+value to, either have to be integer (as a shorthand notation for a
+generator), or a single algebra element. If they have the form $x(i)$
+where |x| is the generatorname of liebracket |bracketname|, we must
+strip off the generator, in order to get the commutator in a canonical
+form. Moreover generators should not exceed the maximal number of odd
+or even generators, respectively.
+
+The macro |check_and_strip_argument| checks one argument for its
+validity, using the conditions stated in the previous section.
+Because we have to satisfy a lot of conditions and we don't want the
+procedure merely to exist out of error messages, we use a variable
+|error| to indicate whether an error has occured or not. In this way
+we can do with one error message after all tests. The variable
+|error| has to be local at some higher level. The macro
+|wrong_atomic_argument| checks an atomic argument is an integer and
+lies within the ranges of the liebracket.
+
+@d wrong_atomic_argument(arg)=@/
+((not fixp arg) or arg<-get(bracketname,'odd_dimension)
+ or @| arg>get(bracketname,'even_dimension)) @;
+
+@d check_and_strip_argument(arg)=@/
+if atom arg then error:=wrong_atomic_argument(arg)
+else begin
+ error:=not member(operator_name_of arg,algebra_elements);
+ if not error and operator_name_of arg=generatorname then
+ begin
+ arg:=first_argument_of arg;
+ error:=not atom arg or wrong_atomic_argument(arg);
+ end;
+end @;
+
+@<Prepare and check |arg1| and |arg2|@>=@/
+check_and_strip_argument(arg1);
+if not error then check_and_strip_argument(arg2);
+if error then
+ rederr("SET_/CLEAR_LIEBRACKET: argument(s) invalid or out of range") @;
+
+@ There are a few ``special'' commutators which are initialized to
+zero and should never be changed again. If $\lie$ is a liebracket,
+these commutators are $\lie(i,i)=0$ for all $i>0$ (this follows
+directly from the (graded) skew-symmetry and the fact that $x(i)$ is
+even for $i>0$), $\lie(i,0)$ for $i=-n,\dots,-1$ and $\lie(0,i)$ for
+$i=0,\dots,m$ (this has been explained in one of the previous
+sections). Moreover, if a commutator has been used to solve other
+commutators or generators using the Jacobi identity, it may be
+dangerous to change this commutator. In the first case we must give an
+error message, in the second case a warning will do.
+
+This kind of information is most conveniently recovered from the
+informative part of the vector structure. Without going into detail
+right here, the following module will take care of the point raised
+above. Note that |arg1| and |arg2| need to be we ordered for this check.
+
+@d special=s
+
+@<Check |arg1| and |arg2| for special or dangerous commutators@>=@/
+ error:=@+if fixp arg1 and fixp arg2 then
+ (if entry then informative_part_of entry)
+ where entry=get_vector_structure(bracketname,arg1,arg2);
+ if error then
+ if car error='special then
+ rederr("SET_/CLEAR_LIEBRACKET: commutator can not be changed")
+ else message("SET_/CLEAR_LIEBRACKET: changing",
+ list(bracketname,arg1,arg2),"may lead to errors",nil) @;
+
+@ With the modules written above we can implement the procedure
+|set_liebracket| at once. We |reval| both arguments before
+continuing. This is useful, because the simplification procedure does
+the same. Notice that a set-element-function doesn't need to return a
+value.
+
+@u
+lisp procedure set_liebracket(val,value);
+if length val neq 3 then
+ rederr("SET_LIEBRACKET: assignment only possible to commutators")
+else begin scalar bracketname,generatorname,algebra_elements,arg1,arg2,
+ error,sign;
+ bracketname:=operator_name_of val;
+ generatorname:=get(bracketname,'generatorname);
+ algebra_elements:=bracketname . generatorname . get(bracketname,'algebra_elements);
+ arg1:=reval first_argument_of val;
+ arg2:=reval second_argument_of val;
+ @<Prepare and check |arg1| and |arg2|@>;
+ @<Order |arg1| and |arg2|...@>;
+ @<Check |arg1| and |arg2| for special or dangerous commutators@>;
+ value:=aeval value;
+ @<Check if |value| is a valid algebra element@>;
+ if sign then value:=mk!*sq negsq simp value;
+ @<Store the assignment |bracketname(arg1,arg2):=value@;|@>;
+end$
+
+@ Before we can implement the remaining part of the
+set-element-function of a liebracket, we have to say something about
+the mechanism that controls the reevaluation of algebraic expressions
+in REDUCE, the !*SQ prefixform.
+
+An algebraic expression in !*SQ prefixform is a list of the form
+(|!*sq| {\it standard\_quotient} [|t|$\vert$|nil|]). If the last
+element is |t|, no assignments have taken place after the last
+simplification of the expression, which can affect its value. If it is
+|nil|, the expression may have been affected by some assignment that
+has taken place, so reevaluation is necessary. If reevalutation is
+necessary, it is clear that the |t|'s must be replaced by |nil| for
+all algebraic expressions at a time. At this place it is not necessary
+to explain how this can be accomplished, but it is sufficient to say that
+the call |rmsubs()| does the job properly.
+
+If a kernel has never been used in any other algebraic expression, it
+is clear that it is unnecessary to call |rmsubs| if someone assigns a
+value to this kernel. Therefore, for every kernel REDUCE keeps track
+if it has been used in some other algebraic expression. For atoms this
+is done by flagging them |used!*|, for operator elements it is recorded
+on the so called klist of that operator.
+
+Of course the standard REDUCE procedures respect this mechanism. But
+we took the simplification of and assignment to commutators in our own
+hands. Did we take enough precautions to respect this mechanism? Well,
+a few sections ago, when implementing the simplification function of a
+liebracket, we mentioned, but did not explain a side effect of the
+procedure |mksq| which we used to convert a kernel to a standard
+quotient. This seems to be the right moment to explain that this side
+effect is the recording of the fact that the kernel is used by
+flagging it |used!*| or putting it on the klist.
+
+This partially solves our problem, for if a unknown commutator is used
+in some other algebraic expression it will be simplified by
+|simp_liebracket| which makes it a standard quotient by calling
+|mksq|. On the other hand, as experience showed, for a liebracket of average
+length, the klist may get a length of about 10000 to 20000 elements
+and reduce the performance of the entire system in an quite drastic way.
+
+Therefore we will partially replace the klist mechanism for a
+liebracket by storing the klist information as an additional entry in
+the vector structure, just for those commutators whose
+value is also stored in the vector structure.
+
+In order to make this new construction work it turns out that two
+standard REDUCE procedures have to be adapted. These changes are explained in
+the last section of this document.
+
+@ If we do an assignment to a commutator we must call
+|rmsubs| if necessary. Without going into the matter too deep right
+here, we will simply give a macro definition which checks if an
+operator element is used.
+
+@d used_operator_element(opr_el)=@/
+ 'used!* memq cddr fkern opr_el@;
+
+@ If the two arguments of the commutator which we want to store are
+integers, we must use the vector structure to store it and eventually
+call |rmsubs| ourselves, otherwise it must be stored on the kvalue
+list. In the last case the standard REDUCE procedure |setk1| takes care
+of everything.
+
+@<Store the assignment |brack...@>=
+if fixp arg1 and fixp arg2 then
+begin
+ if used_operator_element(list(bracketname,arg1,arg2)) then rmsubs();
+ put_commutator(bracketname,arg1,arg2,value);
+end else
+ setk1(list(bracketname,arg1,arg2),value,t) @;
+
+@*= Clearing liebrackets. There is one aspect of the access to
+liebrackets and/or commutators which we have left out of sight so far
+deliberately, namely how to clear these objects. Clearing expressions
+and/or operators in REDUCE is done by the procedures |clear| and
+|clear1|, the last one of which does its job by two subsequent calls
+of the procedure |let2| with different parameters.
+
+In earlier versions of this package we used the procedure |clear| to
+clear commutators, but it seemed impossible to use it to clear an
+entire liebracket, because a liebracket isn't just an ordinary rtype.
+The only possibility to let this construction work for commutators,
+was to jump through some procedures in an obscure and illogical way
+and finally let the clearing take place in the simplification
+procedure depending on the flag |subfg!*|. Clearing of an entire
+liebracket was done by a procedure of itself.
+
+In this version we will do the job in a more logical way by changing
+the standard REDUCE procedure |clear| in such a way that the clearing
+of both commutators and liebrackets will take place in a procedure of
+itself. The idea behind this change is quite simple: if the object to
+be cleared is of some rtype which on its turn possesses the property
+|clearfn|, then apply |clearfn| to it, otherwise proceed as before.
+In that way it resembles the procedure |setk|, which uses a
+set-element-function for rtypes.
+
+Note that |clear| has the property |stat='rlis| which means that it
+can have an arbitrary number of arguments separated by commas, which
+the parser will pass to it as a list. Hence also |clear1|, which is
+called by |clear|, will have its argument as one list.
+
+Notice that we can't use |getrtype| to get the rtype of an operator
+element since |getrtype| will, for instance, not recognize a
+commutator to be an element of the rtype liebracket.
+
+@u
+lisp procedure clear1 u;
+ begin scalar x,xx;
+ while u do
+ <<if flagp(x := car u,'share)
+ then if not flagp(x,'reserved) then set(x,x) else rsverr x
+ else if eqcar(x,'list)
+ then u := nil . append(cdr x,cdr u)
+ else if eqcar(x,'replaceby) then rule!-list(list x,nil)
+ else if smemq('!~,x)
+ then if eqcar(x,'equal) then rule!-list(list x,nil)
+ else rule!-list(list list('replaceby,x,nil),nil)
+ else if (xx:=get(if atom x then x @+else car x,'rtype))
+ and (xx:=get(xx,'clearfn))
+ then apply1(xx,x)
+ else @+<<let2(x,nil,nil,nil); let2(x,nil,t,nil)>>;
+ u := cdr u>>
+ end$
+
+@ The clearfn of a liebracket will be the procedure |clear_liebracket|.
+This has to be placed on the property list of |liebracket|.
+
+@<Lisp ini...@>=@/
+ put('liebracket,'clearfn,'clear_liebracket)$
+
+
+@ The procedure |clear_liebracket| is rather simple: if its argument
+is an atom, we have to clear an entire liebracket by removing all its
+properties, otherwise the argument should be a commutator.
+
+@u
+lisp procedure clear_liebracket val;
+if atom val then @<Remove all properties of liebracket |val|@>
+else if length val = 3 then @<Clear commutator |val|@>
+else rederr("CLEAR_LIEBRACKET: wrong number of arguments to commutator")$
+
+
+@ Clearing a commutator is almost the same as assigning |nil| to it.
+Therefore we have to manipulate the arguments in the same way as in
+the procedure |set_liebracket|, except that we need not incorporate a
+possible change of sign. We copy it without comment.
+
+@<Clear commutator |val|@>=
+begin scalar bracketname,generatorname,algebra_elements,arg1,arg2,error,h;
+ bracketname:=operator_name_of val;
+ generatorname:=get(bracketname,'generatorname);
+ algebra_elements:=bracketname . generatorname . get(bracketname,'algebra_elements);
+ arg1:=reval first_argument_of val;
+ arg2:=reval second_argument_of val;
+ @<Prepare and check |arg1| and |arg2|@>;
+ if not_ordered_commutator(arg1,arg2) then
+ begin
+ h:=arg1;arg1:=arg2;arg2:=h; %Switch |arg1| and |arg2|%
+ end;
+ @<Check |arg1| and |arg2| for...@>;
+ @<Clear commutator |bracketname(arg1,arg2)|@>;
+end @;
+
+@ If |arg1| and |arg2| are integers, we have to clear an entry in the
+vector structure, otherwise we have to clear the commutator by
+replacing the kvalue list of |bracketname| by the old kvalue list with
+one entry removed. Note that there is no need to update the !*SQ
+prefixforms by calling |rmsubs|, since the calling procedure |clear|
+has already taken care of that.
+
+@<Clear commutator |bra...@>=@/
+val:=list(bracketname,arg1,arg2);
+if fixp arg1 and fixp arg2 then
+ if get_commutator(bracketname,arg1,arg2) then @|
+ put_commutator(bracketname,arg1,arg2,nil)
+ else message("CLEAR_LIEBRACKET:",val,"not found",nil)
+else begin scalar kvalue;
+ kvalue:=get(bracketname,'kvalue);
+ if (h:=assoc(val,kvalue)) then
+ put(bracketname,'kvalue,delete(h,kvalue))
+ else message("CLEAR_LIEBRACKET:",val,"not found",nil);
+end @;
+
+@*= Tools for solving Jacobi identities. We have gathered
+enough material now to implement one of the main tasks of this
+package, namely the computing and solving of Jacobi identities in
+order to find new relations between commutators and generators. To
+accomplish this, we have to do the following things in succession:
+first we have to find all triples $(i,j,k)$ with $i,j,k$ integer that
+satisfy all conditions such that the Jacobi identity for $x(i)$,
+$x(j)$ and $x(k)$ may lead to a new relation and secondly, for each
+triple $(i,j,k)$ found in the first step, we must compute this Jacobi
+identity and solve it.
+
+\bigskip
+In the sections where we specified the requirements for a
+liebracket, we found that it is interesting to compute and solve the
+Jacobi identities for all $x(i)$, $x(j)$ and $x(k)$ such that all
+three commutators $\lie(i,j)$, $\lie(j,k)$ and $\lie(i,k)$ are a
+linear combination of generators. For these Jacobi identities (may)
+lead to new relations between generators and/or commutators of two
+generators, which are the main object of our interest.
+
+How must we proceed to find all triples $(i,j,k)$ that satisfy the
+conditions stated above? Well, a typical sequence of actions while
+trying to compute (part of) a Lie (super)algebra could be: introduce
+some new generators as names for unknown commutators (i.e., assign the
+generators to these commutators) and try to find new relations implied
+by Jacobi identities containing these commutators. Hence we could
+proceed as follows: first find all ``new'' commutators $\lie(i,j)$
+which are a linear combination of generators (by ``new'' we mean those
+commutators which haven't been processed before). Then, if $\lie(i,j)$
+is such a commutator, $(i,j,k)$ is a triple for which the Jacobi
+identity has to be checked, if both $\lie(i,k)$ and $\lie(j,k)$ are
+linear combinations of generators. It is easily seen that proceeding
+this way one will find all Jacobi identities solvable until that
+stage.
+
+There is one aspect which we haven't explained yet: how do
+we recognize commutators which have already been processed. The
+observant reader will remember that we used the vector structure not
+only to store values of commutators, but also reserved a part for
+additional information about the commutator, initialized to |nil|.
+It is clear that we can use it right here to mark commutators which
+have already been processed.
+
+\bigskip
+There is, however, another purpose for which we will use the
+``informative'' part of the vector structure, namely to indicate if
+the computation of a Jacobi identity can be done more efficiently,
+which is very important because of the large amount of Jacobi
+identities we have to compute. For this look at a characteristic term
+of a Jacobi identity, say $\lie(i,\lie(j,k))$, and suppose that
+$\lie(j,k)=\sum_q a_q*x(q)$, a linear combination of generators. Hence
+we have to compute $\lie(i,\sum_q a_q*x(q))$ or using the bilinearity
+$\sum_q a_q*\lie(i,q)$. Computing this kind of expression by simply
+applying |simp_liebracket| to it, we (have to) use the procedure
+|operator_coeff| to get all $x(q)$'s and $a_q$'s every time we come
+across $\lie(j,k)$.
+
+It would be much more efficient, if the value of $\lie(j,k)$ were
+stored in such a way, that there is no need to use the procedure
+|operator_coeff| to get all $x(q)$'s and $a_q$'s. This can indeed be
+done, if we take advantage of the way how standard forms in REDUCE are
+build up. Using the procedure |get_all_kernels|, described in the
+TOOLS package, and the standard REDUCE procedure |reorder|, it is very
+easy to accomplish that the $x(q)$'s occur as leading variable of (a
+reduced part of) the value of $\lie(j,k)$ and the $a_q$'s as leading
+coefficient.
+
+If $\lie(j,k)$ is a reordered sum of generators and we want to compute
+$\lie(i,\lie(j,k))$ using this reordering, we cannot simplify
+$\lie(j,k)$ during the computation because this would destroy the
+special ordering we imposed. This implies that we should think about
+what to do if we find a linear dependency between some generators and
+solve it for one of them, let's say $x(q)$. For suppose this $x(q)$
+occurs in the value of $\lie(j,k)$, then computing $\lie(i,\lie(j,k))$
+using the reordering, would lead to a term $\lie(i,q)$ which is not
+desirable because of the linear dependency found. A solution to this
+problem would be, if we find a linear dependency and solve it for
+$x(q)$, to assign to all $\lie(i,q)$'s a value according to this
+linear dependency.
+
+The most convenient way to implement this is by making a Lie
+(super)algebra generator a rtype of itself, |algebra_generator|, and
+assigning a set-element-function and a clear function to it, which
+take care of all the necessary actions. Moreover, this offers us the
+possibility do some more checks. For instance, in order to keep the
+solving of Jacobi identities act as we intended, we only want to
+allow assignments to a generator, which are linear combinations of
+other generators. For if we would allow this, we would possibly get
+Jacobi identities, marked as solvable by the process described above,
+containing commutators with non-integer arguments, for which we
+certainly don't want to solve. We will write these procedures in a
+next chapter.
+
+@ In the previous sections we have seen to which purposes we can use
+the informative part of the vector structure. Before describing its
+contents exactly, we will add one other application. Namely, for
+whatever reason, we may want to compute all Jacobi identities again,
+so it must be possible to indicate if all Jacobi identities containing
+some commutator have to be recomputed. Therefore, we can distinguish
+the following three conditions for each commutator:\medskip
+
+\item{1.} the commutator hasn't been reordered and hence hasn't been
+checked until now. This is the initial status for every commutator and
+is indicated by |nil| (we already used this in the procedure
+|put_commutator|).
+
+\item{2.} the commutator has both been reordered and checked. This is
+indicated by |'(t)|.
+
+\item{3.} the commutator has been reordered, but must be
+checked again. This is indicated by |'(nil)|.
+
+\enditem
+If we want to recompute all Jacobi identities for some liebracket,
+|'(t)| has to be replaced by |'(nil)| for each commutator in the
+vector structure of this liebracket, which has already been checked.
+To accomplish this we will use a mechanism similar to the one used for
+!*SQ prefixforms. These are constructed by |cons|'ing
+|'!*sq . @t{\it standard\_quotient}@> . !*sqvar!*|,
+where |!*sqvar!*| is a list |'(t)|. In doing so, the |t| of !*SQ
+prefixforms can be replaced by |nil| {\it globally}, by replacing the
+|car| of |!*sqvar!*| by |nil| with the procedure |rplaca|. This
+construction works because |rplaca(alist,new_car)| doesn't replace the
+|car| of |alist| by making a new copy |new_car . cdr alist|, but
+replaces the |car| in the physical memory.
+
+We will also |cons| a variable |!*jacobi_var!*| with value |'(t)| to
+each reordered commutator in the vectorstructure of a liebracket.
+However, in our case we don't want to replace the |t| by |nil|
+globally, but only for one liebracket at a time. Therefore each
+liebracket should have its own variable |!*jacobi_var!*|. It should be
+placed on the property list of the liebracket under consideration as
+the property |!*jacobi_var!*|.
+
+The procedure |recompute_jacobi_identities_of| takes care of this
+replacement and also puts a new copy of |!*jacobi_var!*| on the
+property list. This procedure should be available in algebraic mode.
+
+We foresee that we have to check if |bracketname| is a liebracket in
+a lot of procedures. In order to be able print an appropriate error
+message we will make definition to deal with it. For convenience we
+will also write a definition which checks the validity of a generator.
+
+@d check_if_bracketname_is_a_liebracket_in(proc)=@/
+ if get(bracketname,'rtype) neq 'liebracket then@|
+ stop_with_error(proc,bracketname,"is not a liebracket",nil) @;
+@d check_if_generatorname_is_a_generator_in(proc)=@/
+ if get(generatorname,'rtype) neq 'algebra_generator then@|
+ stop_with_error(proc,generatorname,"is not an algebra generator",nil) @;
+
+@u
+lisp operator recompute_jacobi_identities_of;
+
+lisp procedure recompute_jacobi_identities_of bracketname;
+begin scalar !*jacobi_var!*;
+ check_if_bracketname_is_a_liebracket_in("RECOMPUTE_JACOBI_IDENTITIES:");
+ !*jacobi_var!*:=get(bracketname,'!*jacobi_var!*);
+ rplaca(!*jacobi_var!*,nil);
+ put(bracketname,'!*jacobi_var!*,list t);
+end$
+
+@*1 Finding the unprocessed commutators. After the introduction above
+we are able to take care of the first part of finding the solvable
+Jacobi identities, namely collecting all commutators which are a sum
+of generators and haven't been processed until now. If we find such a
+commutator we must (a) reorder it in such a way that all generators
+occur in it as leading variables, (b) put it on a list of all
+commutators which have to be processed and (c) mark it processed in
+the vector structure. These three steps are implemented in the
+procedure |find_unprocessed_commutators_of|.
+
+In |find_unprocessed_commutators_of| we need quite a lot of
+properties of the liebracket under consideration. Some of them we have
+already met before, but there are also a few, which need some
+explanation right now.
+
+First of all we will store the list of unprocessed commutators on the
+property list as the property |commutator_list|, in order to keep the
+system as fool proof as possible. Namely, if we would keep this list
+as a local variable in |find_unprocessed_commutators_of| it could be
+destroyed by some user break, while in the vector structure these
+commutators were already marked as being processed. In that way we
+could loose some Jacobi identities.
+Because of the possibility of an user break we must be aware of the fact
+that this list may not be empty. Hence in all cases we must |cons| new
+commutators in front of it.
+
+Secondly we should be aware of the fact that not all commutators have
+to be used. Hence it is useless to check commutators which contain
+unused commutators. The number of used even and odd generators is
+stored on the property list of a liebracket as the properties
+|even_used| and |odd_used| respectively.
+
+The following definition sums up all the properties and variables
+necessary to access the vector structure directly, we can use it in
+several places. The module following it initializes them. Recall that
+we used the letter $m$ for the number of even generators and $n$ for
+odd generators.
+
+@d properties_for_direct_access=@/
+vector_structure,m,m_used,n,n_used
+
+@<Initialize properties for direct access@>=@/
+ vector_structure:=get(bracketname,'vector_structure);@/
+ m:=get(bracketname,'even_dimension);n:=get(bracketname,'odd_dimension);@/
+ m_used:=get(bracketname,'even_used);n_used:=get(bracketname,'odd_used) @;
+
+@ The properties necessary in the procedure
+|find_unprocessed_commutators_of| are listed below. The module
+following it initializes them. The variable |non_generators|
+represents all operators, except the generator, that are allowed as
+algebra element.
+
+@d necessary_properties_for_finding_commutators=@;@/
+properties_for_direct_access,generatorname,non_generators,
+commutator_list,!*jacobi_var!*
+
+@<Get all necessary properties for finding commutators@>=
+ @<Initialize properties for direct access@>;
+ generatorname:=get(bracketname,'generatorname);@/
+ non_generators:=bracketname . get(bracketname,'algebra_elements);@/
+ commutator_list:=get(bracketname,'commutator_list);@/
+ !*jacobi_var!*:=get(bracketname,'!*jacobi_var!*) @;
+
+@ The procedure |find_unprocessed_commutators_of| is quite
+straightforward. Note that we don't make an exception for the
+``special'' commutators |bracketname(i,j)| with $i=0$ or $j=0$ or
+$i=j>0$. Of course we don't want these commutators to be processed any
+further. This means that they must be initialized as already being
+processed.
+
+Also another category of commutators need not be processed, namely the
+commutators of generators which have been found linear dependent.
+Checking of Jacobi identities for linear dependent generators boils
+down to checking a linear combination of Jacobi identities for linear
+independent generators. Thus we shouldn't mark commutators of linear
+dependent generators as processed.
+
+Recall that the data of commutator |bracketname(i,j)| are stored in
+the vector structure at indices $n+i$ and $m-j$ for the outer and
+inner vector, respectively.
+
+@u
+lisp procedure find_unprocessed_commutators_of bracketname;
+begin scalar vector_i,entry_i_j,k_info_i_j,commutator,form,kord!*,
+ necessary_properties_for_finding_commutators,comm_list_i,
+ dependent_generators;
+ @<Get all necessary properties for finding com...@>;
+ @<Find the |dependent_generators|@>;
+ for i:=-n_used:m_used do
+ if not memq(i,dependent_generators) then
+ begin
+ vector_i:=getv(vector_structure,n+i);
+ for j:=i:m_used do
+ if not memq(j,dependent_generators) then @|
+ @<Mark |bracketname(i,j)| processed, if it is a sum of generators@>;
+ end;
+ return commutator_list;
+end$
+
+@ Finding the dependent generators can be easily done using the kvalue
+list of |generatorname|. Of course we only need to store the index of
+each dependent generator.
+
+@<Find the |dependent_generators|@>=
+dependent_generators:=
+ for each entry in get(generatorname,'kvalue) collect
+ first_argument_of first_element_of entry
+
+@ An entry in the vector structure consists of a informative part (the
+|car|) and the klist and commutator part (the |cdr|). The following
+definitions translate some conditions of the informative part (which
+we have defined in one of the previous sections) into their lisp
+equivalents.
+
+@d not_processed=null car
+@d recomputation_necessary_for=null caar
+
+@ A standard form belonging to an algebra element is a sum of
+generators, if it contains no kernels of all other operators allowed
+as algebra elements. We can check this most conveniently by using the
+procedure |get_all_kernels|, which acts on standard forms and is
+described in the TOOLS package. Recall that the variable
+|non_generators| is the list of all operators other then the
+generator, allowed as algebra element.
+
+@d sum_of_generators(algebra_element)=@/
+ null get_all_kernels(algebra_element,non_generators) @;
+
+@ If a commutator is a sum of generators the following things should
+be done:\medskip
+\item{1.} it has to be reordered in such a way that all generators
+occur as leading variables of (a reduced part of) it. One should
+remember that reordering in REDUCE is done by the procedure |reorder|,
+which works on standard forms (this is described in more detail in the
+TOOLS package). Note that we rebinded the fluid system variable
+|kord!*| in the procedure |find_unprocessed_commutators_of|. In doing
+so the kernel ordering outside this procedure will not be affected.
+The definition |convert_form_into_reordered_commutator| takes care of
+the reordering.
+
+\item{2.} the commutator list must be updated. We store the indices
+$i$ and $j$ on it, since these contain all the necessary information.
+We will, however, use an association list on $i$, i.e., the smallest
+index, to store $i$ and $j$, because the number of commutators to be
+processed may be rather big. To keep the system fool proof we put the
+updated commutator list on the property list of the liebracket for
+each commutator separately. This part is taken care of by the
+definition |update_commutator_list|. Notice the use of |rplacd| to
+replace the |cdr| of nested lists. It is easily checked that this
+causes no harm. Due to the use of |rplacd| we do not have to store
+|commutator_list| on the property list of |bracketname|. If there is,
+however, no entry on |commutator_list| for $i$, we have to extend
+|commutator_list| with it and do store it.
+
+\item{3.} the entry in the vector structure has to marked as checked.
+This can be done by storing |!*jacobi_var!* . k_info_i_j . commutator|
+at the right place in the inner vector, where |k_info_i_j| is the
+|k_info| value of the $(i,j)$-th entry of the vector structure. The definition
+|mark_entry_as_checked| takes care of it.
+
+@d convert_form_into_reordered_commutator=@/
+ setkorder get_all_kernels(form,generatorname);@/
+ commutator:=!*ff2a(reorder form,denr commutator) @;
+@d update_commutator_list=@/
+ if (comm_list_i:=assoc(i,commutator_list)) then@/
+ (if not member(j,comm_list_i) then
+ rplacd(comm_list_i,j . cdr comm_list_i))
+ else @+
+ <<commutator_list:=list(i,j) . commutator_list;
+ put(bracketname,'commutator_list,commutator_list)>> @;
+@d mark_entry_as_checked=@/
+ putv(vector_i,m-j,!*jacobi_var!* . k_info_i_j . commutator) @;
+
+@ If a commutator has not been checked so far, we should only process
+it now, if it is a sum of generators. Commutators, for which
+recomputation is necessary, don't have to be reordered, since this has
+already been done the first time they were checked.
+
+@<Mark |brac...@>=
+begin
+entry_i_j:=getv(vector_i,m-j);
+if entry_i_j and commutator_part_of entry_i_j then
+ if not_processed entry_i_j then
+ begin
+ commutator:=simp!* commutator_part_of entry_i_j;
+ k_info_i_j:=k_info_of entry_i_j;
+ form:=numr commutator;
+ if sum_of_generators(form) then begin
+ convert_form_into_reordered_commutator;
+ update_commutator_list;
+ mark_entry_as_checked;
+ end;
+ end
+ else if recomputation_necessary_for entry_i_j then begin
+ commutator:=commutator_part_of entry_i_j;
+ k_info_i_j:=k_info_of entry_i_j;@/
+ update_commutator_list;
+ mark_entry_as_checked;
+ end;
+end @;
+
+@*1 Finding the unsolved Jacobi identities. With help of the procedure
+described above we have found a list of unprocessed commutators and
+put it on the property list of the liebracket under consideration. Our
+next task is for each commutator on this list to find the unsolved
+Jacobi identities belonging to it. If $(i,j)$ is a couple of indices
+of the commutator list, the solvable Jacobi identities are represented
+by all triples $(i,j,k)$ for which both |bracketname(i,k)| and
+|bracketname(j,k)| are a sum of generators, i.e., are marked as
+processed in the vector structure.
+
+It is easy to see that the (graded) Jacobi identity
+ $$(-1)^{\vert x\vert\cdot\vert z\vert }[x,[y,z]]+
+ (-1)^{\vert y\vert \cdot\vert x\vert}[y,[z,x]]+
+ (-1)^{\vert z\vert \cdot\vert y\vert }[z,[x,y]]=0$$
+in case of equality of some of the elements $x$, $y$ and $z$ sometimes
+is fulfilled automatically, depending if $x$, $y$ and $z$ are odd or
+even. If we want to compute Jacobi identities for $x(i)$, $x(j)$ and
+$x(k)$ with $i\leq j\leq k$ the reader should check that only the
+following ranges for $i$, $j$ and $k$ give rise to meaningful
+identities (i.e., identities which are not fulfilled automatically):
+(1) $i\leq j\leq k < 0$, (2) $i\leq j <0<k$, (3) $i<0<j<k$ and (4)
+$0<i<j<k$. Moreover it is easily seen that these conditions are
+satisfied if and only if none of the commutators $\lie(i,j)$,
+$\lie(i,k)$ and $\lie(j,k)$ is one of the ``special'' commutators
+$\lie(p,q)$ with $p=0$ or $q=0$ or $p=q>0$. We recall that we
+expected these ``special'' commutators to be initialized to zero and
+to be marked as processed. Now the condition ``marked as processed''
+only means that the informative part of an entry in the vector
+structure is a list whose |car| is |t| (i.e., has a value) or |nil|
+(i.e., has no value), indicating whether or not recomputation of
+Jacobi identities for this commutator is necessary. In the light of
+what we have said in this section it seems not a bad idea to mark
+these ``special'' commutators as special. We can do this by
+initializing the informative part of an entry in the vector structure
+to |'(special)|. One can easily check that this does not affect the
+condition ``marked as processed''.
+
+Hence if we have to find all meaningful triples $(i,j,k)$ belonging to
+an unprocessed commutator represented by the couple $(i,j)$ with
+$i\leq j$, we have to check the commutators (1) |bracketname(k,i)| and
+|bracketname(k,j)| for $-n_{\rm used}\leq k\leq i-1$, (2)
+|bracketname(i,k)| and |bracketname(k,j)| for $i\leq k\leq j-1$ and
+(3) |bracketname(i,k)| and |bracketname(j,k)| for $j\leq k\leq m_{\rm
+used}$ to be marked as processed, but not special, where $m_{\rm
+used}$ and $n_{\rm used}$ are the number of even and odd generators
+which have been used so far. The macro |processed_but_not_special|
+checks this for an entry of the vectorstructure.
+
+@d processed_but_not_special(entry)=@/
+ (car entry and caar entry neq 'special) @;
+
+@ As in the case of finding the unprocessed commutators we will store
+the list of solvable Jacobi identities on the property list of the
+liebracket under consideration as the property |identity_list|.
+In this section we will initialize all necessary properties for
+finding Jacobi identities.
+
+@d necessary_properties_for_finding_identities=@/
+properties_for_direct_access,commutator_list,identity_list
+
+@<Get all necessary properties for finding identities@>=
+ @<Initialize properties for direct access@>;
+ commutator_list:=get(bracketname,'commutator_list);@/
+ identity_list:=get(bracketname,'identity_list) @;
+
+@ If a Jacobi identity $(i,j,k)$ is solvable, depends on the $(i,k)$-th
+and $(j,k)$-th entry of the vector structure and it has only to be stored
+if it has not been stored before. These conditions are checked by the
+definition |check_and_store_identity|. Its argument is a triple
+$i,j,k$ with $i\leq j\leq k$.
+
+We will store the Jacobi identities to be solved on a double
+association list |identity_list|, as the number of them may increase
+very rapidly, in which case linear search would be too time consuming.
+Storing a Jacobi identity on |identity_list| is taken care of by the
+macro |update_identity_list|.
+
+@d check_and_store_identity(i,j,k)=@/
+ if processed_but_not_special(entry_i_k) and
+ processed_but_not_special(entry_j_k)
+ then update_identity_list(i,j,k) @;
+@d update_identity_list(i,j,k)=@/
+ if (id_list_i:=assoc(i,identity_list)) then
+ if (id_list_i_j:=assoc(j,cdr id_list_i)) then @/
+ (if not member(k,cdr id_list_i_j) then
+ rplacd(id_list_i_j,k . cdr id_list_i_j))
+ else rplacd(id_list_i,list(j,k) . cdr id_list_i)
+ else identity_list:=list(i,list(j,k)) . identity_list @;
+
+@ The procedure |find_Jacobi_identities_of| essentially consists of a
+double |while| loop in which we try to find solvable Jacobi identities for
+each commutator on the |commutator_list| of a liebracket. Commutators
+which have been checked may be removed from the |commutator_list|.
+As in |find_unprocessed_commutators_of| we will use |rplacd| to alter
+the inner lists of |commutator_list|.
+
+@u
+lisp procedure find_Jacobi_identities_of bracketname;
+begin scalar comm_list_i,i,j,vector_i,vector_j,vector_k,
+ entry_i_k,entry_j_k,
+ necessary_properties_for_finding_identities,
+ id_list_i,id_list_i_j;
+ @<Get all necessary properties for finding id...@>;
+ while commutator_list do begin
+ comm_list_i:=first_element_of commutator_list;
+ i:=car comm_list_i;
+ while cdr comm_list_i do begin
+ j:=cadr comm_list_i;
+ @<Find and store all Jacobi identities for |i| and |j|@>;
+ rplacd(comm_list_i,cddr comm_list_i);
+ end;
+ commutator_list:=rest_of commutator_list;@/
+ put(bracketname,'commutator_list,commutator_list);
+ end;
+return identity_list;
+end$
+
+@ Finding and storing all Jacobi identity for a couple $i,j$ consists
+of three phases which differ in the way they get the $(i,k)$-th
+and $(j,k)$-th entry of the vector structure. After we
+have found all identities belonging to $i,j$ we must save the updated
+|identity_list| on the property list of the liebracket under
+consideration. Saving it once for a commutator pair $i,j$ will do
+since at this stage the commutator pair has not been removed from
+the commutator list yet.
+
+@<Find and store all ...@>=@/
+vector_i:=getv(vector_structure,n+i);
+vector_j:=getv(vector_structure,n+j);
+for k:=-n_used:i-1 do begin
+ vector_k:=getv(vector_structure,n+k);
+ if (entry_i_k:=getv(vector_k,m-i)) and (entry_j_k:=getv(vector_k,m-j)) then
+ check_and_store_identity(k,i,j);
+end;
+for k:=i:j-1 do begin
+ vector_k:=getv(vector_structure,n+k);
+ if (entry_i_k:=getv(vector_i,m-k)) and (entry_j_k:=getv(vector_k,m-j)) then
+ check_and_store_identity(i,k,j);
+end;
+for k:=j:m_used do begin
+ if (entry_i_k:=getv(vector_i,m-k)) and (entry_j_k:=getv(vector_j,m-k)) then
+ check_and_store_identity(i,j,k);
+end;@/
+put(bracketname,'identity_list,identity_list) @;
+
+@*1 Computing special Jacobi identities. The procedures developed so
+far supplied us with a list of triples $(i,j,k)$ with $i\leq j\leq k$
+such that all three commutators $\lie(i,j)$, $\lie(i,k)$ and
+$\lie(j,k)$ are linear combinations of generators and are stored in a
+reordered form, which facilitates a fast computation of the nested
+commutators of the Jacobi identity for $x(i)$, $x(j)$ and $x(k)$. In
+the following sections we will write the procedure
+|special_Jacobi_identity| that performs the next step, namely the
+actual computation of a Jacobi identity for a triple $(i,j,k)$
+satisfying the requirements stated above.
+
+To explain the idea behind the calculation of the Jacobi identity,
+suppose we have a triple $i,j,k$ as stated above. Then by assumption
+we have $\lie(j,k)=\sum a^l_{jk}x(l)$ so that
+$\lie(i,\lie(j,k))=\sum a^l_{jk}\lie(i,l)$. Now the right hand side of
+the last expression can be computed rather easily by using the
+reordering imposed on the commutator $\lie(j,k)$ as we will see in
+the sequel. One should be aware that is not possible to simplify the
+expression for $\lie(j,k)$ before using it, because this will destroy
+the reordering. Therefore we have to take into account the following
+points:\medskip
+\item{1.} In case one of the generators $x(l)$ has been found linear
+dependent of other generators, we must see to it that $\lie(i,l)$
+evaluates to the right value. As we have already explained this will
+be taken care of by the set-element-function for generators.
+\item{2.} The coefficient $a^l_{jk}$ must be simplified before usage.
+\item{3.} $\sum a^l_{jk}\lie(i,l)$ must be evaluated to the right
+value, i.e., we must take care that substitutions for products and
+powers take place properly. This can be achieved by calling the
+standard REDUCE procedure |subs2| on the simplified expression. A
+search for substitution of powers is only performed if the fluid
+system variable |!*sub2| is set to |t|. If necessary this is done
+automatically by low level procedures used during ordinary
+simplification, depending if a kernel in the simplified expression
+occurs on the list of power substitutions, |powlis!*|. After a call of
+|subs2| |!*sub2| will always be |nil|, so that it can be used for the
+next expression to be simplified. |!*sub2| also occurs on the so
+called |initl| of REDUCE. Variables occuring on the |initl| are
+initialized to an initial value before every command.
+
+@ The procedure |sub_identity| calculates a general term
+$(-1)^{\vert x(i)\vert\cdot\vert x(k)\vert}\lie(i,\lie(j,k))$ of the
+Jacobi identity using the method described above. To achieve this we
+must use the numerator of $\lie(j,k)$ (which is a standard form) to
+add up all terms of $\lie(i,\lie(j,k))$. If $\lie(j,k)$ is zero,
+|sub_identity| also is zero, otherwise by assumption the main variable
+|mvar| of the numerator of $\lie(j,k)$ is a generator, the leading
+coefficient |lc| its coefficient. The same applies to the reductum
+|red| of the standard form. Therefore the summation can simply be
+performed in a |while| loop. Standard quotients can be added,
+subtracted, multiplied and divided by the procedures |addsq|,
+|subtrsq|, |multsq| and |quotsq| respectively.
+
+To simplify the coefficients we can use the procedure |subf1| which
+simplifies a standard form to a standard quotient. Its first argument
+is the standard form to be simplified, the second argument a list of
+substitutions to be performed (in our case |nil|).
+
+Recall that the commutators are stored as !*SQ prefixforms. To get the
+unsimplified standard quotient of a !*SQ prefixform we should simply
+take its |cadr|.
+
+@d simp_sf_to_sq(sf)=subf1(sf,nil)@;
+@d get_sq_of=cadr
+
+@u
+lisp procedure sub_identity(bracketname,i,j,k);
+begin scalar comm_j_k,denr_j_k,coeff_l,l,comm_i_l,term;
+comm_j_k:=get_commutator(bracketname,j,k);
+return if comm_j_k= 0 then nil . 1 else
+begin
+ comm_j_k:=get_sq_of comm_j_k;
+ denr_j_k:=simp_sf_to_sq(denr comm_j_k);
+ comm_j_k:=numr comm_j_k;
+ @<Add all terms of $\lie(i,|comm_j_k|)$ up to |term|@>;
+ if i<0 and k<0 then term:=negsq term;
+ @+%Add a sign if $x(i)$ and $x(k)$ are odd%
+ return quotsq(term,denr_j_k);
+end;
+end$
+
+@ One should notice that we don't check during the assignment to a
+commutator if all generators occuring in the assigned value are valid.
+Since the call of |simp_liebracket_vector| checks the validity of
+integer arguments of a commutator, we only have to check if the
+generators occuring have integer arguments here.
+
+@<Add all terms of $\lie(i,|comm_j_k|)$ up to |term|@>=
+ term:=nil . 1; %Initialize |term| as standard quotient%
+ while comm_j_k do begin
+ l:=first_argument_of mvar comm_j_k;
+ coeff_l:=simp_sf_to_sq(lc comm_j_k);
+ if not fixp l then
+ stop_with_error("SOLVE_JACOBI_IDENTITIES:",list(bracketname,j,k),
+ "contains invalid generator",mvar comm_j_k);
+ comm_i_l:=simp_liebracket_vector(bracketname,i,l);
+ term:=addsq(term,multsq(coeff_l,comm_i_l));
+ comm_j_k:=red comm_j_k;
+ end @;
+
+@ The procedure |special_Jacobi_identity| can now be written at once. We add
+an additional minus sign because in most cases this will neutralize a
+minus sign in the output. Since |sub_identity| expects its arguments
+to be ordered, we have to switch |k| and |i| and the second term. This
+gives an additional sign $(-1)^{1+\vert i\vert\cdot\vert j\vert+
+\vert i\vert\cdot\vert k\vert+\vert j\vert\cdot\vert k\vert}$, i.e.,
+if $j>0$ an additional minus has to be added.
+
+@u
+lisp procedure special_Jacobi_identity(bracketname,i,j,k);
+mk!*sq subs2 negsq
+ addsq(sub_identity(bracketname,i,j,k),@|
+ addsq(multsq((if j>0 then -1 @+else 1) . 1,
+ sub_identity(bracketname,j,i,k)),@|
+ sub_identity(bracketname,k,i,j)))$
+
+@*1 Updating the vector structure. From the last sections it may have
+become clear that until now it is impossible to update (i.e., store
+the simplified values of) the entries of the vector structure without
+deleting all additional information, since the set-element-function of
+a liebracket initializes the additional information to |nil|. As a
+consequence of this, updating the vector structure implies
+recomputation of all Jacobi identities. The procedure
+|update_vector_structure_of| does a better job.
+
+@u
+lisp operator update_vector_structure_of;
+lisp procedure update_vector_structure_of bracketname;
+begin scalar vector_i,entry_i_j,
+ commutator,form,kord!*,generatorname,properties_for_direct_access;
+ @<Initialize prop...@>;
+ generatorname:=get(bracketname,'generatorname);
+ for i:=-n_used:m_used do begin
+ vector_i:=getv(vector_structure,n+i);
+ for j:=i:m_used do begin
+ entry_i_j:=getv(vector_i,m-j);
+ @<If necessary update |entry_i_j|@>;
+ end;
+ end;
+end$
+
+@ Updating an entry is necessary if it has a value, if it is not processed
+or if it is processed but not special. In the last case we must take
+care of the proper reordering.
+
+@<If necessary update |entry_i_j|@>=
+if entry_i_j and commutator_part_of entry_i_j then
+ if not_processed entry_i_j then@|
+ putv(vector_i,m-j,nil . k_info_of(entry_i_j) .
+ aeval commutator_part_of entry_i_j)
+ else if processed_but_not_special(entry_i_j) then begin
+ commutator:=simp!* commutator_part_of entry_i_j;@/
+ form:=numr commutator;
+ convert_form_into_reordered_commutator;
+ putv(vector_i,m-j,informative_part_of(entry_i_j) .
+ k_info_of(entry_i_j) . commutator);
+ end @;
+
+@ As promised in the section where we implemented the simplification
+procedure of a liebracket, we will now explain how a (known)
+commutator of two generators has to be simplified exactly. Namely, if
+the value of a commutator is a sum of generators, the internal
+ordering of the standard quotient in the vector structure representing
+the commutator may be different from the default kernel ordering used
+in REDUCE, because of the reordering we performed intended for the
+efficient computation of Jacobi identities. Since differences in
+ordering may lead to unexpected results (e.g. zero expressions which
+are not represented by 0), we must see to it that we restore the right
+ordering of the standard quotient before returning any commutator.
+
+It is easily checked that reordering is necessary if and only if the
+condition |processed_but_not_special| is true. The ordinary ordering can
+be restored by applying |resimp| on the standard quotient part of the
+commutator. In all other cases if is sufficient just to apply |simp|
+to the commutator. The difference between both methods is the
+following: using the second method the standard quotient will be
+returned unchanged if the |cadr| of the !*SQ prefix form is |t| and
+simplified if |nil|. The first method, however, will always simplify
+and hence reorder the standard quotient before returning it.
+
+@<Get commutator |bracketname(arg1,arg2)| as...@>=@/
+ commutator:=get_vector_structure(bracketname,arg1,arg2);@/
+ commutator:=
+ if commutator and commutator_part_of commutator then
+ if processed_but_not_special(commutator) then
+ if commutator_part_of commutator=0 then nil . 1
+ else resimp get_sq_of commutator_part_of commutator
+ else simp commutator_part_of commutator
+ else mksq(list(bracketname,arg1,arg2),1) @;
+
+
+@*= Analysis of relations in Lie superalgebras. If we have a relation
+in a Lie superalgebra we have a few possibilities to solve it:\medskip
+\item{1.} The relation contains a commutator, for which we can solve
+the relation.
+\item{2.} The relation contains only generators, we have found a
+linear dependency which we can solve.
+\item{3.} The defining relations of the Lie superalgebra contained
+some parameters, which also occur in the relation to solve. In this
+case we can proceed as in case 1.\ and 2., but more carefully. For
+instance, suppose that we have found the relation
+$a(1)*\lie(1,2)+a(2)*x(1)+x(2)=0$. Then it is dangerous simply to
+solve for $\lie(1,2)$ because $a(1)$ eventually may become 0, in which
+case the relation becomes a linear dependency between $x(1)$ and
+$x(2)$. Also a relation like $(a(1)-1)*x(1)+a(2)*x(2)=0$ can be
+solved in two ways: we can put $a(1)=1$ and $a(2)=0$ or solve the
+linear dependency in case $a(1)\neq 1$ or $a(2)\neq 0$.
+\enditem
+To be able to recognize these parameters we will add to each
+liebracket the property |parameters|, which is an operator, elements of
+which may occur as parameters of the Lie superalgebra.
+
+@ To keep the computations as compact as possible we will suppose that
+any relation $R$ to be solved is a sum of generators and commutators
+of two generators. Taking into account the points raised above we can
+deduce the following strategy for finding a solution of a relation:
+\medskip
+\item{1.} If the relation contains at least one commutator whose
+coefficient does not depend on a parameter, choose one and solve for
+it.
+\item{2.} If the relation contains commutators, but all possessing
+coefficients depending on parameters, do not solve the relation.
+\item{3.} If the relation does not contain commutators, but at least
+one generator whose coefficient does not depend on a parameter, choose
+one and solve for it.
+\item{4.} If the relation does not contain commutators and all
+generators have coefficients depending on parameters, try solve the
+relation by solving the set of coefficients regarded as a linear set
+of equations in an appropriate set of parameters.
+\enditem
+These tasks can most conveniently be performed by using the procedures
+|operator_coeff|, for finding all generators with their corresponding
+coefficients, and |solvable_kernels| from the TOOLS package.
+The procedure |operator_coeff| has already been used and described
+before.
+
+The call |solvable_kernels(exprn,k_oplist,c_oplist)| will
+return an algebraic list of kernels |x| from operators occuring on
+|k_oplist|, such that |x| occurs linearly in |exprn| and the
+coefficient of |x| does not depend on any operator occuring on
+|c_oplist|. From this it is clear that |solvable_kernels| can
+be fruitfully used in step 1, 2 and 4.
+
+The process described above will be performed by the procedure
+|relation_analysis|. It returns either the kernel for which the
+relation is solved or |'unsolvable| or |'nested_commutator| if the
+relation for whatever reason is not solvable or contains nested
+commutators.
+
+@d zero_list= '(list 0)@; %List returned by |operator_coeff| applied
+to 0%
+
+@u lisp operator relation_analysis;
+lisp procedure relation_analysis(relation,bracketname);
+begin scalar generatorname,parameters,kernel_list,solvable_kernels,
+ test,kernel,optimal_kernel,coefficient,clear_list;
+ check_if_bracketname_is_a_liebracket_in("RELATION_ANALYSIS:");
+ generatorname:=get(bracketname,'generatorname);
+ parameters:=get(bracketname,'parameters);@/
+ kernel_list:=operator_coeff(relation,generatorname);
+ return
+ if kernel_list=zero_list then 0
+ else if independent_part_of kernel_list neq 0 then
+ @<Solve |relation| for a commutator@>
+ else @<Solve |relation| for a generator or parameters@>;
+end$
+
+@*1 Solving relations for a commutator. To solve |relation| for a
+commutator we must first find out if there are commutators whose
+coefficients do not contain parameters. This is performed by calling
+|solvable_kernels|. If there are any we have to choose one and solve
+for it.
+
+@<Solve |relation| for a com...@>=
+begin@/
+solvable_kernels:=skip_list solvable_kernels(independent_part_of
+ kernel_list,bracketname,parameters);
+return
+if null solvable_kernels then 'unsolvable
+else begin
+ @<Find the optimal commutator |optimal_kernel| for which to solve@>;
+ return
+ if optimal_kernel then@+
+ <<linear_solve_and_assign(relation,optimal_kernel);optimal_kernel>>
+ else 'nested_commutator;
+end;
+end
+
+@ The main problem in solving a commutator from a relation, is
+choosing the most appropriate one to solve. We adopt the idea here
+that the grading of a liebracket will possess all necessary
+information. For instance, if one of the components of the grading is
+the length of the words in the Lie algebra, it is natural to solve for
+the longest word. In this view, if a Lie algebra only possesses a zero
+grading it doesn't matter for which commutator to solve.
+
+If a liebracket possesses a multigrading we will assume that the first
+component is the most important one. This means that we will first
+compare the first components and will only use the further components
+if these are equal.
+
+The basic procedure needed for this purpose is |first_degree_higher|
+which returns |t| if the first degree is higher than the second one.
+
+@u
+lisp procedure first_degree_higher(degree_1,degree_2);
+if null degree_1 then nil
+else if car degree_1>car degree_2 then t
+else first_degree_higher(cdr degree_1,cdr degree_2)$
+
+@ In case two commutators have the same degree the above procedure
+will not give a unique choice independent of the ordering currently
+used in REDUCE. However, in order to guarantee an unique choice, we
+shall add the indices of the commutator to the degree.
+
+@u
+lisp procedure extended_commutator_degree(commutator,bracketname);
+nconc(add_degrees(get_permuted_degree(bracketname,i),
+ get_permuted_degree(bracketname,j)),@|
+ list(i,j)) @/
+where i=first_argument_of commutator, j=second_argument_of commutator$
+
+
+@ In case we have to compare two generators we assume the these will
+both be odd or even. Since in case of solving it is most natural to
+solve for the generator with the highest number we shall add the
+absolute value of the generator number to the degree list.
+
+@u
+lisp procedure extended_generator_degree(generator,bracketname);
+append(get_permuted_degree(bracketname,i),list abs(i)) @/
+where i=first_argument_of generator$
+
+@ Getting the highest of two degrees is fairly simple now. We should
+only be aware that in the application below the second degree may not
+be a list (if there is no second element for which we have to compare
+the degrees). In this case we should simply return the first degree.
+
+@u
+lisp procedure highest_degree(degree_1,degree_2);
+if atom degree_2 then degree_1
+else if first_degree_higher(degree_1,degree_2) then degree_1
+else degree_2$
+
+@ In the code below the variable |optimal_kernel| will be a dotted
+pair containing the present highest degree and the present optimal
+kernel, until the last line.
+
+We will not solve the relation if it contains a nested commutator. In
+this case we set |optimal_kernel| to |nil . nil|.
+
+@<Find the optimal commutator ...@>=@/
+ optimal_kernel:= 0 . nil;
+ while solvable_kernels and car optimal_kernel do begin
+ kernel:=first_element_of solvable_kernels;
+ if not fixp first_argument_of kernel or
+ not fixp second_argument_of kernel then optimal_kernel:=nil . nil
+ else
+ if not ((test:=highest_degree(extended_commutator_degree(kernel,bracketname),
+ car optimal_kernel)) eq car optimal_kernel) then
+ optimal_kernel:=test . kernel;
+ solvable_kernels:=rest_of solvable_kernels;
+ end;@/
+ optimal_kernel:=cdr optimal_kernel @;
+
+@*1 Solving relations for a generator or parameters. If |relation|
+does not contain commutators we have to find out if there are
+generators without parameter coefficients. If so we have a linear
+dependency to be solved w.r.t. generator which is optimal in some
+sense, otherwise we may try to solve the relation by appropriately
+solving parameters.
+
+@<Solve |relation| for a gen...@>=
+begin@/
+solvable_kernels:=skip_list
+ solvable_kernels(relation,generatorname,parameters);
+return
+if null solvable_kernels then
+ @<Solve |relation| by appropiately solving parameters@>
+else
+ begin
+ @<Find the optimal generator |optimal_kernel| for which to solve@>;
+ return
+ if optimal_kernel then@+
+ <<linear_solve_and_assign(relation,optimal_kernel);optimal_kernel>>
+ else 'invalid_generator;
+ end;
+end @;
+
+@
+@<Find the optimal gene...@>=@/
+ optimal_kernel:= 0 . nil;
+ while solvable_kernels and car optimal_kernel do begin
+ kernel:=first_element_of solvable_kernels;
+ if not fixp first_argument_of kernel then
+ optimal_kernel:=nil . nil
+ else
+ if not ((test:=highest_degree(extended_generator_degree(kernel,bracketname),
+ car optimal_kernel)) eq car optimal_kernel) then
+ optimal_kernel:=test . kernel; @/
+ solvable_kernels:=rest_of solvable_kernels;
+ end;@/
+ optimal_kernel:=cdr optimal_kernel @;
+
+@ Solving parameters boils down to the following actions to be taken
+for each |coefficient| of a generator occuring on |kernel_list|, the
+list of generators and their coefficients:\medskip
+\item{1.} If |coefficient| contains some solvable parameters (i.e.,
+occuring linearly in it), choose the first one, solve |coefficient|
+w.r.t. this parameter and put it on |clear_list|. Searching for
+solvable parameters can be performed by applying |solvable_kernels|
+with appropriate arguments.
+\item{2.} If a |coefficient| does not contain a solvable parameter, we
+have to clear all the parameters occuring on |clear_list| (i.e., which
+had been previously solved) and set |clear_list| equal to |nil|,
+indicating that |relation| is not solvable.
+
+@<If possible find and solve the list of parameters |clear_list|@>=
+ repeat begin
+ coefficient:=coefficient_of first_element_of kernel_list;
+ solvable_kernels:=skip_list
+ solvable_kernels(coefficient,parameters,parameters);
+ if null solvable_kernels then
+ begin
+ apply1('clear,clear_list);
+ clear_list:=nil
+ end
+ else begin
+ kernel:=first_element_of solvable_kernels;
+ linear_solve_and_assign(coefficient,kernel);
+ clear_list:=kernel . clear_list;
+ kernel_list:=rest_of kernel_list;
+ end end
+ until null kernel_list or null clear_list @;
+
+@ In order to give the user full control over the process of solving
+parameters we introduce a switch |solve_parameters|, indicating if
+solving of parameters is allowed.
+
+@<Lisp ini...@>=@/
+new_switch(solve_parameters,nil)$
+
+@ If it is allowed to solve parameters we can do so, otherwise
+|relation| is not solvable. The reader should verify that we are sure
+that |relation| contains generators at this stage.
+
+@<Solve |relation| by appr...@>=
+if !*solve_parameters then
+begin
+ kernel_list:=kernel_coeff_list_of kernel_list;
+ @<If possible find and solve the list of parameters |clear_list|@>;
+ return if clear_list then 'list . clear_list else 'unsolvable;
+end
+else 'unsolvable @;
+
+@*= Solving Jacobi identities. Now we have written all kinds of tools
+for solving Jacobi identities and a procedure for analysing Lie
+algebraic relations, we are able to implement the top level procedure
+|solve_Jacobi_identities_of| for actually solving Jacobi identities,
+and some other auxiliary procedures.
+
+Using the procedures |find_unprocessed_commutators_of|,
+|find_Jacobi_identities_of| and |relation_analysis|, solving Jacobi
+identities is in fact really simple: while there are processable
+commutators, find the Jacobi identities belonging to them, try to solve
+and if necessary print these identities. Identities which are not
+solvable automatically should be stored on the property list of the
+liebracket for reconsideration by the user.
+
+Printing of Jacobi identities is controled by a switch
+|print_identities|, which is \&{off} by default. If identities are
+to be printed only the identities not equal to 0 are printed.
+
+@<Lisp ini...@>=@/
+new_switch(print_identities,nil)$
+
+@ The procedure |solve_Jacobi_identities_of| can be written down
+without much explanation. We declare it a lisp operator.
+
+Notice that the property |commutator_list| of a liebracket is cleared
+by a call of |find_Jacobi_identities_of|. The list of unsolved
+identities is stored as the property |unsolved_identities|. After
+storing the unsolved identities, the property |identity_list| can be
+cleared, since all identities on it have been checked.
+
+We want all message in this procedure to appear with the switch |nat|
+turned on. Therefore we will force this and restore the old
+environment afterwards.
+
+@u
+lisp operator solve_Jacobi_identities_of;
+lisp procedure solve_Jacobi_identities_of bracketname;
+begin scalar generatorname,stage,identity_list,i,j,identity,
+ solution,nr_computed,nr_solved,environment,origin;
+ check_if_bracketname_is_a_liebracket_in("SOLVE_JACOBI_IDENTITIES_OF:");@/
+ generatorname:=get(bracketname,'generatorname);
+ environment:=!*nat; !*nat:=t; stage:=0;
+ @<Prepare next stage@>;
+ while identity_list do
+ @<Perform current stage@>;@/
+ print_statistics_of bracketname;@/
+ !*nat:=environment;
+end$
+
+@ Preparing the next stage of solving Jacobi identities consists of
+finding the unprocessed commutators and after that finding all Jacobi
+identities following from them.
+
+@<Prepare next stage@>=
+@<Print starting message for next stage@>;
+find_unprocessed_commutators_of bracketname;@/
+@<Report the search for identities@>;
+identity_list:=find_Jacobi_identities_of bracketname @;
+
+@ @<Perform current stage@>=
+begin
+ nr_computed:=0; nr_solved:=0;@/
+ @<Report the solving of identities@>;
+ @<Compute, solve and print all Jacobi identities in |identity_list|@>;
+ put(bracketname,'identity_list,nil);@/
+ @<Print the number of identities solved@>;
+ @<Prepare next stage@>;
+end @;
+
+@ Recall that |identity_list| is a double association list. Hence we
+must unfold it before usage. Recursive solving of dependencies may
+occur when we are solve a relation. Therefore we have to in- and
+decrease |indentation_level!*| beforehand and afterwards.
+
+@<Compute, solve and print all Jacobi identities in |identity_list|@>=
+for each id_list_i in identity_list do begin
+ i:=car id_list_i; id_list_i:=cdr id_list_i;
+ for each id_list_i_j in id_list_i do begin
+ j:=car id_list_i_j; id_list_i_j:=cdr id_list_i_j;
+ for each k in id_list_i_j do begin
+ incr(nr_computed);@/
+ identity:=special_Jacobi_identity(bracketname,i,j,k);
+ origin:=list('list,i,j,k);@/
+ @<If necessary print |identity|@>;
+ solution:=relation_analysis(identity,bracketname);
+ @<Take the actions appropriate for |solution|@>;
+ @<If necessary print |solution|@>;
+ end;
+ end;
+end @;
+
+@ Due the recursive nature of solving linear dependencies we
+have to use some indentation to indicate the level of
+solving dependencies. Therefore we have to precede |prin2!*| by an
+indentation according to a global variable |indentation_level!*|,
+which represents the level of indentation necessary, in all messages
+at the beginning of a line that are also usable when solving
+dependencies. Messages used only when solving Jacobi identities will
+only be performed at top level, so no indentation is needed there.
+
+The problem with the |indentation_level!*| is that we must be sure
+that it must be zero at start of any command, i.e., at algebraic
+level. But how can we be sure this, for something may go wrong at any
+level, causing a return to algebraic level without properly decreasing
+|indentation_level!*|. Fortunately, there is the |initl| mechanism of
+REDUCE, causing global quantities on the (global) list |initl!*| to be
+initialized to an initial value at algebraic level. Therefore we will
+make |indentation_level!*| a global variable and put it on |initl!*|
+with initial value 0.
+
+@d indent_according_to_level=@/
+ for i:=1:indentation_level!* do prin2!* "| " @;
+@d indented_print(string)=@/
+ <<indent_according_to_level; prin2!* string>>@;
+@d indented_empty_line=@/
+ if indentation_level!*=0 then terpri!* t else
+ @+ <<terpri!* nil; indent_according_to_level; terpri!* nil>> @;
+
+@<Lisp ini...@>=@/
+global '(indentation_level!*)$@/
+initl!*:='indentation_level!* . initl!*$@/
+put('indentation_level!*,'initl,0)$
+
+@ The message are rather straightforward and will not be explained in
+all detail.
+
+@<Print starting message for next stage@>=@/
+prin2!* "Starting stage "; prin2!* incr(stage); prin2!* ":"; terpri!* nil;
+prin2!* "Reordering the commutators..."; terpri!* nil @;
+
+@ @<Report the search for identities@>=@/
+prin2!* "Searching for identities..."; terpri!* nil @;
+
+@ @<Report the solving of identities@>=@/
+prin2!* "Solving the identities..."; terpri!* nil;
+if !*print_identities then @+
+<<prin2!* "==========================";
+ terpri!* nil>> @;
+
+@ @<If necessary print |identity|@>=
+if !*print_identities and identity neq 0 then
+begin indent_according_to_level; maprin origin; terpri!* nil; @/
+ indent_according_to_level; maprin identity; terpri!* nil;
+end @;
+
+@ @<If necessary print |solution|@>=
+if !*print_identities and solution neq 0 then
+begin
+ if member(solution,'(unsolvable nested_commutator invalid_generator))
+ then indented_print("Not solved.")
+ else @+ <<if car solution=generatorname or car solution='list then
+ indented_print("*** Solved for: ")
+ else indented_print("Solved for: ");
+ maprin solution>>;@/
+ indented_empty_line;
+end @;
+
+@ @<Print the number of identities solved@>=@/
+indented_print(nr_solved); prin2!* " identities solved of ";
+prin2!* nr_computed; indented_empty_line @;
+
+@ We recall that the procedure |relation_analysis| can only return 0,
+|unsolvable|, |nested_commutator|, |invalid_generator| or a list, the
+|car| of which is |bracketname|, |generatorname| or |list| (in which
+case some parameters of the Lie superalgebra were solved). The second
+third and fourth case give rise to an unsolved identity, which has to
+be placed on the list of unsolved identities. The last two cases are
+important enough to be mentioned even if |print_identities| is turned
+\&{off}.
+
+In the case that we have an unsolved identity we store it together
+with its origin in an algebraic list on the |unsolved_identities| list
+of the liebracket.
+
+@d update_unsolved_identities_list=@/
+put(bracketname,'unsolved_identities,@|
+ list('list,origin,identity) . get(bracketname,'unsolved_identities)) @;
+
+@<Take the actions appropriate for |solution|@>=
+if solution neq 0 then
+if member(solution,'(unsolvable nested_commutator invalid_generator)) then
+ update_unsolved_identities_list
+else if car solution=generatorname or car solution='list then
+begin incr(nr_solved);
+ if not !*print_identities then
+ <<indented_print("*** Identity "); maprin origin;
+ prin2!* " solved for: "; maprin solution; terpri!* nil>>
+end
+else incr(nr_solved) @;
+
+@*1 Printing unsolved identities and statistics. Users should be able
+to take a look at the list of unsolved identities. For this purpose we
+will write a procedure |unsolved_identities_of|, which rebuilds the
+list of unsolved identities by deleting all entries that have become 0
+during the process and returns it as an algebraic list for further
+examination by the user. Recall that the identities on the unsolved
+identities list are algebraic lists consisting of the origin of the
+identity and the identity itself.
+
+The procedure has to be available in algebraic mode.
+
+@u
+lisp operator unsolved_identities_of;
+lisp procedure unsolved_identities_of bracketname;
+begin scalar unsolved_identities,id;@/
+ check_if_bracketname_is_a_liebracket_in("UNSOLVED_IDENTITIES_OF:");
+ unsolved_identities:=get(bracketname,'unsolved_identities);@/
+ unsolved_identities:=@+
+ for each identity in unsolved_identities join
+ if (id:=aeval second_argument_of identity) neq 0 then @|
+ list list('list,first_argument_of identity,id);
+ put(bracketname,'unsolved_identities,unsolved_identities);
+ return 'list . unsolved_identities;
+end$
+
+@ It may be convenient to get track of some statistics concerning a
+Lie superalgebra, for instance if one wants to know if a Lie
+superalgebra is solved completely. The procedure |print_statistics_of|
+prints the number of used generators, the number of commutators,
+generators and parameters solved and the number of unsolved
+identities; Of course we don't want to count the {\it special}
+commutators in the number of solved commutators. We can check this by
+looking at the informative part of an entry of the vectorstructure.
+
+@d not_special(entry)=@/informative_part_of entry neq '(special)@;
+
+@u
+lisp operator print_statistics_of;
+lisp procedure print_statistics_of bracketname;
+begin scalar properties_for_direct_access,vector_i,entry_i_j,nr_solved,total;
+ check_if_bracketname_is_a_liebracket_in("PRINTS_STATISTICS_OF:");
+ @<Initialize prop...@>;
+ nr_solved:=0;
+ for i:=-n_used:m_used do begin
+ vector_i:=getv(vector_structure,n+i);
+ for j:=i:m_used do
+ if (entry_i_j:=getv(vector_i,m-j)) and
+ commutator_part_of(entry_i_j) and not_special(entry_i_j)
+ then incr(nr_solved);
+ end;
+ total:=((m_used+n_used)^2-m_used+n_used)/2;
+ if total=0 then rederr("PRINT_STATISTICS_OF: first define used area");
+ terpri!* t;
+ prin2!* "Statistics for liebracket "; maprin bracketname; terpri!* nil;@/
+ prin2!* m_used; prin2!* " even and "; prin2!* n_used;
+ prin2!* " odd generators used"; terpri!* nil;
+ prin2!* nr_solved; prin2!* " commutators solved of ";@/ prin2!* total;
+ prin2!* " ("; prin2!* ((nr_solved*100)/total); prin2!* " %)"; terpri!* nil;@/
+ prin2!* length get(get(bracketname,'generatorname),'kvalue);@/
+ prin2!* " linear dependencies found"; terpri!* nil;@/
+ total:=for each parameter in get(bracketname,'parameters) sum
+ length get(parameter,'kvalue);@/
+ prin2!* total; prin2!* " parameters solved"; terpri!* nil;@/
+ prin2!* length get(bracketname,'unsolved_identities);
+ prin2!* " unsolved identities"; terpri!* t;
+end$
+
+
+@*= Access to generators. In the introduction of the previous chapter
+we concluded that it was most convenient to control the access to a
+generator of a Lie (super)algebra by an set-element-function and a
+clear function. For a detailed description how these procedures should
+act we refer to the previous chapter. In the following sections we will
+take care of the set-element-function |set_generator| and the clear
+function |clear_generator| belonging to the rtype |algebra_generator|.
+Moreover, to let the clear function work properly, |algebra_generator|
+must have a rtypefn |generator_rtypefn|. How a set-element-function,
+a clear function and an rtype function work and cooperate exactly, we
+have already explained for a liebracket.
+
+The names of all three procedures must be put on the property list of
+|algebra_generator|.
+
+@<Lisp ini...@>=@/
+put('algebra_generator,'setelemfn,'set_generator)$@/
+put('algebra_generator,'clearfn,'clear_generator)$@/
+put('algebra_generator,'rtypefn,'generator_rtypefn)$
+
+@ The same remarks that were made for the rtypefn |liebracket_rtypefn|
+apply to the rtypefn for a algebra generator, |generator_rtypefn|,
+since we don not want particular generators to be recognized as a
+|algebra_generator|.
+
+@u
+lisp procedure generator_rtypefn u;
+nil$
+
+@ The set-element-function |set_generator| of an algebra generator
+should do three things: check if |val| is a valid generator and
+|value| a sum of generators, do the assignment |val:=value| and adjust
+all commutators containing |val|. For the last action we need to know
+the name of the liebracket associated to the algebra generator
+involved. We expect this name to be stored on the property list of
+this generator as the property |bracketname|.
+
+Since we use the standard REDUCE procedure |setk1| to do the
+assignment on the kvalue list of the generator we must call |rmsubs()|
+ourselves, in order to assure proper reevaluation of algebraic
+expressions.
+
+@u lisp procedure set_generator(val,value); if length val neq 2 then
+ rederr("SET_GENERATOR: generator must have one integer argument")
+else begin scalar generatorname,bracketname,i,valuelist,
+ identity,solution,
+ nr_computed,nr_solved,environment,origin;
+ generatorname:=operator_name_of val;
+ bracketname:=get(generatorname,'bracketname);
+ i:=reval first_argument_of val;
+ value:=aeval value;@/
+ @<Check that |val| and |value| are valid for assignment@>;
+ if used_operator_element(val) then rmsubs();@/
+ setk1(val,value,t); %Do the assignment on the kvalue list of |generatorname|%
+ @<Adjust commutators |bracketname(i,j)| for $j=-n,\dots,1$ and $j=1,\dots,m$@>;
+end$
+
+@ We must check that |val| is a valid generator, i.e., $i$ must be
+integer and not out of range. For this purpose we will use the macro
+|wrong_atomic_argument| we wrote before. Moreover, we must check
+that |value| is a sum of valid generators. This can be done most
+conveniently by using |operator_coeff| and |wrong_atomic_argument|. We will
+use the variable |valuelist| (local within |set_generator|) to
+store the list produced by |operator_coeff|.
+
+@<Check that |val| and |value| are valid for assignment@>=@/
+if not atom i or wrong_atomic_argument(i) then @|
+ stop_with_error("SET_GENERATOR:",val,"invalid or out of range",nil);
+valuelist:=operator_coeff(value,generatorname);
+if independent_part_of valuelist neq 0 then
+ stop_with_error("SET_GENERATOR:",@|independent_part_of valuelist,
+ "not a sum of generators",nil);
+for each term in kernel_coeff_list_of valuelist do
+ if length(term:=kernel_of term) neq 2 or
+ not atom first_argument_of term or @|
+ wrong_atomic_argument(first_argument_of term) then @|
+ stop_with_error("SET_GENERATOR:",term,"invalid or out of range",nil) @;
+
+@*1 Adjusting commutators. After the assignment we have to adjust
+the values of $\\{bracketname}(i,j)$ for $j=-n,\dots,1$ and
+$j=1,\dots,m$ according to the assignment made. Hence we have to solve
+the identities $\\{bracketname}(i,j)=\\{bracketname}(\\{value},j)$.
+This can be done by using the procedure |relation_analysis|.
+
+Recall that we stored the even and odd dimensions $m$ and $n$ on the
+property list of a liebracket as the properties |even_dimension| and
+|odd_dimension|.
+
+Note that there are some different cases to distinguish: $\lie(i,i)$
+may be set for $i<0$, but not for $i>0$. $\lie(i,0)$ may also not be
+set. These cases are already incorporated in the |repeat| statement.
+Moreover, note that |value| has been |aeval|'ed, hence is in !*SQ
+prefixform.
+
+To stay in line with the procedure |solve_Jacobi_identities_of| we
+will take the same actions and print the same kind of information as
+we did during the solving of Jacobi identities. Recall that all
+message that may occur recursively at deeper levels of solving linear
+dependencies are indented according to the global variable
+|identation_level!*|. Hence this level must be increased before
+we start adjusting commutators.
+
+@<Adjust commuta...@>=@/
+environment:=!*nat; !*nat:=t; %Force the switch |nat| to be on%
+@<Write a message that adjustment of commutators has begun@>;
+incr(indentation_level!*);
+nr_computed:=0;nr_solved:=0;
+for j:=-get(bracketname,'odd_dimension):get(bracketname,'even_dimension) do
+ if j neq 0 and (i neq j or i<0) then
+ begin
+ incr(nr_computed);@/
+ identity:=@<|bracketname(i,j)-bracketname(value,j)|@>;
+ origin:=list('list,i,j);@/
+ @<If necessary print |ide...@>;
+ solution:=relation_analysis(identity,bracketname);
+ @<Take the actions appr...@>;
+ @<If necessary print |sol...@>;
+ end;
+@<Print the number of ident...@>;
+decr(indentation_level!*);@/
+!*nat:=environment %Restore the original setting of |nat|% @;
+
+@ @<Write a message that ...@>=@/
+indented_print("Adjusting the commutators of "); @/ maprin val; prin2!* "...";
+terpri!* nil;
+if !*print_identities then @+
+<<indented_print("| ========================");
+terpri!* nil;>> @;
+
+@ To get the difference of |bracketname(i,j)| and
+|bracketname(value,j)| we use |simp_liebracket| to get both
+commutators as standard quotients, |subtrsq| to subtract them and
+|mk!*sq| to convert a standard quotient into a !*SQ prefixform.
+Because we use the answer to solve an algebra relation we have to
+make sure that all substitutions are performed, hence we must apply
+|subs2| to the standard quotient.
+
+@<|bracketname(i,j)-bracketname(value,j)|@>=@/
+mk!*sq subs2 subtrsq(simp_liebracket(list(bracketname,i,j)),@|
+ simp_liebracket(list(bracketname,value,j))) @;
+
+@*1 Clearing generators. The clear function of an algebra generator is
+much easier than its set-element-function, because it is nearly
+impossible to backtrace all commutators which have been set by the
+assignment to this generator. To understand this, one should be aware
+of the fact that the process of adjusting commutators to linear
+dependencies of some generators may be recursive, namely if one the
+relations |bracketname(i,j)-bracketname(i,value)| itself is a linear
+dependency of some generators. Moreover, the relations caused by this
+linear dependency may have introduced new solvable Jacobi identities,
+which may already have been solved. Hence we will only give a warning
+that things may get messed up.
+
+@u
+lisp procedure clear_generator val;
+if atom val then rederr("CLEAR_GENERATOR: clear associated liebracket instead")
+else if length val neq 2 then
+ rederr("CLEAR_GENERATOR: generator must have one integer argument")
+else begin scalar generatorname,kvalue,h;
+ generatorname:=operator_name_of val;
+ val:=list(generatorname,reval first_argument_of val);
+ kvalue:=get(generatorname,'kvalue);
+ if (h:=assoc(val,kvalue)) then
+ begin
+ put(generatorname,'kvalue,delete(h,kvalue));
+ message("CLEAR_GENERATOR: clearing",val,"may lead to errors",nil);
+ end
+ else message("CLEAR_GENERATOR:",val,"not found",nil);
+end$
+
+@*= Multigradings, definitions and introduction of new generators. In the
+first section we urged the need to store and retrieve integer valued
+multigrades of all generators of a Lie algebra. In this section we
+will introduce an environment for these multigrades, implement
+procedures to find generators and unknown commutators of a certain
+degree and a procedure to determine the degree of an given expression.
+
+Moreover, we will write a procedure to introduce a new generator for a
+given (unknown) commutator and at the same time determine the degree
+of it, i.e., the degree of the commutator. Besides a grading it will
+also be convenient to know the definition and the ``history'' of a
+newly introduced generator, i.e., what commutator was used at highest
+level to define this generator and which commutators were
+recursively used to construct it . This kind of information will
+also be stored.
+
+For each generator we will store this information in a vector of
+dimension $m+n$ where $m$ and $n$ are the even and odd dimension of
+the Lie superalgebra, respectively. Each entry of this vector will be
+a dotted pair, consisting of a degree part, a definition part and a
+history part. At initialization the entry for a generator |y(i)|
+($-n\leq i\leq m$) will be initialized to |'(0) . i . i|, i.e., we
+initialize the degree of all generators to a multi degree of length 1
+with value 0.
+
+The vector with degree and history information will be stored on the
+property list of the liebracket as the property |info_list|. The
+information of generator |y(i)| will be contained in this vector at
+index $n+i$. Access to this vector can be obtained by using the macros
+|get_info| and |put_info|. The length of the multi degrees
+is stored as the property |degree_length|. As stated above it is
+initialized to 1.
+
+@d degree_part=car
+@d definition_part=cadr
+@d history_part=cddr
+@d get_degree=degree_part get_info
+@d get_definition=definition_part get_info
+@d get_history=history_part get_info
+@d get_info(bracketname,i)=@/
+getv(get(bracketname,'info_list),get(bracketname,'odd_dimension)+i) @;
+@d put_info(bracketname,i,value)=@/
+putv(get(bracketname,'info_list),get(bracketname,'odd_dimension)+i,value)@;
+
+@ The most important action for manipulating degrees is the
+possibility to add them. This is done by the recursive procedure
+|add_degrees|, which expects its arguments to be of identical length
+and, moreover, expects its arguments to be integer lists.
+
+@u lisp procedure add_degrees(degree1,degree2);
+if degree1 then (car degree1 + car degree2) . add_degrees(cdr
+degree1,cdr degree2)$
+
+@ From using this package it became apparent that it may be quite
+convenient to look at gradings in another order, since during the
+process of computing Lie super algebras, different components of a
+multigrading may turn out to play an important role. As it is quite
+bothersome to change the order of gradings by hand, we will offer a mechanism
+here that selects a subset of an actual multigrading in a prescribed
+order.
+
+The procedure |degree_component_sequence| will assign a prescibed
+sequence of the multigrading to a liebracket by saving this sequence
+as the property |degree_sequence|. A degree sequence may be given as
+an integer or an algebraic or lisp list of integers. This can be
+transformed into a lisp list using the macro |make_oplist| to be
+explained below.
+
+@u lisp operator degree_component_sequence;
+lisp procedure degree_component_sequence(bracketname,degree_sequence);
+begin scalar degree_length;
+ check_if_bracketname_is_a_liebracket_in("DEGREE_COMPONENT_SEQUENCE:");
+ degree_sequence:=make_oplist(degree_sequence);
+ degree_length:=get(bracketname,'degree_length);
+ degree_sequence:=
+ for each component in degree_sequence collect
+ if fixp component and component >0 and component leq degree_length then
+ component
+ else
+ stop_with_error("DEGREE_COMPONENT_SEQUENCE: multigrading has no component",
+ component,nil,nil);
+ put(bracketname,'degree_sequence,degree_sequence);
+end$
+
+@ Given a |degree| the procedure |permuted_degree| returns |degree|
+permuted w.r.t.\ a prescribed |sequence|. If there is no |sequence|
+degree should be returned without change.
+
+@d get_permuted_degree(bracketname,i)=
+ permuted_degree(degree_part get_info(bracketname,i),
+ get(bracketname,'degree_sequence))
+
+@u lisp procedure permuted_degree(degree,sequence);
+if null sequence then degree else permute_degree(degree,sequence)$
+
+lisp procedure permute_degree(degree,sequence);
+if sequence then
+ nth(degree,car sequence) . permute_degree(degree,cdr sequence)$
+
+@ If we want to determine the degree of a general Lie algebra element
+|element| belonging to a liebracket |bracketname|, we have to
+distinguish three cases:\medskip
+
+\item{1.} if |element| is the index number of a generator, we can simply
+get the information about |element| and return the degree part of it.
+
+\item{2.} if |element| is a commutator, we can add the degrees of both
+components. Because we will use algebraic list to return the
+definition a some generator, as explained in one of the next sections,
+we will also consider algebraic lists as commutators, in this case.
+
+\item{3.} if |element| is a generator, we can return the degree of the
+index number of |element|.
+\enditem
+The procedure |degree_of1| takes care of these cases. Notice that we
+expect commutators to have only two arguments. We can achieve this by
+simplifying |element| before applying |degree_of1|.
+
+@u lisp procedure degree_of1(bracketname,element);
+if atom element then
+ if wrong_atomic_argument(element) then@|
+ stop_with_error("DEGREE_OF: cannot determine degree of",element,nil,nil)
+ else get_permuted_degree(bracketname,element)
+else
+if operator_name_of element=bracketname or operator_name_of element='list then
+ add_degrees(degree_of1(bracketname,first_argument_of element),@|
+ degree_of1(bracketname,second_argument_of element))
+else if operator_name_of element=get(bracketname,'generatorname) then @|
+ degree_of1(bracketname,first_argument_of element)
+else stop_with_error("DEGREE_OF: cannot determine degree of",element,nil,nil)$
+
+@ At algebraic level we will return the degree of some Lie algebra
+element as an algebraic list. This is done by the procedure
+|degree_of|.
+
+In order to avoid difficulties with linear dependencies of some
+generators, we shall also allow linear combinations of Lie algebra
+elements and suppose that the sum offered is homogeneous. In this case
+we return the degree of the first Lie algebra element encountered.
+
+Notice that |element| is evaluated specifically as requested in the
+previous module.
+
+@u lisp operator degree_of;
+lisp procedure degree_of element;
+begin scalar operatorname,bracketname,check_element;
+ if (element:=reval element)=0 then @+return nil;
+ if not atom element then
+ begin
+ operatorname:=operator_name_of element;
+ if get(operatorname,'rtype)='liebracket then bracketname:=operatorname
+ else if get(operatorname,'rtype)='algebra_generator then @|
+ bracketname:=get(operatorname,'bracketname)
+ end;
+ if null bracketname then @<Check for linear combinations of Lie algebra elements@>;
+ if null bracketname then @|
+ stop_with_error("DEGREE_OF: cannot determine degree of",element,nil,nil);
+ return 'list . degree_of1(bracketname,element)
+end$
+
+@ If a linear combination is a sum we can check the first term. If it
+is a quotient we have to examine the numerator. If it is a product we
+have to examine the factors until we have encountered a Lie algebra
+element.
+
+@<Check for linear combinations of Lie algebra elements@>=
+begin
+ check_element:=element;
+ while not atom check_element and @|
+ member(operator_name_of check_element,'(quotient plus minus difference)) do
+ check_element:=first_argument_of check_element;
+ if not atom check_element then@/
+ (if operator_name_of check_element='times then
+ @<Check all factors for Lie algebra elements@>
+ else
+ begin
+ operatorname:=operator_name_of check_element;
+ if get(operatorname,'rtype)='liebracket then bracketname:=operatorname
+ else if get(operatorname,'rtype)='algebra_generator then @|
+ bracketname:=get(operatorname,'bracketname);
+ if bracketname then element:=check_element
+ end)
+end
+
+@ @<Check all factors for Lie algebra elements@>=
+ while null bracketname and (check_element:=rest_of check_element) do
+ <<if not atom first_element_of check_element then
+ begin
+ operatorname:=operator_name_of first_element_of check_element;
+ if get(operatorname,'rtype)='liebracket then bracketname:=operatorname
+ else if get(operatorname,'rtype)='algebra_generator then @|
+ bracketname:=get(operatorname,'bracketname)
+ end;
+ if bracketname then element:=first_element_of check_element>>
+
+
+@ The next step towards a useful application of gradings is the
+availability of a procedure |define_degree| to assign a new value to the
+degree of some generator (since a grading with all degrees equal to 0
+isn't very useful). We impose a few requirements on the degrees to be
+assigned:\medskip
+
+\item{1.} A newly assigned degree should have the
+proper length, i.e., should have length |degree_length|.
+
+\item{2.} All entries of a multi degree should be integer valued.
+
+\item{3.} A degree can be entered as an atom, an algebraic list or a
+lisp list. This is the same syntax for entering ``lists'' of some
+objects which we used for lists of operatornames for multilinear
+operatornames, as introduced in the TOOLS package. Hence we copy the
+definition |make_oplist| which transforms one the alternatives
+mentioned above in an ordinary lisp list.
+
+@d make_oplist(op_list)=@/if null op_list then op_list else if atom
+op_list then list op_list else if
+car op_list='list then cdr op_list else op_list @;
+
+@<Check if |degree| is a valid degree@>=@/
+if not integer_valued(degree:=make_oplist(degree)) or
+ length degree neq get(bracketname,'degree_length) then
+stop_with_error("DEGREE:",'list . degree,"invalid degree",nil) @;
+
+@ Checking that a list consists of integers can be done with help of
+the following recursive procedure.
+
+@u
+lisp procedure integer_valued degree;
+if null degree then t
+else if fixp car degree then integer_valued cdr degree$
+
+@ Assigning a new degree to a generator is really simple now: check if
+the generator is indeed a generator, check the degree for its validity
+and update the info entry for the generator.
+
+@u lisp operator define_degree;
+lisp procedure define_degree(generator,degree);
+begin scalar generatorname,bracketname,info;
+ @<Check if |generator| is valid, if so find |bracketname|@>;
+ @<Check if |degree| is a valid degree@>;
+ info:=get_info(bracketname,generator);
+ put_info(bracketname,generator,
+ degree . definition_part info . history_part info);
+end$
+
+@ A generator is valid, if it is an operator element
+whose operator is of rtype |algebra_generator| and, moreover, the
+argument of which is not out of range. Before checking the argument we
+must |reval| it because this is not necessarily done (for instance in
+the procedures |definition_of| and |history_of|, which will be
+explained in a few sections).
+
+@<Check if |generator| is valid, if so find |bracketname|@>=
+ if atom generator then
+ stop_with_error("DEGREE:",generator,"invalid generator",nil);
+ generatorname:=operator_name_of generator;
+ check_if_generatorname_is_a_generator_in("DEGREE:");
+ bracketname:=get(generatorname,'bracketname);
+ generator:=reval first_argument_of generator;
+ if wrong_atomic_argument(generator) then @|
+ stop_with_error("DEGREE: generator index",
+ generator,"out of range",nil) @;
+
+@ Since all procedures concerning degrees check for the proper length
+of the degrees, there should be a procedure |change_degree_length| to
+change the length of all degrees. The main part of it consists of
+adapting the length of all existing degrees. This is necessary because
+|add_degrees| expects all degrees to be of the same length. If the new
+length of is larger than the old one we must extend all degrees with
+an appropriate number of zeros, otherwise we can take the sub degree of
+appropriate length.
+
+@u
+lisp operator change_degree_length;
+lisp procedure change_degree_length(bracketname,degree_length);
+begin scalar m,n,old_length,shortage,extension,info,degree;
+ check_if_bracketname_is_a_liebracket_in("CHANGE_DEGREE_LENGTH:");
+ if not fixp degree_length or degree_length <= 0 then
+ rederr("CHANGE_DEGREE_LENGTH: degree length should be >= 0");@/
+ m:=get(bracketname,'even_dimension);
+ n:=get(bracketname,'odd_dimension);@/
+ old_length:=get(bracketname,'degree_length);
+ shortage:=degree_length-old_length;
+ if shortage>0 then extension:=@+for i:=1:shortage collect 0;@/
+ @<Adapt the |info_list|@>;
+ put(bracketname,'degree_length,degree_length);
+end$
+
+@ @<Adapt the |info_list|@>=
+ for i:=-n:m do
+ begin info:=get_info(bracketname,i); @/
+ degree:=if extension then append(degree_part info,extension)
+ else sub_list(degree_part info,degree_length);
+ put_info(bracketname,i,
+ degree . definition_part info . history_part info)
+ end @;
+
+@ The sub list of a list |l|, consisting of the first $n$ elements,
+can be collected using the recursive procedure |sub_list|.
+
+@u
+lisp procedure sub_list(l,n);
+if l and n>0 then car l . sub_list(cdr l,n-1)$
+
+@ Finding the definition or the history of some generator is much
+easier than the determination of the degree of some Lie algebra
+element, and is taken care of by the procedure |definition_of| and
+|history_of|, both to be available in algebraic mode.
+There is, however, one tricky point which we should take care of in
+both cases, namely if some generator is found linear independent, we
+still want to be able to retrieve the definition/history of such a
+generator. Therefore the arguments of |definition_of| and |history_of|
+must not be evaluated. This can be achieved by giving |definition_of|
+and |history_of| the property |psopfn|, i.e., the arguments of these
+procedures are put on a list and the procedure which name is the value
+of the property |psopfn| is applied to this list. For this we will use
+the same convention as in the TOOLS package: the |psopfn| is indicated
+by a additional 1, the real work, however, is done by a lisp procedure
+with the same name and syntax as available in algebraic mode.
+
+The definition of a generator is either an integer, corresponding to the
+generator, or an algebraic list with two integer arguments,
+corresponding to the commutator used to define the generator.
+We use algebraic lists, because it would be useless to return the
+commutator self as the definition, since it will be reevaluated to the
+generator immediately. Recall that for this reason we allowed
+algebraic lists as a special kind of commutators in |degree_of1|.
+
+The history of a generator is either an integer, corresponding to the
+generator, or an algebraic list of arbitrary length, consisting of
+possibly nested lists of integers, corresponding to the possibly
+nested commutator used to define the generator, where all integers
+recursively occuring in the history have integer histories themselves,
+in other words the history corresponds to the way a generator was
+introduced recursively.
+
+@<Lisp ini...@>=@/
+put('definition_of,'psopfn,'definition_of1)$@/
+put('history_of,'psopfn,'history_of1)$
+
+
+@
+@u lisp procedure definition_of1 listed_generator;
+definition_of first_element_of listed_generator$@#
+
+lisp procedure definition_of generator;
+begin scalar generatorname,bracketname;
+ @<Check if |generator| is valid, if so find |bracketname|@>;
+ return get_definition(bracketname,generator);
+end$@#
+
+lisp procedure history_of1 listed_generator;
+history_of first_element_of listed_generator$@#
+
+lisp procedure history_of generator;
+begin scalar generatorname,bracketname;
+ @<Check if |generator| is valid, if so find |bracketname|@>;
+ return get_history(bracketname,generator);
+end$
+
+@*1 Finding commutators and generators of a given degree. The next
+important issue is how to get all (independent) generators or unknown
+commutators of a given degree. The first question that arises is how
+to define a useful notion of objects ``of a given degree''. A rigid
+point of view is to allow all objects whose degree is totally equal to
+the given degree. A more general, and to our opinion very useful,
+point of view is to allow all objects that have a degree the first
+part of which matches the given degree, any other elements of it not
+being relevant. This notion enables us to use subsets of a
+multigrading for selecting Lie algebra objects.
+
+The procedure |sub_degree| takes care of the strategy introduced
+above, and returns |t| if |degree1| is a subset of |degree2|, |nil|
+otherwise.
+
+@u
+lisp procedure sub_degree(degree1,degree2);
+if null degree1 then t
+else if null degree2 then nil
+else if car degree1=car degree2 then
+ sub_degree(cdr degree1,cdr degree2)$
+
+@ Finding all generators of a given degree, is very easy now: first
+check if |degree| is a valid degree (if not searching is useless),
+then collect all generators whose degree match |degree|.
+The result is returned a an algebraic list.
+
+Of course it is not useful to return generators that are linear
+dependent of others, therefore we will also check on the kvalue list
+of the generator if it has a value.
+
+@u
+lisp operator generators_of_degree;
+lisp procedure generators_of_degree(bracketname,degree);
+begin scalar even_used,odd_used,generatorname,kvalue;
+ check_if_bracketname_is_a_liebracket_in("GENERATORS_OF_DEGREE:");@/
+ if not integer_valued(degree:=make_oplist(degree)) then @|
+ stop_with_error("DEGREE:",'list . degree,"invalid degree",nil);@/
+ even_used:=get(bracketname,'even_used);
+ odd_used:=get(bracketname,'odd_used);@/
+ generatorname:=get(bracketname,'generatorname);
+ kvalue:=get(generatorname,'kvalue);
+ @<Return the list of generators with right degree@>;
+end$
+
+@ We use the |for| \dots |join| construct to get the list of generators
+with right degree. In this way we can prevent generators with wrong
+degree to cause empty entries in the result list. Since this construct
+concatenates lists, we have to surround all entries by an additional
+list.
+
+Recall that we prevented the use of 0 as an index of a generator, so
+at this place we have to make an exception for it.
+
+@<Return the list of generators with right degree@>=
+ return 'list .
+ for i:=-odd_used:even_used join
+ if i neq 0 and null assoc(list(generatorname,i),kvalue) and @|
+ sub_degree(degree,get_permuted_degree(bracketname,i))
+ then
+ list list(generatorname,i) @;
+
+@ The procedure |commutators_of_degree| returns an algebraic list of
+all unknown commutators of a given degree. It's action is similar to
+that of |generators_of_degree|. For efficiency reasons we will access
+both the |vector_structure| and the |info_list| directly, i.e.,
+without using the macros |get_commutator| and |get_permuted_degree|.
+Recall that the degrees may be permuted, thus we have to call
+|permuted_degree| at the proper places.
+
+@u
+lisp operator commutators_of_degree;
+lisp procedure commutators_of_degree(bracketname,degree);
+begin scalar properties_for_direct_access,vector_i,entry_i_j,info_list,
+ degree_sequence,degree_i;
+ check_if_bracketname_is_a_liebracket_in("COMMUTATORS_OF_DEGREE:");
+ @<Initialize properties for direct access@>;
+ info_list:=get(bracketname,'info_list);
+ if not integer_valued(degree:=make_oplist(degree)) then @|
+ stop_with_error("DEGREE:",'list . degree,"invalid degree",nil);
+ degree_sequence:=get(bracketname,'degree_sequence);
+ @<Return the list of commutators with right degree@>;
+end$
+
+@ In this case we need not make exceptions for 0 since all $\lie(i,0)$
+are initialized to 0, hence have a value.
+
+@<Return the list of commutators with right degree@>=
+ return 'list .
+ for i:=-n_used:m_used join
+ <<vector_i:=getv(vector_structure,n+i);
+ degree_i:=degree_part getv(info_list,n+i);@/
+ for j:=i:m_used join
+ if (null (entry_i_j:=getv(vector_i,m-j)) or
+ null commutator_part_of(entry_i_j)) and@|
+ sub_degree(degree,@|
+ permuted_degree(add_degrees(degree_i,
+ degree_part getv(info_list,n+j)),
+ degree_sequence))@/
+ then
+ list list(bracketname,i,j)
+ >> @;
+
+@*1 Introduction of new generators. In the light of all the tools we
+made for showing and maintaining the degree, definition and history of
+a generator, it will be very convenient to have a procedure
+|new_generators| that introduces a new generator for some unknown
+commutator and at the same time updates the |info_list|. Recall that
+associated to a liebracket are the properties |even_used| and
+|odd_used|, indicating the number of even and odd generators that are
+actually used, respectively. It will be clear that we can use these
+properties right here to determine first unused index available for a
+newly introduced generator, and, moreover, after introducing a new
+generator, have to update them.
+
+Keeping in mind that the procedure |commutators_of_degree| may be used
+to get a list of unknown commutators, for which new generators may be
+introduced, it also seems convenient if |new_generators| is able to
+deal with lists of unknown commutators. This can be done by calling
+|new_generators| recursively on all elements of the list.
+
+In case of a single commutator we will return the newly introduced
+generator, in case of a list of commutators the corresponding list of
+newly introduced generators. The second case motivates us not to
+produce an error message if, for whatever reason, it impossible to
+create an new generator for some object, but simply return it
+unchanged, for otherwise it will be impossible to return a list
+containing the generators which had already been created.
+
+Hence we can deduce the following strategy:\medskip
+
+\item{1.}
+if the object is an atom return it unchanged.
+
+\item{2.} if the object is an algebraic list apply |new_generators| to
+all its elements and return the list of results. There is, however,
+one tricky point: some commutator may occur several times on the list.
+Since we are working in lisp mode this will not be detected
+automatically, and thus, for each occurence a new generator would be
+introduced. Therefore we must |reval| each entry of the list before
+doing anything.
+
+\item{3.}
+if the object is an other operator element but not a commutator,
+return it unchanged.
+
+\item{4.}
+if the object is a commutator, check if it is possible to introduce a
+new generator for it, if so update the |info_list| and return the
+newly introduced generator, else return the commutator unchanged.
+
+@u
+lisp operator new_generators;
+lisp procedure new_generators commutator_list;
+begin scalar operatorname,bracketname,arg1,arg2,indx,
+ generator,degree,definition,history;
+return
+ if atom commutator_list then commutator_list
+ else @+<<
+ operatorname:=operator_name_of commutator_list;
+ if operatorname='list then
+ 'list . for each commutator in arguments_of commutator_list collect @|
+ new_generators reval commutator
+ else
+ if not get(operatorname,'rtype)='liebracket then commutator_list
+ else
+ @<If possible introduce and return a new generator, update |info_list|@> >>;
+end$
+
+@ It is only possible to introduce new generators for commutators of
+two generators which are not out of range.
+
+@<If possible introduce and return a new generator...@>=
+begin
+ bracketname:=operatorname;@/
+ arg1:=first_argument_of commutator_list;
+ arg2:=second_argument_of commutator_list;
+ if wrong_atomic_argument(arg1) or wrong_atomic_argument(arg2) then
+ return commutator_list;
+ @<Check if new |generator| is possible, if so update |info_list|@>;
+ return if generator then
+ setk(commutator_list,generator)
+ else commutator_list
+end @;
+
+@ Depending if the commutator is even or odd, we must introduce a new
+even or odd generator, respectively.
+
+@<Check if new |generator| is possible, if so update |info_list|@>=
+if even_element(operatorname,commutator_list) then @|
+ @<Update |even_used| and |info_list|, if new |generator| is possible@>
+ else
+ @<Update |odd_used| and |info_list|, if new |generator| is possible@>
+
+@ A new generator is possible if index of it (i.e., the number of used
+elements plus 1) does not exceed the maximal dimension.
+
+@<Update |even_used| and |info_list|, if new |generator| is possible@>=
+begin
+ indx:=get(operatorname,'even_used)+1;
+ if indx<=get(operatorname,'even_dimension)
+ then@/
+ <<put(operatorname,'even_used,indx);
+ generator:=list(get(operatorname,'generatorname),indx);
+ @<Update the |info_list|@> >>;
+end @;
+
+@ @<Update |odd_used| and |info_list|, if new |generator| is possible@>=
+begin
+ indx:=get(operatorname,'odd_used)+1;
+ if indx<=get(operatorname,'odd_dimension)
+ then@/
+ <<put(operatorname,'odd_used,indx);
+ indx:=-indx;
+ generator:=list(get(operatorname,'generatorname),indx);@/
+ @<Update the |info_list|@> >>;
+end @;
+
+@ Before updating the |info_list| at index |indx|, we must compute
+the degree of the newly introduced generator using |add_degrees|,
+construct its definition and its history. The last can be done by
+applying the procedure |add_histories|, to be implemented in the next
+module.
+
+@<Update the |info_list|@>=
+degree:=add_degrees(get_degree(operatorname,arg1),
+ get_degree(operatorname,arg2));@/
+history:=add_histories(get_history(operatorname,arg1),
+ get_history(operatorname,arg2));@/
+definition:=list('list,arg1,arg2);
+put_info(bracketname,indx,degree . definition . history) @;
+
+@ Recall that nested commutators are treated right associative by
+|simp_liebracket|. Therefore we can append the second history to the
+first.
+
+@u lisp procedure add_histories(history1,history2);
+if fixp history2 then list('list,history1,history2)
+else
+ if fixp history1 then 'list . history1 . arguments_of history2
+ else 'list . append(list history1,arguments_of history2)$
+
+@ Before we can use the procedure |new_generators| we must be able to
+change the properties |even_used| and |odd_used|, because these are
+both initialized to 0. For clarity we will in- and output them in the
+same way, namely as an algebraic list |{even_used,odd_used}|.
+
+@u lisp operator list_used;
+lisp procedure list_used bracketname;
+<<check_if_bracketname_is_a_liebracket_in("LIST_USED:");
+ list('list,get(bracketname,'even_used),get(bracketname,'odd_used))>>$
+
+@ Before defining |even_used| and |odd_used| we must check that they
+are integers and not out of range.
+
+@u
+lisp operator define_used;
+lisp procedure define_used(bracketname,used_list);
+begin scalar even_used,odd_used;
+ check_if_bracketname_is_a_liebracket_in("DEFINE_USED:");
+ if atom(used_list) or operator_name_of(used_list) neq 'list or
+ length(used_list) neq 3 then
+ stop_with_error("DEFINE_USED:",used_list,"invalid list of dimensions",nil);
+ even_used:=first_argument_of used_list;
+ odd_used:=second_argument_of used_list;
+ if even_used>get(bracketname,'even_dimension) or
+ odd_used>get(bracketname,'odd_dimension)
+ then rederr("DEFINE_USED: dimensions out of range");@/
+ put(bracketname,'even_used,even_used);
+ put(bracketname,'odd_used,odd_used);
+end$
+
+@*= Declaration and saving of liebrackets. Now we know all ins and
+outs of liebrackets (especially the list of properties associated to
+them), we can finally write the procedures for the declaration and
+saving of liebrackets. Moreover, we will write a procedure for
+enlarging the dimensions of a liebracket.
+
+@ For the declaration of liebrackets we will use the following syntax
+$$\hbox{liebracket bracketname(generatorname,even dimension,odd
+dimension[,algebra elements,parameters])}$$ where algebra elements and
+parameters may be an identifier or an algebraic or lisp list of
+identifiers. For this purpose we can use the macro definition
+|make_oplist| defined before.
+
+We give the procedure |liebracket| the property |stat| with value
+|rlis| in order to allow more liebracket declarations at a time.
+It should be noted that, in doing so, |liebracket| need not be
+declared a lisp operator anymore to make it available in algebraic
+mode.
+
+Procedures with |stat='rlis| can have an arbirtrary number of
+arguments which the parser passes to them on a list. In our case this
+means that |liebracket| is offered a list of liebracket declarations.
+
+@<Lisp ini...@>=
+put('liebracket,'stat,'rlis)$
+
+@ The outline of the procedure |liebracket| is real simple: for each
+declaration offered extract all identifiers and dimensions from it,
+check if this gives rise to a valid liebracket declaration and finally
+set up the right environment.
+
+@u lisp procedure liebracket decl_list;
+begin scalar bracketname,generatorname,m,n,
+ algebra_elements,parameters,rtype,vector_structure,info_list;
+ for each decl in decl_list do
+ begin if length decl < 4 then @|
+ stop_with_error("LIEBRACKET:",decl,"invalid liebracket declaration",nil);@/
+ @<Get |bracketname|, |generatorname|, |m|, |n|,
+|algebra_elements| and |parameters|@>;
+ @<Check the liebracket declaration for its validity@>;
+ @<Set up the environment for liebracket |bracketname|@>;
+ end;
+end$
+
+@ Since |decl| is a list of length at least 4 we can retrieve the
+desired variables and dimensions from it. If there are no algebra
+elements or parameters specified, |algebra_elements| and |parameters|
+will become |nil|. We transform them in orderly lisp lists using
+|make_oplist|.
+
+@<Get |bracketname|, |generatorname|, |m|, |n|, |algebra_elements|
+ and |parameters|@>=@/
+bracketname:=car decl; generatorname:=cadr decl;@/
+m:=reval caddr decl; n:=reval cadddr decl;@/
+if decl:=cddddr decl then
+<<algebra_elements:=car decl;algebra_elements:=make_oplist(algebra_elements);@/
+if cdr decl then parameters:=cadr decl; parameters:=make_oplist(parameters)>>@;
+
+@ For a proper liebracket declaration |bracketname| and
+|generatorname| must both be identifiers and may not be any other REDUCE
+structure. Moreover |m| and |n| must both be positive integers.
+We do not check if all objects offered as algebra
+elements or parameters are identifiers, since this cannot do any
+harm.
+
+@<Check the liebracket declaration for its validity@>=
+if not idp bracketname or not idp generatorname or not fixp m or not
+ fixp n or m<0 or n<0 then @|
+ stop_with_error("LIEBRACKET:",decl,"invalid liebracket declaration",nil); @/
+if get(bracketname,'simpfn) then @|
+ stop_with_error("LIEBRACKET: operator",bracketname,
+ "invalid as liebracket",nil);@/
+if rtype:=get(bracketname,'rtype) then @|
+ stop_with_error("LIEBRACKET:",rtype,bracketname,"invalid as liebracket");@/
+if get(generatorname,'simpfn) then @|
+ stop_with_error("LIEBRACKET: operator",generatorname,
+ "invalid as generator",nil);@/
+if rtype:=get(generatorname,'rtype) then @|
+ stop_with_error("LIEBRACKET:",rtype,generatorname,"invalid as generator") @;
+
+@ If we have a proper liebracket declaration we have to set up an
+environment for the liebracket |bracketname|, first by properly
+initializing the |vector_structure| and secondly by putting all other
+necessary properties on the property list of |bracketname|.
+
+Notice that properties of a liebracket that are lists initially being
+empty need not be initialized. For convenience we will list here the
+lists of all properties associated with a liebracket and a Lie algebra
+generator, which we will use later on. For an explanation of the
+properties we refer to the sections where they were introduced.
+We also recall that we have to flag |bracketname| |full| in order to
+enable simplification in the way we perform it.
+
+@d list_of_properties_of_a_liebracket=@/
+'(vector_structure info_list !*jacobi_var!* even_dimension odd_dimension
+even_used odd_used degree_length degree_sequence algebra_elements
+parameters oplist resimp_fn
+generatorname rtype simpfn commutator_list identity_list
+unsolved_identities kvalue)@;
+@d list_of_properties_of_a_generator=@;@/
+'(bracketname rtype simpfn kvalue)@;
+
+@<Set up the environment for liebracket |bracketname|@>=
+@<Initialize the vectors |vector_structure| and |info_list|@>;
+put(bracketname,'vector_structure,vector_structure);@/
+put(bracketname,'info_list,info_list);@/
+put(bracketname,'!*jacobi_var!*,list t);@/
+put(bracketname,'even_dimension,m);@/
+put(bracketname,'odd_dimension,n);@/
+put(bracketname,'even_used,0);@/
+put(bracketname,'odd_used,0);@/
+put(bracketname,'degree_length,1);@/
+put(bracketname,'algebra_elements,algebra_elements);@/
+put(bracketname,'parameters,parameters);@/
+put(bracketname,'oplist,
+ bracketname . generatorname . 'list . 'df . algebra_elements);@/
+put(bracketname,'resimp_fn,'resimp_liebracket);@/
+put(bracketname,'generatorname,generatorname);@/
+put(bracketname,'rtype,'liebracket);@/
+put(bracketname,'simpfn,'simp_liebracket);@/
+put(generatorname,'bracketname,bracketname);@/
+put(generatorname,'rtype,'algebra_generator);@/
+put(generatorname,'simpfn,'simpiden);@/
+flag(list bracketname,'full) @;
+
+@ Now we know all properties associated to a liebracket we can also
+write the remaining part of the clear function of a liebracket, namely
+removing the properties (and flags). Notice that we do not remove the
+|klist|'s of the liebracket and the generators since the commutators
+and generators may be used elsewhere.
+
+@<Remove all prop...@>=
+begin scalar bracketname,generatorname;
+ bracketname:=val;
+ generatorname:=get(bracketname,'generatorname);
+ for each property in list_of_properties_of_a_liebracket do
+ remprop(bracketname,property);
+ for each property in list_of_properties_of_a_generator do
+ remprop(generatorname,property);@/
+ remflag(list bracketname,'full);
+end @;
+
+@ Recall that the vector structure containing all commutators is a
+double vector, the outer of dimension $m+n$, such that for $-n\leq
+i\leq m$ at index $n+i$ all commutators $\lie(i,j)$ with $i\leq j\leq
+m$ are stored at index $m-j$ in a vector of dimension $m-i$.
+Moreover, we have to initialize the ``special'' commutators
+$\lie(i,0)$ ($-n\leq i\leq 0$) and $\lie(0,j)$ and
+$\lie(j,j)$ ($0<j\leq m$) to 0 and mark them as special.
+The second field of each special entry is the klist replacement; it
+must be initialized to |nil|.
+
+@<Initialize |vector_structure|@>=
+vector_structure:=mkvect(m+n);
+for i:=-n:m do putv(vector_structure,n+i,mkvect(m-i));
+for i:=-n:0 do putv(getv(vector_structure,n+i),m,'(special) . nil . 0);
+for j:=1:m do
+ <<putv(getv(vector_structure,n),m-j,'(special) . nil . 0);
+ putv(getv(vector_structure,n+j),m-j,'(special) . nil . 0)>> @;
+
+@ The |info_list| has to be initialized as follows: each generator
+|y(i)| has initial degree 0, definition |y(i)| and history $i$.
+
+@<Initialize the vectors |vector...@>=
+@<Initialize |vector_...@>;
+info_list:=mkvect(m+n);
+for i:=-n:m do putv(info_list,n+i,'(0) . i . i) @;
+
+@*1 Saving and printing all values of a liebracket. Saving a
+liebracket |bracketname| boils down to saving all properties of
+|bracketname| in a file, this time including the |klist|'s of the
+liebracket and the generator. Before saving it all we have to call
+|rmsubs| in order to enable simplification of algebraic expressions
+after being read in. We print the values of all properties using the
+procedure |prin1|, which, unlike the procedure |prin2|, prints
+rereadable expressions.
+
+One should be aware of the fact that the standard REDUCE token reader
+|token1| is not able to recognize and return a vector as a token.
+However, on our system |token1| has been replaced by a token reader
+based on the lisp underneath REDUCE, which \`{\i}s able to read
+vectors. Moreover, on another configuration at our site which did use
+|token1| as the token reader, we could patch it in such way that it
+was also able to read vectors without too much difficulty.
+
+The implementation of |save_liebracket| beneath explicitly uses the
+fact that the token reader used is able to read vectors. If this is
+not the case |save_liebracket| has to be rewritten in such a way that
+all commutators to be saved are temporarily stored on a list which can
+be read by |token1|. In that case the vector structure has to be build
+up again. This case will be dealt with in a separate change file
+belonging to this package.
+
+The procedure |save_liebracket| has to be available in algebraic mode.
+
+@d print_this_property_of(bracketname)=@/
+<<prin2 "put('"; prin1 bracketname; prin2 ",'"; prin1 property; prin2 ",'";
+ prin1 get(bracketname,property); prin2 ")$"; terpri(); terpri()>> @;
+
+@u
+lisp operator save_liebracket;
+lisp procedure save_liebracket(bracketname,savefile);
+begin scalar generatorname;
+ check_if_bracketname_is_a_liebracket_in("SAVE_LIEBRACKET:");@/
+ generatorname:=get(bracketname,'generatorname);@/
+ rmsubs();
+ out savefile;@/
+ write "lisp$"; %Reading the properties should be done in symbolic mode%
+ terpri(); terpri();@/
+ @<Check if this package has been loaded@>;
+ for each property in 'klist . list_of_properties_of_a_liebracket do
+ print_this_property_of(bracketname);@/
+ write "flag('(",bracketname,"),'full)$"; terpri(); terpri();
+ for each property in 'klist . list_of_properties_of_a_generator do
+ print_this_property_of(generatorname);
+ @<Incorporate statements to repair the |vector_structure|@>;
+ write "algebraic$ end$";@/
+ shut savefile;
+end$
+
+@ We can check if this package has been loaded by verifying that the
+procedure |simp_liebracket| has a definition, using |getd|.
+
+@<Check if this package has been loaded@>=@/
+write "if not getd 'simp_liebracket then";terpri();
+write "rederr(",
+"""Load the Lie superalgebra package before reading this file""",")$";
+terpri();terpri() @;
+
+@ The informative part of some elements in a vector structure may have
+the value |(t)|, indicating that the commutator belonging to such an
+element has been reordered and the Jacobi identities with the
+commutator have been computed. In this case the value of this
+informative part is not ordinary |(t)| but in fact it is the value of
+|!*jacobi_var!*| belonging to the liebracket under consideration.
+After reading the vector structure from file this is not the case
+anymore, so we have to replace all occurences of |(t)| by
+|!*jacobi_var!*|. This is done by the procedure
+|repair_vector_structure_of|.
+
+Notice that due to the procedure |find_unprocessed_commutators_of|
+only commutators with |-n_used|${}\leq i,j \leq{}$|m_used| have
+been processed, hence these are the only commutators that have to be
+repaired.
+
+@u
+lisp procedure repair_vector_structure_of bracketname;
+begin scalar properties_for_direct_access,!*jacobi_var!*,vector_i,entry_i_j;
+ @<Initialize properties for dir...@>;
+ !*jacobi_var!*:=get(bracketname,'!*jacobi_var!*);
+ for i:=-n_used:m_used do
+ begin vector_i:=getv(vector_structure,n+i);
+ for j:=i:m_used do
+ if (entry_i_j:=getv(vector_i,m-j)) and informative_part_of(entry_i_j)='(t)
+ then @|
+ putv(vector_i,m-j,!*jacobi_var!* . k_info_and_commutator_part_of entry_i_j);
+ end;
+end$
+
+@ @<Incorporate statem...@>=@/
+write "repair_vector_structure_of '",bracketname,"$"; terpri(); terpri() @;
+
+@ The result of applying the procedure |save_liebracket| is a file,
+which can only be read using this package. It will also be convenient
+to have a procedure that lists all known commutators in a rereadable
+form. A statement |a:=b| can be printed like that by applying
+|varpri(b,list('setk,mkquote a,mkquote b),'only)|. With this knowledge
+we can easily implement a procedure |print_liebracket| which print the
+definitions of all known commutators $\lie(i,j)$ for |-n_used|${}\leq
+i\leq j\leq{}$|m_used|, which are not special. Printing of the
+definition of special commutators is not useful since these
+commutators will allways be 0.
+
+@u
+lisp operator print_liebracket;
+lisp procedure print_liebracket bracketname;
+begin scalar properties_for_direct_access,vector_i,commutator_i_j;
+ check_if_bracketname_is_a_liebracket_in("PRINT_LIEBRACKET:");@/
+ @<Initialize properties for dir...@>;
+ for i:=-n_used:m_used do
+ begin vector_i:=getv(vector_structure,n+i);
+ for j:=i:m_used do
+ if (i neq 0) and (j neq 0) and (i neq j or i<0) and @|
+ (commutator_i_j:=getv(vector_i,m-j)) and
+ (commutator_i_j:=aeval commutator_part_of commutator_i_j) then @|
+ varpri(commutator_i_j,@|
+ list('setk,mkquote list(bracketname,i,j),mkquote commutator_i_j),
+ 'only);
+ end;
+end$
+
+@*1 Changing the dimensions of a liebracket. Until now the dimensions
+of a liebracket have to be given on declaration and cannot be changed
+anymore. It would be very inconvenient if the only way to enlarge the
+dimensions is to declare a larger liebracket and do all computations
+again. Therefore we will write a procedure |change_dimensions_of|
+which does a better job. It can be used both to enlarge or diminish
+the dimensions of the Lie algebra. It should be available in algebraic
+mode.
+
+Essentially the only actions necessary for ``enlarging'' a liebracket are
+the construction of a larger/smaller |vector_structure|, putting all
+information from the old to the new vector structure and update the
+properties containing information about the dimensions.
+
+Moreover, if the new dimensions are bigger than the old ones, some of
+the newly introduced commutators may have to be adjusted according to
+linear dependencies found before and, moreover, the length of the
+degrees of the newly introduced generators has to be adapted.
+
+@u
+lisp operator change_dimensions_of;
+lisp procedure change_dimensions_of(bracketname,m,n);
+begin scalar old_vector_structure,old_m,old_n,new_m,new_n,old_vector_i,entry_i_j,
+ vector_structure,old_info_list,info_list,vector_i,m_used,n_used,
+ degree_length,kernel_list;
+ check_if_bracketname_is_a_liebracket_in("CHANGE_DIMENSIONS_OF:");@/
+ old_m:=get(bracketname,'even_dimension);
+ old_n:=get(bracketname,'odd_dimension);@/
+ new_m:=min(m,old_m);new_n:=min(n,old_n);@/
+ m_used:=min(new_m,get(bracketname,'even_used));
+ n_used:=min(new_m,get(bracketname,'odd_used));@/
+ old_vector_structure:=get(bracketname,'vector_structure);
+ old_info_list:=get(bracketname,'info_list);
+ @<Initialize the vectors |vector...@>;
+ @<Transfer all known commutators and degrees to the larger vectors@>;
+ put(bracketname,'vector_structure,vector_structure);@/
+ put(bracketname,'info_list,info_list);
+ put(bracketname,'even_dimension,m);
+ put(bracketname,'odd_dimension,n);@/
+ put(bracketname,'even_used,m_used);
+ put(bracketname,'odd_used,n_used);
+ @<Take care of the eventual linear dependencies and the degree length@>;
+end$
+
+@ We have to transfer all known commutators |bracketname(i,j)| with
+|-new_n|${}\leq i,j\leq{}$|new_m| and also all degrees of
+|generatorname(i)| for |-new_n|${}\leq i\leq{}$|new_m|.
+
+@<Transfer all known...@>=
+for i:=-new_n:new_m do
+begin
+ old_vector_i:=getv(old_vector_structure,old_n+i);@/
+ vector_i:=getv(vector_structure,n+i);
+ for j:=i:new_m do
+ if (entry_i_j:=getv(old_vector_i,old_m-j)) then
+ putv(vector_i,m-j,entry_i_j);@/
+ putv(info_list,n+i,getv(old_info_list,old_n+i));
+end @;
+
+@ We take care of eventual linear dependencies in a very pragmatic
+way: if the new dimensions are larger than the old ones, we just do
+the assignments for the generators again. The adjustment of the new
+commutators will then be taken care of automatically.
+
+If |degree_length| is the current degree length, changing the degree
+length for the newly introduced generators can be taken care of by two
+subsequent calls of |change_degree_length| with |2*degree_length| and
+|degree_length|, respectively.
+
+Notice that before taking care of the eventual dependencies the degree
+length has to possess its proper length since |relation_analysis| uses
+this to decide which kernel to solve for.
+
+@<Take care of the eventu...@>=
+if m>old_m or n>old_n then
+begin
+degree_length:=get(bracketname,'degree_length);
+change_degree_length(bracketname,2*degree_length);
+change_degree_length(bracketname,degree_length);
+kernel_list:=
+ for each dependency in get(get(bracketname,'generatorname),'kvalue) collect@|
+ first_element_of dependency;
+for each kernel in kernel_list do setk(kernel,aeval kernel);
+end
+
+@*= Printing and parsing of commutators. The next subject to be dealt
+with is the preparation of facilities for a ``default'' liebracket
+whose commutators can be typed in and will be printed out using square
+brackets. For this we will introduce a global variable
+|default_liebracket!*|, which is the name of the liebracket known to
+REDUCE as the default liebracket. We initialize it to |lie|, since
+this is the name we usually use.
+
+@<Lisp ini...@>=@/
+initialize_global(default_liebracket!*,'lie)$
+
+@ REDUCE input is parsed by the procedure |xread1|, which converts
+it to a form that can be translated to lisp by the procedure |form|.
+If we want REDUCE to translate expressions in square brackets as
+commutators of the default liebracket |default_liebracket!*|, we can
+do this by giving the token |![| the property |stat| with value
+|liebracket_stat|, indicating to the parser |xread1| that expressions
+in square brackets are to be dealt with by a separate procedure
+|liebracket_stat|, and flagging |!]| as a delimiter, again indicating
+to |xread1| that the expression currently being parsed has ended.
+
+@<Lisp ini...@>=@/
+put('![,'stat,'liebracket_stat)$@/
+flag(list '!],'delim)$
+
+@ If |xread1| encounters the token |![|, it calls the procedure
+|liebracket_stat|, which will take control over the parsing of the
+commutator that follows the opening bracket. The argument(s) of the
+commutator can be read by recursively calling |xread| which will parse
+until it encounters the delimiter |!]| and return the parsed
+arguments.
+
+Before returning the list representing the commutator of the default
+liebracket we must scan another token in order to keep the parsing
+process in a correct state.
+
+@u
+lisp procedure liebracket_stat;
+begin scalar arguments;
+ arguments := xread nil;@/
+ arguments :=@+
+ if atom arguments or car arguments neq '!*comma!* @| then
+ arguments @+
+ else cdr arguments;@/
+ scan();
+ return default_liebracket!* . arguments;
+end$
+
+@ If some algebraic operatorname has the property |prifn|, the printing
+routines of REDUCE will transfer the control over the printing of an
+element of such operatorname to the procedure which name is the value of
+the property |prifn|. So by introducing a |prifn| |liebracket_prifn|
+we can print the commutators of some liebracket using square brackets.
+
+If we want to print a commutator using square brackets we can print
+``['' and ``]'' and in between the arguments of the commutator
+separated by commas.
+
+@u
+lisp procedure liebracket_prifn commutator;
+begin
+ prin2!* "[";@/
+ inprint('!*comma!*,0,arguments_of commutator);@/
+ prin2!* "]";
+end$
+
+@ The operatorname initially declared default liebracket must have the
+right |prifn|.
+
+@<Lisp ini...@>=@/
+put(default_liebracket!*,'prifn,'liebracket_prifn)$
+
+@ The default liebracket can be changed by using the procedure
+|default_liebracket|, which is available in algebraic mode and takes
+all necessary actions.
+
+@u lisp operator default_liebracket;
+
+lisp procedure default_liebracket bracketname;
+begin
+ remprop(default_liebracket!*,'prifn);@/
+ default_liebracket!*:=bracketname;@/
+ put(default_liebracket!*,'prifn,'liebracket_prifn);
+end$
+
+@*= Basis transformations of Lie superalgebras. If one is working with
+a Lie superalgebra, the structure of which is partially determined and
+partially is to be determined, it may be very convenient to perform a
+basis transformation of this algebra. Proceeding this way the
+structure of the remaining part might become clearer. Of course if we
+perform a basis transformation, we also want to have all (known)
+commutators expressed in elements of the new basis. Hence we have to
+perform a transformation of the commutator table, i.e., the
+vectorstructure, too.
+
+For this suppose we are given a Lie (super)algebra with basis $x_i$
+$(i\in I)$, and furthermore suppose we have a basis transformation
+given by $y_j=a^i_j x_i$ $(j\in I)$, where we have used the sommation
+convention. Then in general a commutator $[x_k,x_l]$ $(k,l\in I,k\leq
+l)$ is given by
+$$[x_k,x_l]=c^i_{kl}x_i+\sum_{k',l'} [x_{k'},x_{l'}]_u$$
+where the subscript $u$ denotes (yet) unknown commutators, i.e.,
+commutators having empty entries in the vectorstructure. Using the
+basis transformation given above, we are interested in the commutators
+$$[y_p,y_q]=a^k_p a^l_q [x_k,x_l]$$
+with all commutators on the right hand side expressed in terms of the
+new basis $y_j$. Therefore we can perform the transformation of a Lie
+product table in two steps:\medskip
+
+\item{1.} Express all commutators $[x_k,x_l]$ in terms of the new
+basis.
+\item{2.} Express all commutators $[y_p,y_q]$ in terms of the new
+basis using the result of the first step.
+\enditem
+It seems clear that we need the inverse transformation
+$b^j_i=(a^i_j)^{-1}$ in order to perform the first step. Using the
+inverse transformation we get
+$$[x_k,x_l]=c^i_{kl}b^j_i y_j+\sum b^p_{k'}b^q_{l'}[y_p,y_q]$$
+
+For the implementation in REDUCE of this rather simple exercise there
+are some additional points involved. For instance, the newly created
+commutators should be stored in another liebracket since the
+generatorname changed from, let's say, $x$ to $y$. And, how exactly to
+perform the transformation and the inverse transformation. As we will
+see later on, we will use some rather tricky temporary demolishing of
+the old liebracket structure to get everything right. Moreover, for
+reasons of efficiency, we will temporarily bypass all kinds of checks
+performed on the assignment of commutators and instead perform one
+sufficient check for all assignments beforehand.
+
+@ The first point to be taken care of is how to deal with the
+transformation and inverse transformation. Points involved are {\it
+a\/}) how to represent the transformation, {\it b\/}) how to compute the
+inverse transformation and finally, in the light of the last remark of
+the previous section, {\it c\/}) how to see to it that the transformation
+leaves no elements untransformed.
+
+By a basis transformation we understand a (possibly empty) algebraic
+list of equations of the form $y_j=a^i_j x_j$, where $(a^i_j)$ is
+invertible. Notice that we do not require a basis transformation to
+comprise all old generators $x_i$, but also a subset is allowed.
+Nevertheless if we are transforming commutators to a new basis, such
+non occuring generators may appear in the computation of some
+commutators. Hence, in order to get a correct new commutator table,
+we must find the remaining non transformed generators and transform
+them into new generators.
+
+In ordinary cases it will be sufficient only to transform the used
+generators, by which we mean generators in one of the ranges
+$1,\dots,$|even_used| or $-1,\dots,$|odd_used|. However, for whatever
+reason, some generator outside these ranges may also be used, in which
+case transforming the used generators will not be sufficient.
+Therefore we will introduce a switch |full_transformation| indicating
+if transformation of the used generators is sufficient or if
+transformation of the whole algebra is necessary. We put
+|full_transformation| \&{off} be default.
+
+@<Lisp ini...@>=@/
+new_switch(full_transformation,nil)$
+
+@ Depending on the switch |full_transformation| we have different
+upperbounds for the even and odd generators to be transformed, namely
+the properties |even_used| and |odd_used| if |full_transformation| is
+\&{off}, or |even_dimension| and |odd_dimension| if
+|full_transformation| is \&{on}, of the liebracket under consideration.
+In both cases we will use vectors |transform_vector| and
+|inverse_vector| to store the basis transformation and its inverse.
+
+@<Get |even_bound| and |odd_bound| and initialize the vectors@>=
+ if null !*full_transformation then
+ begin even_bound:=get(bracketname,'even_used);
+ odd_bound:=get(bracketname,'odd_used);
+ end
+ else
+ begin even_bound:=get(bracketname,'even_dimension);
+ odd_bound:=get(bracketname,'odd_dimension);
+ end;@/
+ transform_vector:=mkvect(even_bound+odd_bound);
+ inverse_vector:=mkvect(even_bound+odd_bound) @;
+
+
+@ The outline of the top level transformation procedure
+|transform_liebracket| is very easy: extend and process the basis
+transformation, compute the inverse transformation, and transform
+the commutator table using these transformations.
+
+@u
+lisp operator transform_liebracket;
+lisp procedure transform_liebracket(bracketname,new_bracketname,
+ new_generatorname,basis_transformation);
+begin scalar generatorname,even_bound,odd_bound,transform_vector,inverse_vector,
+ new_generator,transformed_sq,splitted_sf,generator_list,x_gap,y_gap,
+ new_even_used,new_odd_used,result;
+ check_if_bracketname_is_a_liebracket_in("TRANSFORM_LIEBRACKET:");
+ generatorname:=get(bracketname,'generatorname);
+ @<Get |even_bound|...@>;
+ @<Extend and compute the basis transformation and its inverse@>;
+ @<Transform the liebracket |bracketname| into |new_bracketname|@>;
+end$
+
+@*1 Storage and extension of the transformation. Given the algebraic
+list |basis_transformation| representing the basis transformation we
+have to fill the vectors |transform_vector| and |inverse_vector|.
+Processing the transformation essentially consists of three steps:
+read in and process |basis_transformation|, compute the inverse
+transformation and extend the transformation to the whole range of
+generators that must be transformed.
+
+@<Extend and compute the ...@>=
+@<Read in and process |basis_transformation|@>;
+@<Compute and store the inverse transformation@>;
+@<Extend the transformation to |even_bound| and |odd_bound|@> @;
+
+@ A basis transformation consists of a number of transformation rules
+of the form $y_j=a^i_jx_i$, which we have to check for their validity
+and store in the vector |transform_vector|. These checks consist of:
+\medskip
+
+\item{1.} checking if the transformation rule is of the
+proper form.
+
+\item{2.} checking that the new generator $y_j$ lies
+within the proper range.
+
+\item{3.} checking that the right hand side of the transformation rule
+is indeed a sum of generators. This can for instance be done using
+the procedure |operator_coeff|. We will, however, use the low level
+procedure |split_form|, which underlies the procedure |operator_coeff|
+and acts on standard forms, since we can use the splitted forms
+returned by |split_form|, as we will see further on. The right hand
+side of the transformation rule is a sum of generators if the
+independent part, i.e., the |car|, of the result of |split_form| is
+|nil|.
+\item{4.} checking that the sign of the generators on the right hand
+side of the tranformation rules is the same as on the left hand side.
+\enditem
+Moreover, in order to know for which old generators we have to solve
+the set of transformation rules we store all occuring generators on
+|generator_list|.
+
+For each transformation rule we will store the right hand side as a
+standard quotient |transformed_sq| as well as the splitted list returned by
+|split_form|, |splitted_sf|.
+
+@d lhs=cadr
+@d rhs=caddr
+@d valid_transformation_rule = @/
+ (eqexpr transformation_rule and
+ not atom lhs transformation_rule and @|
+ operator_name_of lhs transformation_rule = new_generatorname) @;
+@d valid_generator(generator) = @/
+ (fixp generator and generator neq 0 and generator <= even_bound and
+generator >= -odd_bound)@;
+@d get_new_generator_ok= @/
+ <<new_generator:=first_argument_of lhs(transformation_rule);
+ valid_generator(new_generator)>>@;
+@d sign_and_bound_check= @/
+ for each generator in cdr splitted_sf product
+ if (generator:=first_argument_of car generator)*new_generator>0 and @|
+ valid_generator(generator) then 1 @+else 0 @;
+@d valid_transformed_sq = @/
+ null car splitted_sf and sign_and_bound_check=1 @;
+@d extend_used_generator_list= @/
+ for each generator in cdr splitted_sf do
+ if not member(generator:=car generator,generator_list) then
+ generator_list:=generator . generator_list @;
+@d store_transformation_rule(i,value)=@/putv(transform_vector,odd_bound+i,value)@;
+@d store_inverse_rule(i,value)=@/putv(inverse_vector,odd_bound+i,value)@;
+@d get_transform(i)=@/getv(transform_vector,odd_bound+i) @;
+@d get_inverse(i)=@/getv(inverse_vector,odd_bound+i) @;
+
+@ Given |basis_transformation| we need to process
+all transformation rules in order to get all generators to solve for.
+Solving the resulting system can be done by applying |solve|, but since our
+checks computed the transformations in quite a lot of ways and
+ensure us that we have a linear system of equations (due to the use of
+|split_form| which checks for linearity), we can also use the
+underlying solver for systems of linear equations |solvesys|. The
+arguments of |solvsys| are a list of standard forms to be solved and a
+list of kernels to solve for. Hence we have to generate a list of
+standard forms representing the transformation rules.
+
+Recall that the second argument of |split_form| is the list of
+operators with respect to which to split. Moreover, notice that the
+arguments of |transform_liebracket| are already simplified, since it
+is a lisp operator. Therefore, we can use |simp| without harm.
+
+@d return_transformation_as_sf=@/
+ numr subtrsq(!*k2q lhs(transformation_rule),transformed_sq) @;
+
+@<Read in and process |bas...@>=
+if atom basis_transformation or operator_name_of basis_transformation neq 'list
+then stop_with_error("TRANSFORM_LIEBRACKET",basis_transformation,
+ "not valid as a basis transformation",nil); @/
+basis_transformation:=
+for each transformation_rule in arguments_of basis_transformation collect
+ <<if not valid_transformation_rule or not get_new_generator_ok
+ then @| stop_with_error("TRANSFORM_LIEBRACKET:",lhs(transformation_rule),
+ "not allowed as a new generator",nil);@/
+ transformed_sq:=simp rhs(transformation_rule);
+ splitted_sf:=split_form(numr transformed_sq,list(generatorname));
+ if not valid_transformed_sq then
+ stop_with_error("TRANSFORM_LIEBRACKET",lhs(transformation_rule),
+ "must be a sum of generators with right sign",nil);@/
+ extend_used_generator_list;
+ store_transformation_rule(new_generator,transformed_sq . splitted_sf);
+ return_transformation_as_sf>> @;
+
+@ The result of |solvesys| is a list of a list of standard quotients
+being the solutions of the system for the list of kernels given as its
+second argument preceded by |t| if the system is found to be linear.
+If the system is inconsistent |solvesys| will return with an error.
+For the inverse transformation we will also store the standard
+quotient as well as the list of splitted standard forms returned by
+|split_form|.
+
+If the number of dependent variables of the system does not equal the
+number of equations, the system is not consistent and we can stop
+without trying to solve it.
+
+@<Compute and store the inverse...@>=
+if length generator_list neq length basis_transformation then
+ rederr "TRANSFORM_LIEBRACKET: inconsistent transformation";
+if basis_transformation then
+ basis_transformation:=caadr solvesys(basis_transformation,generator_list);
+for each generator in generator_list do
+ <<transformed_sq:=first_element_of basis_transformation;
+ store_inverse_rule(first_argument_of generator,
+ transformed_sq . @|split_form(numr transformed_sq,list(new_generatorname)));
+ @/ basis_transformation:=rest_of basis_transformation>> @;
+
+@ After the preceding steps we are left with two (possibly partially
+filled) vectors |transform_vector| and |inverse_vector| representing
+the basis transformation and its inverse. For a proper transformation
+of the commutator tables, however, we must be sure that both vectors
+are filled completely, as far as some old generators are not already
+found to be linear dependent. In other words, we have to extend the
+basis transformation to the full range $1,\dots,|even_bound|$ and
+$-1,\dots,-|odd_bound|$ of generators.
+
+Since we didn't require that the generators of the preceding steps be
+successive in any way, this boils down to filling in the gaps in both
+|transform_vector| and |inverse_vector|. Since we want to fill in the gaps
+from low to high for both even and odd generators, we have to deal with even
+and odd generators separately, that is to say we will use an additional
+variable |direction| to indicate whether we look at even or odd gaps and a
+variable |bound| being |even_bound| or |odd_bound|, respectively.
+
+So it is our task to go through both positive and negative ranges of
+generators and check if there is a gap, i.e., there is no transformation rule
+associated to a generator or there is a linear dependency for a generator
+(since these generators will never occur again). If we have found a gap
+|x_gap| in the transformation for the old generators, then there must
+also be a gap |y_gap| for the new generators, and we can extend the
+transformation by transforming |x_gap| into |y_gap| and vice versa.
+
+@d find_next_x_gap=@/
+ repeat x_gap:=x_gap+direction
+ until abs(x_gap)>bound or @|(null getv(inverse_vector,odd_bound+x_gap)
+ and @| null assoc(list(generatorname,x_gap),get(generatorname,'kvalue)));
+ if abs(x_gap)>bound then x_gap:=nil @;
+
+@d find_next_y_gap=@/
+ repeat y_gap:=y_gap+direction
+ until abs(y_gap)>bound or null getv(transform_vector,odd_bound+y_gap) @;
+
+@d exchange_gaps=@/
+ store_inverse_rule(x_gap, mksq(list(new_generatorname,y_gap),1) . @|
+ list(nil,list(new_generatorname,y_gap) . 1));@/
+ store_transformation_rule(y_gap, mksq(list(generatorname,x_gap),1) . @|
+ list(nil,list(generatorname,x_gap) . 1)) @;
+
+@d fill_in_the_gaps=@/
+x_gap:=y_gap:=0; find_next_x_gap; find_next_y_gap;
+while x_gap do @+<<exchange_gaps; find_next_x_gap; find_next_y_gap>> @;
+
+@<Extend the transform...@>=
+<<fill_in_the_gaps; new_even_used:=y_gap-1>> where direction=1,bound=even_bound;
+<<fill_in_the_gaps; new_odd_used:=-y_gap-1>> where direction=-1,bound=odd_bound @;
+
+@*1 Transformation of the Lie product table. Now we have dealt with
+the most intricate part of the transformation, we can start earning
+from our efforts, since the remaining work merely consists of
+simplifying expressions. However, in order to save work as much as
+possible we will temporarily redefine some of the simplification
+functions and data structures associated to the old liebracket
+|bracketname|. Since we want to be sure to restore these changes
+afterwards, we will perform this part in a procedure |transform_table|
+and surround it by |errorset| in order to keep full control over
+|transform_table| in case of errors, i.e., if an error occurs
+|errorset| will return control to the calling procedure. In this way
+we can be sure that the original data structures can be restored.
+
+The result of |errorset| is a list containing the result of the
+procedure called by |errorset|.
+
+@<Transform the liebracket...@>=
+@<Save the original data structures of |bracketname|@>;
+result:=errorset(list('transform_table,mkquote bracketname,mkquote generatorname,
+ mkquote new_bracketname,mkquote new_generatorname,
+ mkquote even_bound,mkquote odd_bound,
+ mkquote new_even_used,mkquote new_odd_used,
+ mkquote transform_vector,mkquote inverse_vector),t,t);
+@<Restore the data structures of |bracketname|@>;
+if result then return
+ list('list,
+ @|('list . @+for i:=1:new_even_used collect mk!*sq car get_transform(i)),
+ @|('list . @+for i:=1:new_odd_used collect mk!*sq car get_transform(-i))) @;
+
+@ In particular, the vector structure of the old liebracket must be
+saved. We save it as the property |save_vector_structure|.
+
+@<Save the original...@>=
+put(bracketname,'save_vector_structure,get(bracketname,'vector_structure)) @;
+
+@ Transforming the commutator table can be done in two steps: first we have to
+express all old commutators in terms of the new generators, after that
+the new commutators can be expressed in terms of the old ones and then
+simplified to expressions in new generators.
+
+However, before that we have to declare |new_bracketname| a Lie
+(super)algebra. Notice that we have to take the same set of operators
+as |algebra_elements| and |parameters|, respectively. Since a
+liebracket declaration checks if its generator isn't already an
+algebraic operator and if so, returns with an error message, we have
+to remove the property |simpfn| for |new_generatorname|.
+
+Finally we will construct a grading for |new_bracketname|, using the
+grading of |bracketname|. Notice that this is only useful when all the
+transformation rules are homogeneous.
+
+@u
+lisp procedure transform_table(bracketname,generatorname,
+ new_bracketname,new_generatorname,even_bound,odd_bound,
+ new_even_used,new_odd_used,
+ transform_vector,inverse_vector);
+begin scalar m,n,vector_structure,vector_i,
+ save_vector_structure,save_vector_i,save_entry_i_j,arg_i,arg_j,degree_length;
+ remprop(new_generatorname,'simpfn);
+ apply1('liebracket,list list(new_bracketname,new_generatorname,
+ even_bound,odd_bound,
+ get(bracketname,'algebra_elements),get(bracketname,'parameters)));
+ @<Redefine the old vector structure@>;
+ @<Compute and store the new vector structure@>;
+ @<Construct a grading for |new_bracketname|@>;
+end$
+
+@ An entry of the vector structure may or may not have a value. If it
+has a value we have to simplify it in such a way that all occurences
+of old generators are replaced by new generators. It is clear that we
+can use |inverse_vector| to this purpose. More specifically, we will
+replace the original |simpfn| |simpiden| by |simp_transform_vector|
+that takes it values from |inverse_vector|.
+
+Since we have to be sure that the generators to be simplified lie
+within the range covered by |inverse_vector|, we check for this.
+Moreover, we need to know where to get |inverse_vector|. For this
+purpose we will flag |generatorname| |full|, in which way the
+generatorname will be added to the arguments of its simplication
+function. We store |inverse_vector| on the property list of
+|generatorname|, as well as |bounds|, i.e. the even and odd bound of
+before, as we need these quantities to access |inverse_vector|.
+
+Notice that |inverse_vector| may contain empty entries, namely for
+those entries that correspond to linear dependent generators. For
+these generators, we may simply apply |simpiden| for further
+simplification.
+
+@u
+
+lisp procedure simp_transform_vector generator;
+begin scalar generatorname,i,bounds,inverse_vector,value;
+ generatorname:=car generator;
+ i:=cadr generator;
+ bounds:=get(generatorname,'bounds);
+ inverse_vector:=get(generatorname,'inverse_vector);
+ if i<-car bounds or i>cdr bounds then
+ stop_with_error("TRANSFORM_LIEBRACKET:",generator,
+ "out of the transformation range. Use 'on fulltransformation;'.",nil);
+ return
+ if value:=getv(inverse_vector,car bounds+i) then car value
+ else simpiden generator
+end$
+
+@ Of course we have to put some additional properties on the property
+list of |generatorname|. Moreover we have to apply |rmsubs| so that we
+can be sure that the result of |simpiden| will be resimplified.
+
+@<Take preparations for temporary simplification@>=@/
+put(generatorname,'inverse_vector,inverse_vector);@/
+put(generatorname,'bounds,odd_bound . even_bound);@/
+put(generatorname,'simpfn,'simp_transform_vector);@/
+flag(list generatorname,'full);
+rmsubs() @;
+
+@ If an entry of |vector_structure| has no value, i.e., the commutator
+corresponding to it is not known, we have to express it in terms of
+the new liebracket and generators. To this purpose we will write a
+procedure |transform_commutator|, which computes, given two entries of
+|transform_vector| or |inverse_vector|, the commutator $[y_i,y_j]$
+expressed in old generators or $[x_i,x_j]$ expressed in new
+generators, respectively.
+
+The entries of both of the vectors mentioned above contain a dotted
+pair, the |car| of which is the generator as standard quotient, the
+|cdr| a list applicable by the procedure |build_sum| of the TOOLS
+package, used to compute the outcome of a multilinear operator applied
+to the numerators of its arguments, as a standard quotient. Therefore,
+we have to divide the result by the denominators of the standard
+quotients. Notice that the second argument of |build_sum| is a stack
+of splitted arguments, hence we have to reverse the arguments.
+
+@u
+lisp procedure transform_commutator(bracketname,transformed_i,transformed_j);
+quotsq(build_sum(bracketname,list(cdr transformed_j,cdr transformed_i)),@|
+ !*f2q multf(denr car transformed_i,denr car transformed_j))$
+
+@ With the above preparations redefining the |vector_structure| is
+utterly simple. Recall that entries of a vector structure are dotted
+pairs, the |car| of which is the informative part, to be initialized
+to |nil|, the |cadr| the klist info part, which for the temporary
+vector structure may be also be set to |nil|. Moreover, recall that
+|vector_structure| entries whose informative part is |'(special)|
+should not be changed.
+
+The reader should be aware that a |arg_i| in the code below
+will only be used if has a value, namely all commutators containing
+linear dependent generators have a value according to this dependency,
+so will be dealt with in the ``known part''. The same applies to the
+call of |get_inverse(j)|.
+
+After installing the temporary vector structure, we have to call
+|rmsubs| again, in order effectuate the resubstitution of the unknown
+commutators into commutators of the new liebracket.
+
+@<Redefine the old vector...@>=
+@<Take preparations for ...@>;
+save_vector_structure:=get(bracketname,'save_vector_structure);
+m:=get(bracketname,'even_dimension); n:=get(bracketname,'odd_dimension);
+@<Initialize |vector_structure|@>;
+for i:=-odd_bound:even_bound do begin
+ save_vector_i:=getv(save_vector_structure,n+i);
+ vector_i:=getv(vector_structure,n+i);
+ arg_i:=get_inverse(i);
+ for j:=i:even_bound do
+ if (save_entry_i_j:=getv(save_vector_i,m-j)) and
+ commutator_part_of(save_entry_i_j) then @/
+ (if not_special(save_entry_i_j) then @|
+ putv(vector_i,m-j,nil . nil . aeval commutator_part_of save_entry_i_j))
+ else putv(vector_i,m-j,@|
+ nil . nil . mk!*sq transform_commutator(new_bracketname,arg_i,get_inverse(j)))
+end;
+put(bracketname,'vector_structure,vector_structure);
+rmsubs() @;
+
+@ After the redefinition of the vector structure of |bracketname| any
+commutator of |bracketname| will be automatically simplified to an
+expression in commutators and generators of the new liebracket. Hence
+a commutator $[y_i,y_j]$ of the transformed liebracket can be computed
+in two ways: using the transformation it can be expressed in terms of
+the old generators, which will be simplified to an expression in the
+new generators, or just as |new_bracketname(i,j)|. This gives rise to
+relation for |new_bracketname| which can be solved and stored using
+|relation_analysis|. As we will use !*SQ prefix forms, which will not
+be simplified again, to represent the relation, we must be sure that
+full simplication has taken place, i.e., we have to apply |subs2| or
+|simp!*| at the right places.
+
+Notice that due to linear dependencies of the old generators the
+vector |transform_vector| need not be filled entirely. Due to
+|fill_in_the_gaps| we know, however, that with the exception of 0
+|transform_vector| is exactly filled from |-new_odd_used| to
+|new_even_used|. Of course we don't have to compute commutators
+outside of this range. ``Special'' commutators need to be solved
+neither. Since we don't use the vector structure here to see if a
+commutator is special we will check using |i| and |j| directly.
+
+Finally we will set |even_used| and |odd_used| to |new_even_used| and
+|new_odd_used|, respectively, for the newly created
+liebracket, as these are the actual numbers of used even and odd generators.
+
+@d no_special_pair_i_j= @/
+ i neq 0 and j neq 0 and (i neq j or i<0) @;
+
+@<Compute and store the new...@>=
+for i:=-new_odd_used:new_even_used do
+ if (arg_i:=get_transform(i)) then
+ for j:=i:new_even_used do
+ if (arg_j:=get_transform(j)) and no_special_pair_i_j then @|
+ relation_analysis(mk!*sq subtrsq(simp!* list(new_bracketname,i,j),@|
+ subs2 transform_commutator(bracketname,arg_i,arg_j)),
+ new_bracketname);
+put(new_bracketname,'even_used,new_even_used);
+put(new_bracketname,'odd_used,new_odd_used)@;
+
+@ Using |transform_vector| and the procedure |degree_of| and
+|define_degree| it is not very hard to construct a grading for
+|new_bracketname|, under the assumption that the transformation is
+homogeneous w.r.t.\ this grading. Notice that all elements of
+|transform_vector| are filled consecutively from |-new_odd_used| to
+|new_even_used|, with the exception of 0.
+
+Before doing anything we should, however, change the length of the
+grading of |new_bracketname| to the length of the grading of
+|bracketname|, that is, to the length of the list of currently used
+components of the grading of |bracketname|.
+
+@<Construct a grading...@>=@/
+degree_length:=if get(bracketname,'degree_sequence) then
+ length get(bracketname,'degree_sequence)
+ else get(bracketname,'degree_length);
+change_degree_length(new_bracketname,degree_length);
+for i:=-new_odd_used:new_even_used do
+ if i neq 0 then
+ define_degree(list(new_generatorname,i),degree_of(mk!*sq car get_transform(i)))
+
+@ @<Restore the data stru...@>=@/
+put(bracketname,'vector_structure,get(bracketname,'save_vector_structure));
+remprop(bracketname,'save_vector_structure);
+put(generatorname,'simpfn,'simpiden);
+remprop(generatorname,'inverse_vector);
+remflag(list generatorname,'full);
+remprop(generatorname,'bounds) @;
+
+@*= Necessary changes to the klist mechanism. In one of the previous
+sections we already explained that the ordinary klist mechanism of
+REDUCE is not very suited for liebrackets, since all occuring
+commutators are stored on a linear list, where the number of
+commutators may be quit big. Moreover we made some preparations in the
+vector structure of a liebracket, in order to replace the ordinary
+klist mechanism with an information system which is based on the
+vector structure.
+
+Here, it is our intention to change two basic procedures of the REDUCE
+source in such a way that the outer appearance of the system remains
+the same, whereas hidden under the surface for liebrackets the klist
+mechanism is replaced by a vector structure based counterpart.
+
+@ The first procedure to be changed is |fkern|. It is used by |mksq| and
+checks if there is a klist entry for some kernel, if not, it generates one,
+and eventually, returns this entry.
+
+Changes are obvious: if the operatorname of the kernel is a liebracket
+and both arguments are integers, not the klist should be used but the
+vector structure of the concerning liebracket. If not both arguments
+are integers, we can only use the klist mechanism.
+
+@u
+symbolic procedure fkern u;
+ begin scalar x,y;
+ if atom u then @+return list(u,nil);
+ if get(operator_name_of u,'rtype)='liebracket and @|
+ fixp first_argument_of u and fixp second_argument_of u then @+
+ return fkern_liebracket u;
+ 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$
+
+@ The procedure |fkern_liebracket| is fairly simple. If the
+|k_info_of| the vector structure entry of the considered
+commutator exists, return it, otherwise construct it and adapt the
+vector structure accordingly. For the last action we shall use
+|rplaca|. It is easily seen that the use of |rplaca| causes no harm.
+
+Since the |k_info| can be found directly in the vector structure, and
+doesn't have to be found by association, one would expect that the
+kernel can be removed from the |k_info| entry. This, however, is not
+true: the kernel in the |k_info| is used by |mksq| to obtain an identical
+address for the considered kernel in all standard quotients. Thus a
+lot of memory can be saved.
+
+Notice that the arguments of the considered commutator need not be
+checked to lie within proper bounds. This is due to the fact that
+|fkern| (indirectly) only is called from procedures which have already
+checked the bounds.
+
+@u symbolic procedure fkern_liebracket commutator;
+begin scalar bracketname,i,j,entry_i_j;
+ bracketname:=operator_name_of commutator;
+ i:=first_argument_of commutator;
+ j:=second_argument_of commutator;
+ entry_i_j:=get_vector_structure(bracketname,i,j);
+ if null entry_i_j then @|entry_i_j:=
+ put_vector_structure(bracketname,i,j,nil . list(commutator,nil) . nil)
+ else if null k_info_of entry_i_j then @|
+ rplaca(k_info_and_commutator_part_of entry_i_j,list(commutator,nil));
+ return k_info_of entry_i_j;
+end$
+
+@ The procedure |prepsq!*| is used to reorder an algebraic expression
+for output. After |factor O;| the expression is ordered w.r.t. all
+kernels of the operator $O$. The order of the kernels of the operator
+$O$ is governed by its klist. Since the klist of a liebracket is not
+complete, in fact it only contains info about commutators containing
+non integer arguments, we have to choose a different method here. We
+do this as follows: we find all the kernels of the concerning
+liebracket using the procedure |find_all_kernels| of the TOOLS package
+and order the thus obtained list of kernels w.r.t.\ the standard
+kernel ordering of REDUCE, by calling the procedure |ordn|. This list
+can now be used as a replacement for the klist.
+
+@u
+symbolic procedure prepsq!* u;
+ begin scalar x,!*combinelogs;
+ if null numr u then return 0;
+ x := setkorder
+ append((for each j in factors!*
+ join if not idp j then nil
+ else if get(j,'rtype)='liebracket then
+ ordn get_all_kernels(numr u,j)
+ 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 !*div
+ or upl!* or dnl!*
+ then replus prepsq!*1(numr u,denr u,nil)
+ else sqform(u,function prepsq!*2);
+ setkorder x;
+ return u
+ end$
+
+@ The end of a REDUCE input file must be marked with |end|.
+@u end@+;
+
+@*= Index. This section contains the cross reference index of all
+identifiers, together with the numbers of the modules in which they
+are used. Underlined entries correspond to module numbers where the
+identifier was declared.
+\bigskip
diff --git a/web/reduce/rweb/appl/liesuperconvert.web b/web/reduce/rweb/appl/liesuperconvert.web
new file mode 100644
index 0000000000..1c03f50920
--- /dev/null
+++ b/web/reduce/rweb/appl/liesuperconvert.web
@@ -0,0 +1,51 @@
+% Copyright (c) 1991 Marcel Roelofs, University of Twente, Enschede,
+% The Netherlands.
+%
+% $Header: liesuperconvert.web,v 1.1 91/09/18 17:49:54 roelofs Exp $
+%
+
+@* Conversion of vector structures. In the latest version of the
+LIESUPER package, the klist mechanism has been replaced by a vector
+structure based mechanism to check wether a commutator has been used
+in any other algebraic expression or not. Due to this change the
+entries of a vector structure also have changed. As a consequence,
+save files of liebrackets written by the old package cannot be used by
+the current package anymore.
+
+Fortunately, it is still possible to read saved liebrackets without
+damaging any information. The following procedure will convert the
+vector structure of former liebrackets to the corresponding vector
+structure of the current liebrackets. In order to understand what
+happens we refer to the documentation of the LIESUPER package.
+
+@d old_informative_part_of=car
+@d old_commutator_part_of=cdr
+
+@u lisp operator convert_liebracket;
+lisp procedure convert_liebracket bracketname;
+begin scalar m,n,klist,vector_structure,vector_i,entry_i_j,k_info_i_j;
+ if get(bracketname,'rtype) neq 'liebracket then
+ rederr "CONVERT_LIEBRACKET: argument must be a liebracket";
+ m:=get(bracketname,'even_dimension);
+ n:=get(bracketname,'odd_dimension);
+ klist:=get(bracketname,'klist);
+ vector_structure:=get(bracketname,'vector_structure);
+ for i:=-n:m do
+ begin vector_i:=getv(vector_structure,n+i);
+ for j:=i:m do
+ begin entry_i_j:=getv(vector_i,m-j);
+ k_info_i_j:=assoc(list(bracketname,i,j),klist);
+ if entry_i_j then
+ putv(vector_i,m-j,old_informative_part_of entry_i_j . k_info_i_j .
+ old_commutator_part_of entry_i_j)
+ else if k_info_i_j then
+ putv(vector_i,m-j,nil . k_info_i_j . nil);
+ if k_info_i_j then klist:=delete(k_info_i_j,klist)
+ end
+ end;
+ put(bracketname,'klist,klist)
+end$
+
+@ Any REDUCE file must end with |end@;|.
+
+@u end;
diff --git a/web/reduce/rweb/appl/list2vector.ch b/web/reduce/rweb/appl/list2vector.ch
new file mode 100644
index 0000000000..cb6df64e33
--- /dev/null
+++ b/web/reduce/rweb/appl/list2vector.ch
@@ -0,0 +1,107 @@
+% Copyright (c) 1991 Marcel Roelofs, University of Twente, Enschede,
+% The Netherlands.
+%
+% $Header: list2vector.ch,v 1.2 91/10/23 09:37:31 roelofs Exp $
+%
+@x
+One should be aware of the fact that the standard REDUCE token reader
+|token1| is not able to recognize and return a vector as a token.
+However, on our system |token1| has been replaced by a token reader
+based on the lisp underneath REDUCE, which \`{\i}s able to read
+vectors. Moreover, on another configuration at our site which did use
+|token1| as the token reader, we could patch it in such way that it
+was also able to read vectors without too much difficulty.
+
+The implementation of |save_liebracket| beneath explicitly uses the
+fact that the token reader used is able to read vectors. If this is
+not the case |save_liebracket| has to be rewritten in such a way that
+all commutators to be saved are temporarily stored on a list which can
+be read by |token1|. In that case the vector structure has to be build
+up again. This case will be dealt with in a separate change file
+belonging to this package.
+
+The procedure |save_liebracket| has to be available in algebraic mode.
+
+@d print_this_property_of(bracketname)=@/
+<<prin2 "put('"; prin1 bracketname; prin2 ",'"; prin1 property; prin2 ",'";
+ prin1 get(bracketname,property); prin2 ")$"; terpri(); terpri()>> @;
+
+@u
+lisp operator save_liebracket;
+lisp procedure save_liebracket(bracketname,savefile);
+begin scalar generatorname;
+ check_if_bracketname_is_a_liebracket_in("SAVE_LIEBRACKET:");@/
+ generatorname:=get(bracketname,'generatorname);@/
+ rmsubs();
+ out savefile;@/
+ write "lisp$"; %Reading the properties should be done in symbolic mode%
+ terpri(); terpri();@/
+ @<Check if this package has been loaded@>;
+ for each property in 'klist . list_of_properties_of_a_liebracket do
+ print_this_property_of(bracketname);@/
+ write "flag('(",bracketname,"),'full)$"; terpri(); terpri();
+ for each property in 'klist . list_of_properties_of_a_generator do
+ print_this_property_of(generatorname);
+ @<Incorporate statements to repair the |vector_structure|@>;
+ write "algebraic$ end$";@/
+ shut savefile;
+end$
+@y
+One should be aware of the fact that the standard REDUCE token reader
+|token1| is not able to recognize and return a vector as a token.
+However, on our system |token1| has been replaced by a token reader
+based on the lisp underneath REDUCE, which \`{\i}s able to read
+vectors. Moreover, on another configuration at our site which did use
+|token1| as the token reader, we could patch it in such way that it
+was also able to read vectors without too much difficulty.
+
+Here, however, we will give an implementation for those systems which have
+|token1| as their token reader, or which have another token reader
+uncapable of reading vectors. This means that we have to transform the
+vectors |info_list| and |vector_structure| into a list and a list of
+lists, respectively, hence have to be dealt with separately.
+
+The procedure |save_liebracket| has to be available in algebraic mode.
+
+@d print_this_property_of(bracketname)=@/
+<<prin2 "put('"; prin1 bracketname; prin2 ",'"; prin1 property; prin2 ",'";
+ prin1 get(bracketname,property); prin2 ")$"; terpri(); terpri()>> @;
+
+@u
+lisp operator save_liebracket;
+lisp procedure save_liebracket(bracketname,savefile);
+begin scalar generatorname,vector_list;
+ check_if_bracketname_is_a_liebracket_in("SAVE_LIEBRACKET:");@/
+ generatorname:=get(bracketname,'generatorname);@/
+ rmsubs();
+ out savefile;@/
+ write "lisp$"; %Reading the properties should be done in symbolic mode%
+ terpri(); terpri();@/
+ @<Check if this package has been loaded@>;
+ for each property in 'klist . cddr list_of_properties_of_a_liebracket do
+ print_this_property_of(bracketname);@/
+ @<Save the vectors |vector_structure| and |info_list| as lists@>;
+ write "flag('(",bracketname,"),'full)$"; terpri(); terpri();
+ for each property in 'klist . list_of_properties_of_a_generator do
+ print_this_property_of(generatorname);
+ @<Incorporate statements to repair the |vector_structure|@>;
+ write "algebraic$ end$";@/
+ shut savefile;
+end$
+
+@ With the above procedures saving the vectors |vector_structure| and
+|info_list| as lists and reading these lists in as vectors is peanuts.
+The procedures |list2vector| and |vector2list| are already available
+in PSL, for which this changefile is meant primarily.
+
+@<Save the vectors ...@>=
+vector_list:=for each el in vector2list get(bracketname,'vector_structure)
+ collect vector2list el;
+prin2 "put('"; prin1 bracketname;
+prin2 ",'VECTOR_STRUCTURE,list2vector(for each el in '";
+prin1 vector_list; prin2 " collect list2vector el))$"; terpri(); terpri();
+vector_list:=vector2list get(bracketname,'info_list);
+prin2 "put('"; prin1 bracketname; prin2 ",'INFO_LIST,list2vector '";
+ prin1 vector_list; prin2 ")$"; terpri(); terpri()
+
+@z
diff --git a/web/reduce/rweb/appl/source/integrator.red b/web/reduce/rweb/appl/source/integrator.red
new file mode 100644
index 0000000000..9cc67dd711
--- /dev/null
+++ b/web/reduce/rweb/appl/source/integrator.red
@@ -0,0 +1,991 @@
+%5:%
+%line 72 "integrator.web"
+
+symbolic$
+write"Integrator package for REDUCE 3.4, $Revision: 0.92 $"$terpri()$
+%9:%
+%line 213 "integrator.web"
+
+%line 214 "integrator.web"
+put( 'initialize_equations, 'psopfn, 'initialize_equations1)$
+
+%:9%%13:%
+%line 294 "integrator.web"
+
+
+global '(current_equation_set!*)$
+current_equation_set!*:= 'equ$
+
+%:13%%18:%
+%line 382 "integrator.web"
+
+
+
+fluid '(!*coefficient_check)$
+!*coefficient_check:=t$
+flag( '(coefficient_check), 'switch)$
+
+%:18%%30:%
+%line 597 "integrator.web"
+
+%line 598 "integrator.web"
+
+
+fluid '(!*polynomial_check)$
+!*polynomial_check:=nil$
+flag( '(polynomial_check), 'switch)$
+
+%:30%%50:%
+%line 955 "integrator.web"
+
+%line 956 "integrator.web"
+
+
+fluid '(!*allow_differentiation)$
+!*allow_differentiation:=nil$
+flag( '(allow_differentiation), 'switch)$
+
+%:50%%61:%
+%line 1185 "integrator.web"
+
+%line 1186 "integrator.web"
+
+fluid '(listpri_depth!*)$
+listpri_depth!*:=40$
+
+%:61%
+%line 75 "integrator.web"
+
+algebraic$
+
+%:5%%10:%
+%line 217 "integrator.web"
+
+%line 218 "integrator.web"
+lisp procedure initialize_equations1 specification_list;
+begin scalar operator_name,total_used,variable_list,
+specification,even_used,odd_used,
+constant_operator,bracketname,function_name,function_list;
+if length specification_list<5 then
+rederr("INITIALIZE_EQUATIONS: wrong number of parameters");
+if not idp(operator_name:=car specification_list)then
+rederr("INITIALIZE_EQUATIONS: equations operator must be identifier");
+if not fixp(total_used:=
+reval car(specification_list:=cdr specification_list))
+or total_used<0 then
+rederr("INITIALIZE_EQUATIONS: total number of equations must be positive");
+put(operator_name, 'total_used,total_used);
+variable_list:=reval car(
+specification_list:=cdr specification_list);
+if atom variable_list or car variable_list neq 'list then
+rederr("INITIALIZE_EQUATIONS: variable list must be algebraic list");
+put(operator_name, 'variable_list,cdr variable_list);
+%11:%
+%line 265 "integrator.web"
+
+specification_list:=cdr specification_list;
+specification:=car specification_list;
+
+if atom specification or length specification neq 4 or car specification neq 'list
+or not idp(constant_operator:=cadr specification)or
+not fixp(even_used:=reval caddr specification)or
+not fixp(odd_used:=reval cadddr specification)
+or even_used<0 or odd_used<0 then
+
+msgpri("INITIALIZE_EQUATIONS: invalid declaration of",
+specification,nil,nil,t);
+put(operator_name, 'constant_operator,constant_operator);
+if get(constant_operator, 'rtype)= 'algebra_generator then
+put(operator_name, 'bracketname,
+bracketname:=get(constant_operator, 'bracketname));
+
+if get(constant_operator, 'rtype)= 'algebra_generator then
+define_used(bracketname,list( 'list,even_used,odd_used))
+else
+begin
+put(constant_operator, 'even_used,even_used);
+put(constant_operator, 'odd_used,odd_used);
+end
+
+%:11%
+%line 236 "integrator.web"
+;
+%12:%
+%line 276 "integrator.web"
+
+%line 277 "integrator.web"
+for each function_specification in cdr specification_list do
+begin
+
+if atom function_specification or length function_specification neq 4 or car function_specification neq 'list
+or not idp(function_name:=cadr function_specification)or
+not fixp(even_used:=reval caddr function_specification)or
+not fixp(odd_used:=reval cadddr function_specification)
+or even_used<0 or odd_used<0 then
+
+msgpri("INITIALIZE_EQUATIONS: invalid declaration of",
+function_specification,nil,nil,t);
+
+if get(function_name, 'rtype)= 'algebra_generator then
+define_used(bracketname,list( 'list,even_used,odd_used))
+else
+begin
+put(function_name, 'even_used,even_used);
+put(function_name, 'odd_used,odd_used);
+end;
+function_list:=function_name . function_list;
+end;
+put(operator_name, 'function_list,function_list)
+
+%:12%
+%line 237 "integrator.web"
+;
+end$
+
+%:10%%14:%
+%line 298 "integrator.web"
+
+%line 299 "integrator.web"
+lisp operator use_equations;
+lisp procedure use_equations operator_name;
+begin
+if idp operator_name then
+current_equation_set!*:=operator_name
+else rederr("USE_EQUATIONS: argument must be identifier");
+end$
+
+%:14%%15:%
+%line 315 "integrator.web"
+
+%line 316 "integrator.web"
+lisp operator integrate_equation;
+lisp procedure integrate_equation n;
+begin scalar listpri_depth!*,total_used,equation,denominator,
+solvable_kernel,solvable_kernels,df_list,df_kernel,
+function_list,present_functions_list,variable_list,absent_variables,
+polynomial_variables,equations_list,linear_functions_list,constants_list,
+bracketname,df_terms,df_functions,
+linear_functions,functions_and_constants_list,commutator_functions,
+present_variables,
+inhomogeneous_term,nr_of_variables,integration_variables,
+forbidden_functions,differentiations_list,polynomial_order;
+listpri_depth!*:=200;
+terpri!* t;
+%16:%
+%line 348 "integrator.web"
+
+if null(total_used:=get(current_equation_set!*, 'total_used))or
+n>total_used then
+
+msgpri("INTEGRATE_EQUATIONS: properly initialize",
+current_equation_set!*,nil,nil,t);
+if null(equation:=cadr assoc(list(current_equation_set!*,n),
+get(current_equation_set!*, 'kvalue)))then
+
+msgpri("INTEGRATE_EQUATION:",list(current_equation_set!*,n),
+"is non-existent",nil,t);
+denominator:=denr(equation:=simp!* equation);
+equation:=numr equation;
+if null equation then
+ <<write current_equation_set!*,"(",n,") = 0";terpri!* t;
+
+setk(list(current_equation_set!*,n),0);goto solved>>
+
+%:16%
+%line 329 "integrator.web"
+;
+%19:%
+%line 398 "integrator.web"
+
+df_list:=split_form(equation, '(df));
+if null car df_list and
+(cdr df_list)and length(cdr df_list)=1
+then
+if(solvable_kernel:=find_solvable_kernel(
+solvable_kernels:=list(car car cdr df_list),
+cdr df_list,denominator))then
+ <<df_kernel:=cadr solvable_kernel;
+setk(df_kernel,homogeneous_integration_of(solvable_kernel));
+depl!*:=
+delete(assoc(df_kernel,depl!*),depl!*);
+
+
+ <<write current_equation_set!*,"(",n,"): ","Homogeneous integration of ";maprin solvable_kernel;terpri!* nil;
+
+setk(list(current_equation_set!*,n),0);goto solved>> >>
+else
+ <<write"*** ",current_equation_set!*,"(",n,"): ","Homogeneous integration"," failed:";terpri!* t;
+write" coefficient not a number for ";
+maprin
+car solvable_kernels;terpri!* nil;
+write" Solvable with 'off coefficient_check'";
+terpri!* t;goto solved>>
+
+%:19%
+%line 330 "integrator.web"
+;
+%27:%
+%line 568 "integrator.web"
+
+%28:%
+%line 576 "integrator.web"
+
+%line 577 "integrator.web"
+function_list:=get(current_equation_set!*, 'function_list);
+present_functions_list:=get_recursive_kernels(equation,function_list);
+variable_list:=get(current_equation_set!*, 'variable_list);
+absent_variables:=variable_list;
+for each function in present_functions_list do
+for each variable in
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(function,depl!*))do
+absent_variables:=delete(variable,absent_variables)
+
+%:28%
+%line 569 "integrator.web"
+;
+%29:%
+%line 591 "integrator.web"
+
+%line 592 "integrator.web"
+polynomial_variables:=absent_variables;
+if !*polynomial_check then
+polynomial_variables:=for each variable in polynomial_variables join
+if polynomialp(equation,variable)then list(variable)
+
+%:29%
+%line 570 "integrator.web"
+;
+%32:%
+%line 614 "integrator.web"
+
+%line 615 "integrator.web"
+equations_list:=multi_split_form(equation,polynomial_variables);
+if length equations_list>1 then
+ <<for each pc_pair in cdr
+equations_list do
+setk(list(current_equation_set!*,(total_used:=total_used+1)),
+mk!*sq((cdr pc_pair) ./ 1));
+if car equations_list then
+setk(list(current_equation_set!*,(total_used:=total_used+1)),
+mk!*sq((car equations_list) ./ 1));
+write current_equation_set!*,"(",n,") breaks into ",
+current_equation_set!*,"(",get(current_equation_set!*, 'total_used)+1,
+"),...,",current_equation_set!*,"(",total_used,") by ";
+maprin partial_list(polynomial_variables,5);
+terpri!* nil;
+
+setk(list(current_equation_set!*,n),0);
+put(current_equation_set!*, 'total_used,total_used);
+goto solved
+>>
+
+%:32%
+%line 571 "integrator.web"
+
+
+%:27%
+%line 331 "integrator.web"
+;
+%34:%
+%line 652 "integrator.web"
+
+%line 653 "integrator.web"
+linear_functions_list:=split_form(car df_list,
+function_list);
+df_list:=cdr df_list;
+constants_list:=split_form(car linear_functions_list,
+list get(current_equation_set!*, 'constant_operator));
+linear_functions_list:=cdr linear_functions_list;
+if(bracketname:=get(current_equation_set!*, 'bracketname))then
+%35:%
+%line 669 "integrator.web"
+
+%line 670 "integrator.web"
+if length(df_list)=0 and
+length(linear_functions_list)=0 then
+ <<
+if atom(solvable_kernel:=
+relation_analysis(!*ff2a(equation,denominator),bracketname))
+then <<write current_equation_set!*,"(",n,") is a non-solvable Lie relation";
+terpri!* t>>
+else <<write current_equation_set!*,"(",n,") solved for ";maprin solvable_kernel;
+terpri!* t;
+setk(list(current_equation_set!*,n),0)>> ;
+goto solved
+>>
+
+%:35%
+%line 660 "integrator.web"
+
+
+%:34%
+%line 332 "integrator.web"
+;
+%36:%
+%line 710 "integrator.web"
+
+%line 711 "integrator.web"
+%37:%
+%line 725 "integrator.web"
+
+%line 726 "integrator.web"
+df_terms:=for each df_term in df_list join
+if member(car cadr car df_term,function_list)
+then list car df_term;
+for each df_term in df_terms do if not member(cadr
+df_term,df_functions)then df_functions:=cadr(df_term) . df_functions;
+functions_and_constants_list:=append(linear_functions_list,
+cdr constants_list);
+linear_functions:=for each linear_function in
+functions_and_constants_list collect car linear_function;
+if bracketname then commutator_functions:=
+get_recursive_kernels(car constants_list,
+get(current_equation_set!*, 'function_list));
+
+%:37%
+%line 712 "integrator.web"
+;
+%38:%
+%line 739 "integrator.web"
+
+%line 740 "integrator.web"
+present_variables:=variable_list;
+for each variable in absent_variables do
+present_variables:=delete(variable,present_variables);
+nr_of_variables:=length present_variables
+
+%:38%
+%line 713 "integrator.web"
+;
+for each kernel in linear_functions do if length
+
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(kernel,depl!*))=nr_of_variables then
+solvable_kernels:=kernel . solvable_kernels;
+for each kernel in append(df_functions,commutator_functions)do
+solvable_kernels:=delete(kernel,solvable_kernels);
+if solvable_kernels then
+%39:%
+%line 745 "integrator.web"
+
+%line 746 "integrator.web"
+ <<solvable_kernel:=
+find_solvable_kernel(solvable_kernels,functions_and_constants_list,denominator);
+if solvable_kernel then
+ <<linear_solve_and_assign(!*ff2a(equation,1),solvable_kernel);
+depl!*:=
+delete(assoc(solvable_kernel,depl!*),depl!*);
+
+
+ <<write current_equation_set!*,"(",n,"): ","Solved for ";maprin solvable_kernel;terpri!* nil;
+
+setk(list(current_equation_set!*,n),0);goto solved>>
+>>
+else
+ <<write"*** ",current_equation_set!*,"(",n,"): ","Solving a function"," failed:";terpri!* t;
+write" coefficient not a number for ";
+maprin
+partial_list(solvable_kernels,3);terpri!* nil;
+write" Solvable with 'off coefficient_check'";
+terpri!* t;goto solved>>
+>>
+
+%:39%
+%line 720 "integrator.web"
+
+
+%:36%
+%line 333 "integrator.web"
+;
+%40:%
+%line 772 "integrator.web"
+
+%line 773 "integrator.web"
+%41:%
+%line 784 "integrator.web"
+
+%line 785 "integrator.web"
+integration_variables:=present_variables;
+for each kernel in append(linear_functions,commutator_functions)do
+for each variable in
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(kernel,depl!*))do
+integration_variables:=delete(variable,integration_variables);
+for each df_function in df_functions do
+if not length
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(df_function,depl!*))=nr_of_variables then
+for each variable in
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(df_function,depl!*))do
+integration_variables:=delete(variable,integration_variables)
+
+%:41%
+%line 773 "integrator.web"
+;
+%43:%
+%line 813 "integrator.web"
+
+%line 814 "integrator.web"
+%44:%
+%line 824 "integrator.web"
+
+%line 825 "integrator.web"
+for each df_term in df_terms do
+ <<if length
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(cadr df_term,depl!*))=nr_of_variables
+and(check_differentiation_sequence(cdr cdr df_term,
+integration_variables)
+or member(cadr df_term,forbidden_functions))
+then solvable_kernels:=if member(cadr df_term,forbidden_functions)
+then list(nil,nil)else df_term . solvable_kernels;
+forbidden_functions:=(cadr df_term) . forbidden_functions>> ;
+
+%:44%
+%line 814 "integrator.web"
+;
+%45:%
+%line 834 "integrator.web"
+
+%line 835 "integrator.web"
+if solvable_kernels then
+if length(solvable_kernels)=1 then
+if(solvable_kernel:=find_solvable_kernel(solvable_kernels,df_list,denominator))
+then
+if(inhomogeneous_term:=linear_solve(mk!*sq(equation ./ 1),solvable_kernel))
+and(not !*polynomial_check or
+check_polynomial_integration(solvable_kernel,inhomogeneous_term))
+then
+ <<df_kernel:=cadr solvable_kernel;
+setk(df_kernel,
+inhomogeneous_integration_of(solvable_kernel,inhomogeneous_term));
+depl!*:=
+delete(assoc(df_kernel,depl!*),depl!*);
+
+
+ <<write current_equation_set!*,"(",n,"): ","Inhomogeneous integration of ";maprin solvable_kernel;terpri!* nil;
+
+setk(list(current_equation_set!*,n),0);goto solved>> >>
+else
+ <<write current_equation_set!*,"(",n,"): Inhomogeneous integration failed: ";terpri!* t;
+write"inhomogeneous term not polynomial in integration variables";
+terpri!* t;goto solved>>
+else
+ <<write"*** ",current_equation_set!*,"(",n,"): ","Inhomogeneous integration"," failed:";terpri!* t;
+write" coefficient not a number for ";
+maprin
+car solvable_kernels;terpri!* nil;
+write" Solvable with 'off coefficient_check'";
+terpri!* t;goto solved>>
+else <<write current_equation_set!*,"(",n,"): Inhomogeneous integration failed: ";terpri!* t;
+write"more terms with maximal dependency";terpri!* t;goto solved>>
+
+%:45%
+%line 815 "integrator.web"
+
+
+%:43%
+%line 774 "integrator.web"
+
+
+%:40%
+%line 334 "integrator.web"
+;
+%51:%
+%line 960 "integrator.web"
+
+%line 961 "integrator.web"
+%52:%
+%line 993 "integrator.web"
+
+
+present_variables:=for each variable in present_variables collect
+(variable . nil . 0);
+
+for each kernel in df_terms do
+for each variable in
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(cadr(kernel),depl!*))do
+
+rplacd(entry,kernel . (cddr entry+1))
+where entry=assoc(variable,present_variables);;
+
+for each kernel in linear_functions do
+for each variable in
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(kernel,depl!*))do
+
+rplacd(entry,kernel . (cddr entry+1))
+where entry=assoc(variable,present_variables);;
+if bracketname then
+for each kernel in commutator_functions do
+for each variable in
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(
+kernel,depl!*))do
+
+rplacd(entry,nil . (cddr entry+1))
+where entry=assoc(variable,present_variables);
+
+%:52%
+%line 961 "integrator.web"
+;
+%53:%
+%line 1007 "integrator.web"
+
+%line 1008 "integrator.web"
+differentiations_list:=
+for each entry in present_variables join
+if cadr entry and cddr entry=1 and
+(polynomial_order:=get_polynomial_order(
+linear_solve(mk!*sq(equation ./ 1),cadr entry),car entry))
+then list(car entry . cadr entry . (polynomial_order+1));
+if differentiations_list then
+if !*allow_differentiation then
+ <<for each entry in differentiations_list do
+setk(list(current_equation_set!*,(total_used:=total_used+1)),
+mk!*sq simpdf list(mk!*sq(equation ./ 1),
+car entry,cddr entry));
+write current_equation_set!*,"(",n,"): Generation of ",current_equation_set!*,"(",get(current_equation_set!*, 'total_used)+1,
+"),...,",current_equation_set!*,"(",total_used,") by differentiation w.r.t. ";
+terpri!* t;
+maprin partial_list(for each entry in differentiations_list collect
+list( 'list,car entry,cddr entry),10);
+terpri!* nil;
+put(current_equation_set!*, 'total_used,total_used);
+goto solved
+>>
+else <<
+write"*** ",current_equation_set!*,"(",n,
+"): Generation of new equations by differentiation possible.";
+terpri!* t;write" Solvable with 'on allow_differentiation'";
+terpri!* t;goto solved>>
+
+%:53%
+%line 962 "integrator.web"
+
+
+%:51%
+%line 335 "integrator.web"
+;
+%55:%
+%line 1054 "integrator.web"
+
+%line 1055 "integrator.web"
+write current_equation_set!*,"(",n,") not solved";terpri!* t
+
+%:55%
+%line 336 "integrator.web"
+;
+solved:
+end$
+
+%:15%%20:%
+%line 421 "integrator.web"
+
+%line 422 "integrator.web"
+lisp procedure find_solvable_kernel(kernel_list,kc_list,denominator);
+if !*coefficient_check then first_solvable_kernel(kernel_list,kc_list,denominator)
+else car kernel_list$
+
+
+lisp procedure first_solvable_kernel(kernel_list,kc_list,denominator);
+if kernel_list then
+(if numberp cdr kc_pair or
+numberp !*ff2a(cdr kc_pair,denominator)
+then car kc_pair
+else first_solvable_kernel(cdr kernel_list,kc_list,denominator))
+where kc_pair=assoc(car kernel_list,kc_list)$
+
+%:20%%21:%
+%line 458 "integrator.web"
+
+lisp procedure homogeneous_integration_of df_term;
+begin scalar df_function,function_number,dependency_list,integration_list,
+coefficient_name,bracketname,even_used,odd_used,
+integration_variable,
+number_of_integrations,solution,new_dependency_list;
+%22:%
+%line 483 "integrator.web"
+
+df_function:=cadr df_term;
+if not member(car df_function,get(current_equation_set!*, 'function_list))
+or not fixp(function_number:=cadr df_function)or function_number=0 then
+
+msgpri("PERFORM_HOMOGENEOUS_INTEGRATION: integration of",
+df_function,"not allowed",nil,t)
+
+%:22%
+%line 465 "integrator.web"
+;
+dependency_list:=
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(df_function,depl!*));
+if length dependency_list=1 then
+coefficient_name:=get(current_equation_set!*, 'constant_operator)
+else coefficient_name:=car df_function;
+%23:%
+%line 493 "integrator.web"
+
+%line 494 "integrator.web"
+if get(coefficient_name, 'rtype)= 'algebra_generator then
+begin bracketname:=get(current_equation_set!*, 'bracketname);
+even_used:=get(bracketname, 'even_used);
+odd_used:=get(bracketname, 'odd_used);
+end
+else
+begin
+even_used:=get(coefficient_name, 'even_used);
+odd_used:=get(coefficient_name, 'odd_used);
+end
+
+%:23%
+%line 470 "integrator.web"
+;
+integration_list:=cdr cdr df_term;
+%24:%
+%line 507 "integrator.web"
+
+%line 508 "integrator.web"
+if integration_list then integration_variable:=car
+integration_list else integration_variable:=nil;
+if integration_variable and(integration_list:=cdr integration_list)
+and fixp car integration_list then
+ <<number_of_integrations:=car integration_list;
+integration_list:=cdr integration_list>>
+else number_of_integrations:=1
+
+%:24%
+%line 472 "integrator.web"
+;
+if bracketname then
+%25:%
+%line 521 "integrator.web"
+
+%line 522 "integrator.web"
+if function_number>0 then
+(if even_used+number_of_integrations>get(bracketname, 'even_dimension)then
+change_dimensions_of(bracketname,even_used+number_of_integrations,
+get(bracketname, 'odd_dimension)))
+else
+(if odd_used+number_of_integrations>get(bracketname, 'odd_dimension)then
+change_dimensions_of(bracketname,get(bracketname, 'even_dimension),
+odd_used+number_of_integrations))
+
+%:25%
+%line 474 "integrator.web"
+;
+%26:%
+%line 544 "integrator.web"
+
+solution:=nil ./ 1;
+while integration_variable do
+begin new_dependency_list:=delete(integration_variable,dependency_list);
+for i:=0:number_of_integrations-1 do
+ <<solution:=addsq(solution,multsq(
+if i=0 then 1 ./ 1 else mksq(integration_variable,i),
+mksq(
+list(coefficient_name,if function_number>0 then
+(even_used:=even_used+1)else-(odd_used:=odd_used+1)),1)));
+if new_dependency_list then
+depl!*:=(list(coefficient_name,if function_number>0 then even_used
+else-odd_used) . new_dependency_list) . depl!*;
+>> ;
+%24:%
+%line 507 "integrator.web"
+
+%line 508 "integrator.web"
+if integration_list then integration_variable:=car
+integration_list else integration_variable:=nil;
+if integration_variable and(integration_list:=cdr integration_list)
+and fixp car integration_list then
+ <<number_of_integrations:=car integration_list;
+integration_list:=cdr integration_list>>
+else number_of_integrations:=1
+
+%:24%
+%line 553 "integrator.web"
+
+end;
+solution:=mk!*sq subs2 solution;
+
+if get(coefficient_name, 'rtype)= 'algebra_generator then
+define_used(bracketname,list( 'list,even_used,odd_used))
+else
+begin
+put(coefficient_name, 'even_used,even_used);
+put(coefficient_name, 'odd_used,odd_used);
+end
+
+%:26%
+%line 475 "integrator.web"
+;
+return solution
+end$
+
+%:21%%31:%
+%line 604 "integrator.web"
+
+%line 605 "integrator.web"
+lisp procedure polynomialp(expression,kernel);
+if domainp expression then t
+else((main_variable=kernel or not depends(main_variable,kernel))and
+polynomialp(lc expression,kernel)and polynomialp(red expression,kernel))
+where main_variable=mvar expression$
+
+%:31%%33:%
+%line 636 "integrator.web"
+
+%line 637 "integrator.web"
+lisp procedure partial_list(printed_list,nr_of_items);
+ 'list . broken_list(printed_list,nr_of_items)$
+
+lisp procedure broken_list(list,n);
+if list then if n=0 then '(!.!.!.)
+else car list . broken_list(cdr list,n-1)$
+
+%:33%%42:%
+%line 806 "integrator.web"
+
+%line 807 "integrator.web"
+lisp procedure check_differentiation_sequence(sequence,variable_list);
+if null sequence then t
+else if fixp car sequence or
+member(car sequence,variable_list)then
+check_differentiation_sequence(cdr sequence,variable_list)$
+
+%:42%%46:%
+%line 863 "integrator.web"
+lisp procedure check_polynomial_integration(df_term,integration_term);
+%line 864 "integrator.web"
+begin scalar numerator,denominator,integration_variables,variable,ok;
+numerator:=numr simp integration_term;
+denominator:=denr simp integration_term;
+integration_variables:=
+for each argument in cdr cdr df_term join
+if not fixp argument then list argument;
+ok:=t;
+while ok and integration_variables do
+ <<variable:=car integration_variables;
+ok:=(not depends(denominator,variable)and polynomialp(numerator,variable));
+integration_variables:=cdr integration_variables
+>> ;
+return ok;
+end$
+
+%:46%%47:%
+%line 884 "integrator.web"
+
+%line 885 "integrator.web"
+lisp procedure inhomogeneous_integration_of(df_term,inhomogeneous_term);
+begin scalar df_sequence,integration_variables,int_sequence,
+variable,nr_of_integrations,integration_terms,solution,
+powers,coefficient,int_factor,solution_term,n,k;
+df_sequence:=cdr cdr df_term;
+%48:%
+%line 905 "integrator.web"
+
+%line 906 "integrator.web"
+while df_sequence do
+ <<variable:=car df_sequence;
+df_sequence:=cdr df_sequence;
+if df_sequence and fixp car df_sequence then
+ <<nr_of_integrations:=car df_sequence;
+df_sequence:=cdr df_sequence>>
+else nr_of_integrations:=1;
+integration_variables:=variable . integration_variables;
+int_sequence:=(variable . nr_of_integrations) . int_sequence
+>>
+
+%:48%
+%line 890 "integrator.web"
+;
+integration_terms:=multi_split_form(numr simp inhomogeneous_term,
+integration_variables);
+integration_terms:=(nil . car integration_terms) .
+cdr
+integration_terms;
+
+%49:%
+%line 924 "integrator.web"
+
+%line 925 "integrator.web"
+solution:=nil ./ 1;
+for each term in integration_terms do
+ <<powers:=car
+term;coefficient:=cdr term;
+int_factor:=1;solution_term:=1 ./ 1;
+for each integration in int_sequence do
+ <<variable:=car integration;k:=cdr integration;
+n:=(if power then cdr power else 0)where power=assoc(variable,powers);
+
+for i:=1:k do int_factor:=(n+i)*int_factor;
+solution_term:=multsq(solution_term,mksq(variable,n+k))
+>> ;
+solution_term:=multsq(solution_term,coefficient ./ int_factor);
+solution:=addsq(solution,solution_term)
+>>
+
+%:49%
+%line 896 "integrator.web"
+;
+solution:=multsq(solution,1 ./ denr simp inhomogeneous_term);
+solution:=mk!*sq subs2 addsq(solution,simp homogeneous_integration_of df_term);
+return solution
+end$
+
+%:47%%54:%
+%line 1041 "integrator.web"
+
+%line 1042 "integrator.web"
+lisp procedure get_polynomial_order(expression,variable);
+if not depends(denr(expression:=simp expression),variable)and
+(not !*polynomial_check or polynomialp(numr expression,variable))then
+begin scalar kord!*;
+setkorder list !*a2k variable;
+expression:=reorder numr expression;
+return if mvar expression=variable then ldeg expression else 0;
+end$
+
+%:54%%56:%
+%line 1063 "integrator.web"
+
+%line 1064 "integrator.web"
+algebraic procedure integrate_equations(m,n);
+for i:=m:n do integrate_equation(i)$
+
+
+lisp operator integrate_exceptional_equation;
+lisp procedure integrate_exceptional_equation(n);
+integrate_equation(n)
+where
+!*coefficient_check=nil,
+!*polynomial_check=nil,
+!*allow_differentiation=t$
+
+
+%:56%%57:%
+%line 1085 "integrator.web"
+lisp operator show_equation;
+%line 1086 "integrator.web"
+lisp procedure show_equation n;
+begin scalar equation,total_used,function_list;
+if null(total_used:=get(current_equation_set!*, 'total_used))or
+n>total_used then
+
+msgpri("SHOW_EQUATION: properly initialize",
+current_equation_set!*,nil,nil,t);
+if(equation:=assoc(list(current_equation_set!*,n),get(current_equation_set!*, 'kvalue)))then
+begin
+equation:=setk(list(current_equation_set!*,n),aeval cadr equation);
+varpri(equation,list( 'setk,mkquote list(current_equation_set!*,n),mkquote equation), 'only);
+function_list:=get_recursive_kernels(numr simp equation,
+get(current_equation_set!*, 'function_list));
+if function_list then
+ <<terpri!* t;
+for each fn in function_list do
+ <<maprin(fn .
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(fn,depl!*)));terpri!* nil>>
+>>
+else terpri!* nil
+end
+end$
+
+
+algebraic procedure show_equations(m,n);
+for i:=m:n do show_equation i$
+
+%:57%%58:%
+%line 1112 "integrator.web"
+
+%line 1113 "integrator.web"
+lisp operator functions_used,put_functions_used,equations_used,put_equations_used;
+
+
+lisp procedure functions_used function_name;
+list( 'list,get(function_name, 'even_used),get(function_name, 'odd_used))$
+
+
+lisp procedure put_functions_used(function_name,even_used,odd_used);
+begin
+if not fixp even_used or even_used<0 or
+not fixp odd_used or odd_used<0 then
+
+msgpri("PUT_FUNCTIONS_USED: used functions number invalid",nil,nil,nil,t);
+put(function_name, 'even_used,even_used);
+put(function_name, 'odd_used,odd_used);
+end$
+
+
+lisp procedure equations_used;
+get(current_equation_set!*, 'total_used)$
+
+
+lisp procedure put_equations_used(n);
+if not fixp n or n<0 then
+
+msgpri("PUT_EQUATIONS_USED: used equation number invalid",nil,nil,nil,t)
+else put(current_equation_set!*, 'total_used,n)$
+
+%:58%%59:%
+%line 1149 "integrator.web"
+
+%line 1150 "integrator.web"
+lisp operator df_acts_as_derivation_on;
+
+lisp procedure df_acts_as_derivation_on operator_name;
+begin
+put(operator_name, 'dfform, 'df_as_derivation);
+end$
+
+%:59%%60:%
+%line 1161 "integrator.web"
+
+%line 1162 "integrator.web"
+lisp procedure df_as_derivation(kernel,variable,power);
+begin scalar left_part,right_part,argument,derivative;
+if power neq 1 then
+
+msgpri("DF_AS_DERIVATION:",kernel,"must occur linearly",nil,t);
+left_part:=list car kernel;right_part:=cdr kernel;
+derivative:=nil . 1;
+while right_part do
+ <<argument:=car right_part;right_part:=cdr right_part;
+derivative:=addsq(derivative,
+simp append(reverse left_part,list( 'df,argument,variable) . right_part));
+left_part:=argument . left_part;
+>> ;
+return derivative;
+end$
+
+%:60%%62:%
+%line 1191 "integrator.web"
+
+%line 1192 "integrator.web"
+lisp operator listlength$
+lisp procedure listlength l;
+listpri_depth!*:=l$
+
+%:62%%63:%
+%line 1200 "integrator.web"
+
+%line 1201 "integrator.web"
+symbolic procedure listpri l;
+begin scalar orig,split,u;
+u:=l;
+l:=cdr l;
+prin2!* get( '!*lcbkt!*, 'prtch);
+
+orig:=orig!*;
+orig!*:=if posn!*<18 then posn!* else orig!*+3;
+if null l then go to b;
+split:=treesizep(l,listpri_depth!*);
+a:maprint(negnumberchk car l,0);
+l:=cdr l;
+if null l then go to b;
+oprin '!*comma!*;
+if split then terpri!* t;
+go to a;
+b:prin2!* get( '!*rcbkt!*, 'prtch);
+orig!*:=orig;
+return u
+end$
+
+%:63%%64:%
+%line 1224 "integrator.web"
+end;
+%line 1225 "integrator.web"
+
+%:64%
diff --git a/web/reduce/rweb/appl/source/liesuper.red b/web/reduce/rweb/appl/source/liesuper.red
new file mode 100644
index 0000000000..e8c33d7efc
--- /dev/null
+++ b/web/reduce/rweb/appl/source/liesuper.red
@@ -0,0 +1,2908 @@
+%5:%
+%line 108 "liesuper.web"
+
+symbolic$
+write"Lie (super)algebra package for REDUCE 3.4, $Revision: 1.5 $"$terpri()$
+%6:%
+%line 120 "liesuper.web"
+
+%line 121 "liesuper.web"
+if not getd 'operator_coeff then
+
+msgpri("LIESUPER_INIT: load the TOOLS package before continuing",nil,nil,nil,nil)
+
+
+%:6%
+%line 111 "liesuper.web"
+$
+%33:%
+%line 844 "liesuper.web"
+
+%line 845 "liesuper.web"
+put( 'liebracket, 'rtypefn, 'liebracket_rtypefn)$
+put( 'liebracket, 'setelemfn, 'set_liebracket)$
+
+%:33%%43:%
+%line 1097 "liesuper.web"
+
+%line 1098 "liesuper.web"
+put( 'liebracket, 'clearfn, 'clear_liebracket)$
+
+
+%:43%%80:%
+%line 2099 "liesuper.web"
+
+%line 2100 "liesuper.web"
+
+
+global '(!*solve_parameters)$
+!*solve_parameters:=nil$
+flag( '(solve_parameters), 'switch)$
+
+%:80%%82:%
+%line 2133 "liesuper.web"
+
+%line 2134 "liesuper.web"
+
+
+global '(!*print_identities)$
+!*print_identities:=nil$
+flag( '(print_identities), 'switch)$
+
+%:82%%87:%
+%line 2233 "liesuper.web"
+
+global '(indentation_level!*)$
+initl!*:= 'indentation_level!* . initl!*$
+put( 'indentation_level!*, 'initl,0)$
+
+%:87%%97:%
+%line 2388 "liesuper.web"
+
+put( 'algebra_generator, 'setelemfn, 'set_generator)$
+put( 'algebra_generator, 'clearfn, 'clear_generator)$
+put( 'algebra_generator, 'rtypefn, 'generator_rtypefn)$
+
+%:97%%120:%
+%line 2879 "liesuper.web"
+
+%line 2880 "liesuper.web"
+put( 'definition_of, 'psopfn, 'definition_of1)$
+put( 'history_of, 'psopfn, 'history_of1)$
+
+
+%:120%%137:%
+%line 3198 "liesuper.web"
+
+%line 3199 "liesuper.web"
+put( 'liebracket, 'stat, 'rlis)$
+
+%:137%%154:%
+%line 3559 "liesuper.web"
+
+%line 3560 "liesuper.web"
+
+global '(default_liebracket!*)$
+default_liebracket!*:= 'lie$
+
+%:154%%155:%
+%line 3572 "liesuper.web"
+
+%line 3573 "liesuper.web"
+put( '![, 'stat, 'liebracket_stat)$
+flag(list '!], 'delim)$
+
+%:155%%158:%
+%line 3620 "liesuper.web"
+
+%line 3621 "liesuper.web"
+put(default_liebracket!*, 'prifn, 'liebracket_prifn)$
+
+%:158%%161:%
+%line 3708 "liesuper.web"
+
+%line 3709 "liesuper.web"
+
+
+global '(!*full_transformation)$
+!*full_transformation:=nil$
+flag( '(full_transformation), 'switch)$
+
+%:161%
+%line 112 "liesuper.web"
+
+algebraic$
+
+%:5%%17:%
+%line 490 "liesuper.web"
+
+%line 491 "liesuper.web"
+lisp procedure simp_liebracket val;
+if length val=3 then%18:%
+%line 503 "liesuper.web"
+
+%line 504 "liesuper.web"
+ begin scalar bracketname,arg1,arg2;
+bracketname:=car val;
+arg1:=mk!*sq simp!* cadr val;
+arg2:=mk!*sq simp!* caddr val;
+return
+if fixp arg1 and fixp arg2 then simp_liebracket_vector(bracketname,arg1,arg2)
+else%19:%
+%line 535 "liesuper.web"
+
+%line 536 "liesuper.web"
+ simp_multilinear list(bracketname,
+if fixp arg1 and arg1 neq 0 then list(generatorname,arg1)else arg1,
+if fixp arg2 and arg2 neq 0 then list(generatorname,arg2)else arg2)
+where generatorname=get(bracketname, 'generatorname)
+
+%:19%
+%line 510 "liesuper.web"
+;
+end
+
+%:18%
+%line 492 "liesuper.web"
+
+else if length val>3 then%22:%
+%line 592 "liesuper.web"
+
+%line 593 "liesuper.web"
+ begin scalar bracketname,arguments,result;
+bracketname:=car val;
+arguments:=reverse cdr val;
+result:=simp_liebracket list(bracketname,second arguments,first arguments);
+arguments:=cddr arguments;
+for each arg in arguments do
+result:=simp_liebracket list(bracketname,arg,mk!*sq result);
+return result;
+end
+
+%:22%
+%line 493 "liesuper.web"
+
+else rederr("SIMP_LIEBRACKET: wrong number of arguments")$
+
+%:17%%21:%
+%line 570 "liesuper.web"
+lisp procedure resimp_liebracket val;
+begin scalar bracketname,generatorname,arg1,arg2,resimplify;
+bracketname:=car val;
+generatorname:=get(bracketname, 'generatorname);
+arg1:=cadr val;arg2:=caddr val;
+
+if fixp arg1 then rederr("SIMP_LIEBRACKET: argument contains a non algebra element")
+else if car arg1=generatorname then arg1:=cadr arg1
+else if car arg1= 'list then
+ <<resimplify:=t;arg1:=bracketname . cdr arg1>> ;
+if fixp arg2 then rederr("SIMP_LIEBRACKET: argument contains a non algebra element")
+else if car arg2=generatorname then arg2:=cadr arg2
+else if car arg2= 'list then
+ <<resimplify:=t;arg2:=bracketname . cdr arg2>> ;
+return
+if resimplify then simp_liebracket list(bracketname,arg1,arg2)
+else
+if fixp arg1 and fixp arg2
+then simp_liebracket_vector(bracketname,arg1,arg2)
+else simp_liebracket_kvalue(bracketname,arg1,arg2);
+end$
+
+%:21%%27:%
+%line 732 "liesuper.web"
+
+lisp procedure even_element(bracketname,exprn);
+if fixp exprn then exprn>0
+else if car exprn=bracketname then
+((b1 and b2)or(not b1 and not b2))where
+b1=even_element(bracketname,cadr exprn),
+b2=even_element(bracketname,caddr exprn)
+else if car exprn= 'df then
+even_element(bracketname,cadr exprn)
+else if fixp cadr exprn then
+cadr exprn>0
+else
+msgpri("EVEN_ELEMENT: impossible to determine sign of",
+exprn,nil,nil,t)$
+
+%:27%%30:%
+%line 787 "liesuper.web"
+
+%line 788 "liesuper.web"
+lisp procedure simp_liebracket_vector(bracketname,arg1,arg2);
+begin scalar sign,commutator;
+%28:%
+%line 751 "liesuper.web"
+
+%line 752 "liesuper.web"
+if
+(if fixp arg1 and fixp arg2 then arg1>arg2 else
+ordp(arg1,arg2)and arg1 neq arg2)then
+begin scalar h;
+sign:=(even_element(bracketname,arg1)or even_element(bracketname,arg2));
+h:=arg1;arg1:=arg2;arg2:=h;
+end
+
+%:28%
+%line 790 "liesuper.web"
+;
+%29:%
+%line 763 "liesuper.web"
+
+%line 764 "liesuper.web"
+if arg1<-get(bracketname, 'odd_dimension)or arg2>get(bracketname, 'even_dimension)then
+
+msgpri("SIMP_LIEBRACKET:",list(bracketname,arg1,arg2),"out of range",nil,t)
+
+%:29%
+%line 791 "liesuper.web"
+;
+%68:%
+%line 1840 "liesuper.web"
+
+%line 1841 "liesuper.web"
+commutator:=
+getv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2);
+commutator:=
+if commutator and cddr commutator then
+if
+(car commutator and caar commutator neq 's
+)then
+if cddr commutator=0 then nil . 1
+else resimp cadr cddr commutator
+else simp cddr commutator
+else mksq(list(bracketname,arg1,arg2),1)
+
+
+%:68%
+%line 792 "liesuper.web"
+;
+return
+if sign then negsq commutator
+else commutator;
+end$
+
+%:30%%31:%
+%line 805 "liesuper.web"
+
+%line 806 "liesuper.web"
+lisp procedure simp_liebracket_kvalue(bracketname,arg1,arg2);
+begin scalar sign,commutator;
+%28:%
+%line 751 "liesuper.web"
+
+%line 752 "liesuper.web"
+if
+(if fixp arg1 and fixp arg2 then arg1>arg2 else
+ordp(arg1,arg2)and arg1 neq arg2)then
+begin scalar h;
+sign:=(even_element(bracketname,arg1)or even_element(bracketname,arg2));
+h:=arg1;arg1:=arg2;arg2:=h;
+end
+
+%:28%
+%line 808 "liesuper.web"
+;
+commutator:=assoc(list(bracketname,arg1,arg2),get(bracketname, 'kvalue));
+commutator:=
+if commutator then simp cadr commutator
+else mksq(list(bracketname,arg1,arg2),1);
+return
+if sign then negsq commutator
+else commutator;
+end$
+
+%:31%%34:%
+%line 849 "liesuper.web"
+
+%line 850 "liesuper.web"
+lisp procedure liebracket_rtypefn u;nil$
+
+%:34%%38:%
+%line 950 "liesuper.web"
+
+%line 951 "liesuper.web"
+lisp procedure set_liebracket(val,value);
+if length val neq 3 then
+rederr("SET_LIEBRACKET: assignment only possible to commutators")
+else begin scalar bracketname,generatorname,algebra_elements,arg1,arg2,
+error,sign;
+bracketname:=car val;
+generatorname:=get(bracketname, 'generatorname);
+algebra_elements:=bracketname . generatorname . get(bracketname, 'algebra_elements);
+arg1:=reval cadr val;
+arg2:=reval caddr val;
+%36:%
+%line 910 "liesuper.web"
+
+
+if atom arg1 then error:=
+((not fixp arg1)or arg1<-get(bracketname, 'odd_dimension)
+or arg1>get(bracketname, 'even_dimension))
+else begin
+error:=not member(car arg1,algebra_elements);
+if not error and car arg1=generatorname then
+begin
+arg1:=cadr arg1;
+error:=not atom arg1 or
+((not fixp arg1)or arg1<-get(bracketname, 'odd_dimension)
+or arg1>get(bracketname, 'even_dimension));
+end;
+end;
+if not error then
+if atom arg2 then error:=
+((not fixp arg2)or arg2<-get(bracketname, 'odd_dimension)
+or arg2>get(bracketname, 'even_dimension))
+else begin
+error:=not member(car arg2,algebra_elements);
+if not error and car arg2=generatorname then
+begin
+arg2:=cadr arg2;
+error:=not atom arg2 or
+((not fixp arg2)or arg2<-get(bracketname, 'odd_dimension)
+or arg2>get(bracketname, 'even_dimension));
+end;
+end;
+if error then
+rederr("SET_/CLEAR_LIEBRACKET: argument(s) invalid or out of range")
+
+%:36%
+%line 961 "liesuper.web"
+;
+%28:%
+%line 751 "liesuper.web"
+
+%line 752 "liesuper.web"
+if
+(if fixp arg1 and fixp arg2 then arg1>arg2 else
+ordp(arg1,arg2)and arg1 neq arg2)then
+begin scalar h;
+sign:=(even_element(bracketname,arg1)or even_element(bracketname,arg2));
+h:=arg1;arg1:=arg2;arg2:=h;
+end
+
+%:28%
+%line 962 "liesuper.web"
+;
+%37:%
+%line 934 "liesuper.web"
+
+error:=if fixp arg1 and fixp arg2 then
+(if entry then car entry)
+where entry=
+getv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2);
+if error then
+if car error= 's
+then
+rederr("SET_/CLEAR_LIEBRACKET: commutator can not be changed")
+else
+msgpri("SET_/CLEAR_LIEBRACKET: changing",
+list(bracketname,arg1,arg2),"may lead to errors",nil,nil)
+
+%:37%
+%line 963 "liesuper.web"
+;
+value:=aeval value;
+%35:%
+%line 866 "liesuper.web"
+
+%line 867 "liesuper.web"
+if independent_part(value,algebra_elements)neq 0 then
+rederr("SET_LIEBRACKET: assigned value invalid as algebra element")
+
+%:35%
+%line 965 "liesuper.web"
+;
+if sign then value:=mk!*sq negsq simp value;
+%41:%
+%line 1033 "liesuper.web"
+
+if fixp arg1 and fixp arg2 then
+begin
+if
+ 'used!* memq cddr fkern list(bracketname,arg1,arg2)then rmsubs();
+
+(if old_value then
+
+putv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2,nil . (cadr old_value) . value)
+else
+putv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2,nil . nil . value))
+where old_value=
+getv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2);
+end else
+setk1(list(bracketname,arg1,arg2),value,t)
+
+%:41%
+%line 967 "liesuper.web"
+;
+end$
+
+%:38%%42:%
+%line 1075 "liesuper.web"
+
+%line 1076 "liesuper.web"
+lisp procedure clear1 u;
+begin scalar x,xx;
+while u do
+ <<if flagp(x:=car u, 'share)
+then if not flagp(x, 'reserved)then set(x,x)else rsverr x
+else if eqcar(x, 'list)
+then u:=nil . append(cdr x,cdr u)
+else if eqcar(x, 'replaceby)then rule!-list(list x,nil)
+else if smemq( '!~,x)
+then if eqcar(x, 'equal)then rule!-list(list x,nil)
+else rule!-list(list list( 'replaceby,x,nil),nil)
+else if(xx:=get(if atom x then x else car x, 'rtype))
+and(xx:=get(xx, 'clearfn))
+then apply1(xx,x)
+else <<let2(x,nil,nil,nil);let2(x,nil,t,nil)>> ;
+u:=cdr u>>
+end$
+
+%:42%%44:%
+%line 1105 "liesuper.web"
+
+%line 1106 "liesuper.web"
+lisp procedure clear_liebracket val;
+if atom val then%142:%
+%line 3306 "liesuper.web"
+
+%line 3307 "liesuper.web"
+ begin scalar bracketname,generatorname;
+bracketname:=val;
+generatorname:=get(bracketname, 'generatorname);
+for each property in
+ '(vector_structure info_list !*jacobi_var!* even_dimension odd_dimension
+even_used odd_used degree_length degree_sequence algebra_elements
+parameters oplist resimp_fn
+generatorname rtype simpfn commutator_list identity_list
+unsolved_identities kvalue)do
+remprop(bracketname,property);
+for each property in
+ '(bracketname rtype simpfn kvalue)do
+remprop(generatorname,property);
+remflag(list bracketname, 'full);
+end
+
+%:142%
+%line 1107 "liesuper.web"
+
+else if length val=3 then%45:%
+%line 1117 "liesuper.web"
+
+%line 1118 "liesuper.web"
+ begin scalar bracketname,generatorname,algebra_elements,arg1,arg2,error,h;
+bracketname:=car val;
+generatorname:=get(bracketname, 'generatorname);
+algebra_elements:=bracketname . generatorname . get(bracketname, 'algebra_elements);
+arg1:=reval cadr val;
+arg2:=reval caddr val;
+%36:%
+%line 910 "liesuper.web"
+
+
+if atom arg1 then error:=
+((not fixp arg1)or arg1<-get(bracketname, 'odd_dimension)
+or arg1>get(bracketname, 'even_dimension))
+else begin
+error:=not member(car arg1,algebra_elements);
+if not error and car arg1=generatorname then
+begin
+arg1:=cadr arg1;
+error:=not atom arg1 or
+((not fixp arg1)or arg1<-get(bracketname, 'odd_dimension)
+or arg1>get(bracketname, 'even_dimension));
+end;
+end;
+if not error then
+if atom arg2 then error:=
+((not fixp arg2)or arg2<-get(bracketname, 'odd_dimension)
+or arg2>get(bracketname, 'even_dimension))
+else begin
+error:=not member(car arg2,algebra_elements);
+if not error and car arg2=generatorname then
+begin
+arg2:=cadr arg2;
+error:=not atom arg2 or
+((not fixp arg2)or arg2<-get(bracketname, 'odd_dimension)
+or arg2>get(bracketname, 'even_dimension));
+end;
+end;
+if error then
+rederr("SET_/CLEAR_LIEBRACKET: argument(s) invalid or out of range")
+
+%:36%
+%line 1124 "liesuper.web"
+;
+if
+(if fixp arg1 and fixp arg2 then arg1>arg2 else
+ordp(arg1,arg2)and arg1 neq arg2)then
+begin
+h:=arg1;arg1:=arg2;arg2:=h;
+end;
+%37:%
+%line 934 "liesuper.web"
+
+error:=if fixp arg1 and fixp arg2 then
+(if entry then car entry)
+where entry=
+getv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2);
+if error then
+if car error= 's
+then
+rederr("SET_/CLEAR_LIEBRACKET: commutator can not be changed")
+else
+msgpri("SET_/CLEAR_LIEBRACKET: changing",
+list(bracketname,arg1,arg2),"may lead to errors",nil,nil)
+
+%:37%
+%line 1129 "liesuper.web"
+;
+%46:%
+%line 1140 "liesuper.web"
+
+%line 1141 "liesuper.web"
+val:=list(bracketname,arg1,arg2);
+if fixp arg1 and fixp arg2 then
+if
+(if entry then cddr entry)
+where entry=
+getv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2)then
+
+(if old_value then
+
+putv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2,nil . (cadr old_value) . nil)
+else
+putv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2,nil . nil . nil))
+where old_value=
+getv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+arg1),
+get(bracketname, 'even_dimension)-arg2)
+else
+msgpri("CLEAR_LIEBRACKET:",val,"not found",nil,nil)
+else begin scalar kvalue;
+kvalue:=get(bracketname, 'kvalue);
+if(h:=assoc(val,kvalue))then
+put(bracketname, 'kvalue,delete(h,kvalue))
+else
+msgpri("CLEAR_LIEBRACKET:",val,"not found",nil,nil);
+end
+
+%:46%
+%line 1130 "liesuper.web"
+;
+end
+
+%:45%
+%line 1108 "liesuper.web"
+
+else rederr("CLEAR_LIEBRACKET: wrong number of arguments to commutator")$
+
+
+%:44%%48:%
+%line 1303 "liesuper.web"
+
+lisp operator recompute_jacobi_identities_of;
+
+lisp procedure recompute_jacobi_identities_of bracketname;
+begin scalar !*jacobi_var!*;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("RECOMPUTE_JACOBI_IDENTITIES:",bracketname,"is not a liebracket",nil,t);
+!*jacobi_var!*:=get(bracketname, '!*jacobi_var!*);
+rplaca(!*jacobi_var!*,nil);
+put(bracketname, '!*jacobi_var!*,list t);
+end$
+
+%:48%%51:%
+%line 1395 "liesuper.web"
+
+%line 1396 "liesuper.web"
+lisp procedure find_unprocessed_commutators_of bracketname;
+begin scalar vector_i,entry_i_j,k_info_i_j,commutator,form,kord!*,
+
+
+vector_structure,m,m_used,n,n_used
+,generatorname,non_generators,
+commutator_list,!*jacobi_var!*
+,comm_list_i,
+dependent_generators;
+%50:%
+%line 1370 "liesuper.web"
+
+%49:%
+%line 1355 "liesuper.web"
+
+vector_structure:=get(bracketname, 'vector_structure);
+m:=get(bracketname, 'even_dimension);n:=get(bracketname, 'odd_dimension);
+m_used:=get(bracketname, 'even_used);n_used:=get(bracketname, 'odd_used)
+
+%:49%
+%line 1371 "liesuper.web"
+;
+generatorname:=get(bracketname, 'generatorname);
+non_generators:=bracketname . get(bracketname, 'algebra_elements);
+commutator_list:=get(bracketname, 'commutator_list);
+!*jacobi_var!*:=get(bracketname, '!*jacobi_var!*)
+
+%:50%
+%line 1400 "liesuper.web"
+;
+%52:%
+%line 1417 "liesuper.web"
+
+%line 1418 "liesuper.web"
+dependent_generators:=
+for each entry in get(generatorname, 'kvalue)collect
+cadr car entry
+
+%:52%
+%line 1401 "liesuper.web"
+;
+for i:=-n_used:m_used do
+if not memq(i,dependent_generators)then
+begin
+vector_i:=getv(vector_structure,n+i);
+for j:=i:m_used do
+if not memq(j,dependent_generators)then
+%56:%
+%line 1492 "liesuper.web"
+
+begin
+entry_i_j:=getv(vector_i,m-j);
+if entry_i_j and cddr entry_i_j then
+if null car entry_i_j then
+begin
+commutator:=simp!* cddr entry_i_j;
+k_info_i_j:=cadr entry_i_j;
+form:=numr commutator;
+if
+null get_all_kernels(form,non_generators)then begin
+
+setkorder get_all_kernels(form,generatorname);
+commutator:=!*ff2a(reorder form,denr commutator);
+
+if(comm_list_i:=assoc(i,commutator_list))then
+(if not member(j,comm_list_i)then
+rplacd(comm_list_i,j . cdr comm_list_i))
+else
+ <<commutator_list:=list(i,j) . commutator_list;
+put(bracketname, 'commutator_list,commutator_list)>> ;
+
+putv(vector_i,m-j,!*jacobi_var!* . k_info_i_j . commutator);
+end;
+end
+else if null caar
+entry_i_j then begin
+commutator:=cddr entry_i_j;
+k_info_i_j:=cadr entry_i_j;
+
+if(comm_list_i:=assoc(i,commutator_list))then
+(if not member(j,comm_list_i)then
+rplacd(comm_list_i,j . cdr comm_list_i))
+else
+ <<commutator_list:=list(i,j) . commutator_list;
+put(bracketname, 'commutator_list,commutator_list)>> ;
+
+putv(vector_i,m-j,!*jacobi_var!* . k_info_i_j . commutator);
+end;
+end
+
+%:56%
+%line 1408 "liesuper.web"
+;
+end;
+return commutator_list;
+end$
+
+%:51%%60:%
+%line 1611 "liesuper.web"
+
+lisp procedure find_Jacobi_identities_of bracketname;
+begin scalar comm_list_i,i,j,vector_i,vector_j,vector_k,
+entry_i_k,entry_j_k,
+
+
+vector_structure,m,m_used,n,n_used
+,commutator_list,identity_list
+,
+id_list_i,id_list_i_j;
+%58:%
+%line 1575 "liesuper.web"
+
+%49:%
+%line 1355 "liesuper.web"
+
+vector_structure:=get(bracketname, 'vector_structure);
+m:=get(bracketname, 'even_dimension);n:=get(bracketname, 'odd_dimension);
+m_used:=get(bracketname, 'even_used);n_used:=get(bracketname, 'odd_used)
+
+%:49%
+%line 1576 "liesuper.web"
+;
+commutator_list:=get(bracketname, 'commutator_list);
+identity_list:=get(bracketname, 'identity_list)
+
+%:58%
+%line 1617 "liesuper.web"
+;
+while commutator_list do begin
+comm_list_i:=car commutator_list;
+i:=car comm_list_i;
+while cdr comm_list_i do begin
+j:=cadr comm_list_i;
+%61:%
+%line 1641 "liesuper.web"
+
+%line 1642 "liesuper.web"
+vector_i:=getv(vector_structure,n+i);
+vector_j:=getv(vector_structure,n+j);
+for k:=-n_used:i-1 do begin
+vector_k:=getv(vector_structure,n+k);
+if(entry_i_k:=getv(vector_k,m-i))and(entry_j_k:=getv(vector_k,m-j))then
+
+if
+(car entry_i_k and caar entry_i_k neq 's
+)and
+
+(car entry_j_k and caar entry_j_k neq 's
+)
+then
+if(id_list_i:=assoc(k,identity_list))then
+if(id_list_i_j:=assoc(i,cdr id_list_i))then
+(if not member(j,cdr id_list_i_j)then
+rplacd(id_list_i_j,j . cdr id_list_i_j))
+else rplacd(id_list_i,list(i,j) . cdr id_list_i)
+else identity_list:=list(k,list(i,j)) . identity_list
+;
+end;
+for k:=i:j-1 do begin
+vector_k:=getv(vector_structure,n+k);
+if(entry_i_k:=getv(vector_i,m-k))and(entry_j_k:=getv(vector_k,m-j))then
+
+if
+(car entry_i_k and caar entry_i_k neq 's
+)and
+
+(car entry_j_k and caar entry_j_k neq 's
+)
+then
+if(id_list_i:=assoc(i,identity_list))then
+if(id_list_i_j:=assoc(k,cdr id_list_i))then
+(if not member(j,cdr id_list_i_j)then
+rplacd(id_list_i_j,j . cdr id_list_i_j))
+else rplacd(id_list_i,list(k,j) . cdr id_list_i)
+else identity_list:=list(i,list(k,j)) . identity_list
+;
+end;
+for k:=j:m_used do begin
+if(entry_i_k:=getv(vector_i,m-k))and(entry_j_k:=getv(vector_j,m-k))then
+
+if
+(car entry_i_k and caar entry_i_k neq 's
+)and
+
+(car entry_j_k and caar entry_j_k neq 's
+)
+then
+if(id_list_i:=assoc(i,identity_list))then
+if(id_list_i_j:=assoc(j,cdr id_list_i))then
+(if not member(k,cdr id_list_i_j)then
+rplacd(id_list_i_j,k . cdr id_list_i_j))
+else rplacd(id_list_i,list(j,k) . cdr id_list_i)
+else identity_list:=list(i,list(j,k)) . identity_list
+;
+end;
+put(bracketname, 'identity_list,identity_list)
+
+%:61%
+%line 1623 "liesuper.web"
+;
+rplacd(comm_list_i,cddr comm_list_i);
+end;
+commutator_list:=cdr commutator_list;
+put(bracketname, 'commutator_list,commutator_list);
+end;
+return identity_list;
+end$
+
+%:60%%63:%
+%line 1725 "liesuper.web"
+
+lisp procedure sub_identity(bracketname,i,j,k);
+begin scalar comm_j_k,denr_j_k,coeff_l,l,comm_i_l,term;
+comm_j_k:=
+(if entry then cddr entry)
+where entry=
+getv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+j),
+get(bracketname, 'even_dimension)-k);
+return if comm_j_k=0 then nil . 1 else
+begin
+comm_j_k:=cadr comm_j_k;
+denr_j_k:=subf1(denr comm_j_k,nil);
+comm_j_k:=numr comm_j_k;
+%64:%
+%line 1747 "liesuper.web"
+
+term:=nil . 1;
+while comm_j_k do begin
+l:=cadr mvar comm_j_k;
+coeff_l:=subf1(lc comm_j_k,nil);
+if not fixp l then
+
+msgpri("SOLVE_JACOBI_IDENTITIES:",list(bracketname,j,k),
+"contains invalid generator",mvar comm_j_k,t);
+comm_i_l:=simp_liebracket_vector(bracketname,i,l);
+term:=addsq(term,multsq(coeff_l,comm_i_l));
+comm_j_k:=red comm_j_k;
+end
+
+%:64%
+%line 1734 "liesuper.web"
+;
+if i<0 and k<0 then term:=negsq term;
+
+return quotsq(term,denr_j_k);
+end;
+end$
+
+%:63%%65:%
+%line 1768 "liesuper.web"
+
+%line 1769 "liesuper.web"
+lisp procedure special_Jacobi_identity(bracketname,i,j,k);
+mk!*sq subs2 negsq
+addsq(sub_identity(bracketname,i,j,k),
+addsq(multsq((if j>0 then-1 else 1) . 1,
+sub_identity(bracketname,j,i,k)),
+sub_identity(bracketname,k,i,j)))$
+
+%:65%%66:%
+%line 1785 "liesuper.web"
+
+%line 1786 "liesuper.web"
+lisp operator update_vector_structure_of;
+lisp procedure update_vector_structure_of bracketname;
+begin scalar vector_i,entry_i_j,
+commutator,form,kord!*,generatorname,
+vector_structure,m,m_used,n,n_used
+;
+%49:%
+%line 1355 "liesuper.web"
+
+vector_structure:=get(bracketname, 'vector_structure);
+m:=get(bracketname, 'even_dimension);n:=get(bracketname, 'odd_dimension);
+m_used:=get(bracketname, 'even_used);n_used:=get(bracketname, 'odd_used)
+
+%:49%
+%line 1790 "liesuper.web"
+;
+generatorname:=get(bracketname, 'generatorname);
+for i:=-n_used:m_used do begin
+vector_i:=getv(vector_structure,n+i);
+for j:=i:m_used do begin
+entry_i_j:=getv(vector_i,m-j);
+%67:%
+%line 1805 "liesuper.web"
+
+%line 1806 "liesuper.web"
+if entry_i_j and cddr entry_i_j then
+if null car entry_i_j then
+putv(vector_i,m-j,nil . cadr(entry_i_j) .
+aeval cddr entry_i_j)
+else if
+(car entry_i_j and caar entry_i_j neq 's
+)then begin
+commutator:=simp!* cddr entry_i_j;
+form:=numr commutator;
+
+setkorder get_all_kernels(form,generatorname);
+commutator:=!*ff2a(reorder form,denr commutator);
+putv(vector_i,m-j,car(entry_i_j) .
+cadr(entry_i_j) . commutator);
+end
+
+%:67%
+%line 1796 "liesuper.web"
+;
+end;
+end;
+end$
+
+%:66%%70:%
+%line 1912 "liesuper.web"
+lisp operator relation_analysis;
+lisp procedure relation_analysis(relation,bracketname);
+begin scalar generatorname,parameters,kernel_list,solvable_kernels,
+test,kernel,optimal_kernel,coefficient,clear_list;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("RELATION_ANALYSIS:",bracketname,"is not a liebracket",nil,t);
+generatorname:=get(bracketname, 'generatorname);
+parameters:=get(bracketname, 'parameters);
+kernel_list:=operator_coeff(relation,generatorname);
+return
+if kernel_list= '(list 0)then 0
+else if cadr kernel_list neq 0 then
+%71:%
+%line 1933 "liesuper.web"
+
+begin
+solvable_kernels:=cdr solvable_kernels(cadr
+kernel_list,bracketname,parameters);
+return
+if null solvable_kernels then 'unsolvable
+else begin
+%76:%
+%line 2011 "liesuper.web"
+
+%line 2012 "liesuper.web"
+optimal_kernel:=0 . nil;
+while solvable_kernels and car optimal_kernel do begin
+kernel:=car solvable_kernels;
+if not fixp cadr kernel or
+not fixp caddr kernel then optimal_kernel:=nil . nil
+else
+if not((test:=highest_degree(extended_commutator_degree(kernel,bracketname),
+car optimal_kernel))eq car optimal_kernel)then
+optimal_kernel:=test . kernel;
+solvable_kernels:=cdr solvable_kernels;
+end;
+optimal_kernel:=cdr optimal_kernel
+
+%:76%
+%line 1940 "liesuper.web"
+;
+return
+if optimal_kernel then
+ <<linear_solve_and_assign(relation,optimal_kernel);optimal_kernel>>
+else 'nested_commutator;
+end;
+end
+
+%:71%
+%line 1923 "liesuper.web"
+
+else%77:%
+%line 2032 "liesuper.web"
+
+%line 2033 "liesuper.web"
+ begin
+solvable_kernels:=cdr
+solvable_kernels(relation,generatorname,parameters);
+return
+if null solvable_kernels then
+%81:%
+%line 2106 "liesuper.web"
+
+%line 2107 "liesuper.web"
+if !*solve_parameters then
+begin
+kernel_list:=cddr kernel_list;
+%79:%
+%line 2077 "liesuper.web"
+
+%line 2078 "liesuper.web"
+repeat begin
+coefficient:=caddr car kernel_list;
+solvable_kernels:=cdr
+solvable_kernels(coefficient,parameters,parameters);
+if null solvable_kernels then
+begin
+apply1( 'clear,clear_list);
+clear_list:=nil
+end
+else begin
+kernel:=car solvable_kernels;
+linear_solve_and_assign(coefficient,kernel);
+clear_list:=kernel . clear_list;
+kernel_list:=cdr kernel_list;
+end end
+until null kernel_list or null clear_list
+
+%:79%
+%line 2110 "liesuper.web"
+;
+return if clear_list then 'list . clear_list else 'unsolvable;
+end
+else 'unsolvable
+
+%:81%
+%line 2038 "liesuper.web"
+
+else
+begin
+%78:%
+%line 2050 "liesuper.web"
+
+%line 2051 "liesuper.web"
+optimal_kernel:=0 . nil;
+while solvable_kernels and car optimal_kernel do begin
+kernel:=car solvable_kernels;
+if not fixp cadr kernel then
+optimal_kernel:=nil . nil
+else
+if not((test:=highest_degree(extended_generator_degree(kernel,bracketname),
+car optimal_kernel))eq car optimal_kernel)then
+optimal_kernel:=test . kernel;
+solvable_kernels:=cdr solvable_kernels;
+end;
+optimal_kernel:=cdr optimal_kernel
+
+%:78%
+%line 2041 "liesuper.web"
+;
+return
+if optimal_kernel then
+ <<linear_solve_and_assign(relation,optimal_kernel);optimal_kernel>>
+else 'invalid_generator;
+end;
+end
+
+%:77%
+%line 1924 "liesuper.web"
+;
+end$
+
+%:70%%72:%
+%line 1964 "liesuper.web"
+
+%line 1965 "liesuper.web"
+lisp procedure first_degree_higher(degree_1,degree_2);
+if null degree_1 then nil
+else if car degree_1>car degree_2 then t
+else first_degree_higher(cdr degree_1,cdr degree_2)$
+
+%:72%%73:%
+%line 1975 "liesuper.web"
+
+%line 1976 "liesuper.web"
+lisp procedure extended_commutator_degree(commutator,bracketname);
+nconc(add_degrees(
+permuted_degree(car
+getv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+i),
+get(bracketname, 'degree_sequence)),
+
+permuted_degree(car
+getv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+j),
+get(bracketname, 'degree_sequence))),
+list(i,j))
+where i=cadr commutator,j=caddr commutator$
+
+
+%:73%%74:%
+%line 1988 "liesuper.web"
+
+%line 1989 "liesuper.web"
+lisp procedure extended_generator_degree(generator,bracketname);
+append(
+permuted_degree(car
+getv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+i),
+get(bracketname, 'degree_sequence)),list abs(i))
+where i=cadr generator$
+
+%:74%%75:%
+%line 1998 "liesuper.web"
+
+%line 1999 "liesuper.web"
+lisp procedure highest_degree(degree_1,degree_2);
+if atom degree_2 then degree_1
+else if first_degree_higher(degree_1,degree_2)then degree_1
+else degree_2$
+
+%:75%%83:%
+%line 2149 "liesuper.web"
+
+%line 2150 "liesuper.web"
+lisp operator solve_Jacobi_identities_of;
+lisp procedure solve_Jacobi_identities_of bracketname;
+begin scalar generatorname,stage,identity_list,i,j,identity,
+solution,nr_computed,nr_solved,environment,origin;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("SOLVE_JACOBI_IDENTITIES_OF:",bracketname,"is not a liebracket",nil,t);
+generatorname:=get(bracketname, 'generatorname);
+environment:=!*nat;!*nat:=t;stage:=0;
+%84:%
+%line 2168 "liesuper.web"
+
+%line 2169 "liesuper.web"
+%88:%
+%line 2241 "liesuper.web"
+
+%line 2242 "liesuper.web"
+prin2!*"Starting stage ";prin2!*(stage:=stage+1);prin2!*":";terpri!* nil;
+prin2!*"Reordering the commutators...";terpri!* nil
+
+%:88%
+%line 2169 "liesuper.web"
+;
+find_unprocessed_commutators_of bracketname;
+%89:%
+%line 2245 "liesuper.web"
+
+%line 2246 "liesuper.web"
+prin2!*"Searching for identities...";terpri!* nil
+
+%:89%
+%line 2171 "liesuper.web"
+;
+identity_list:=find_Jacobi_identities_of bracketname
+
+%:84%
+%line 2157 "liesuper.web"
+;
+while identity_list do
+%85:%
+%line 2174 "liesuper.web"
+
+%line 2175 "liesuper.web"
+begin
+nr_computed:=0;nr_solved:=0;
+%90:%
+%line 2248 "liesuper.web"
+
+%line 2249 "liesuper.web"
+prin2!*"Solving the identities...";terpri!* nil;
+if !*print_identities then
+ <<prin2!*"==========================";
+terpri!* nil>>
+
+%:90%
+%line 2177 "liesuper.web"
+;
+%86:%
+%line 2189 "liesuper.web"
+
+%line 2190 "liesuper.web"
+for each id_list_i in identity_list do begin
+i:=car id_list_i;id_list_i:=cdr id_list_i;
+for each id_list_i_j in id_list_i do begin
+j:=car id_list_i_j;id_list_i_j:=cdr id_list_i_j;
+for each k in id_list_i_j do begin
+(nr_computed:=nr_computed+1);
+identity:=special_Jacobi_identity(bracketname,i,j,k);
+origin:=list( 'list,i,j,k);
+%91:%
+%line 2254 "liesuper.web"
+
+%line 2255 "liesuper.web"
+if !*print_identities and identity neq 0 then
+begin
+for i:=1:indentation_level!* do prin2!*"| ";maprin origin;terpri!* nil;
+
+for i:=1:indentation_level!* do prin2!*"| ";maprin identity;terpri!* nil;
+end
+
+%:91%
+%line 2198 "liesuper.web"
+;
+solution:=relation_analysis(identity,bracketname);
+%94:%
+%line 2293 "liesuper.web"
+
+if solution neq 0 then
+if member(solution, '(unsolvable nested_commutator invalid_generator))then
+
+put(bracketname, 'unsolved_identities,
+list( 'list,origin,identity) . get(bracketname, 'unsolved_identities))
+else if car solution=generatorname or car solution= 'list then
+begin(nr_solved:=nr_solved+1);
+if not !*print_identities then
+ <<
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"*** Identity ">> ;maprin origin;
+prin2!*" solved for: ";maprin solution;terpri!* nil>>
+end
+else(nr_solved:=nr_solved+1)
+
+%:94%
+%line 2200 "liesuper.web"
+;
+%92:%
+%line 2260 "liesuper.web"
+
+%line 2261 "liesuper.web"
+if !*print_identities and solution neq 0 then
+begin
+if member(solution, '(unsolvable nested_commutator invalid_generator))
+then
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"Not solved.">>
+else <<if car solution=generatorname or car solution= 'list then
+
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"*** Solved for: ">>
+else
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"Solved for: ">> ;
+maprin solution>> ;
+
+if indentation_level!*=0 then terpri!* t else
+ <<terpri!* nil;
+for i:=1:indentation_level!* do prin2!*"| ";terpri!* nil>> ;
+end
+
+%:92%
+%line 2201 "liesuper.web"
+;
+end;
+end;
+end
+
+%:86%
+%line 2178 "liesuper.web"
+;
+put(bracketname, 'identity_list,nil);
+%93:%
+%line 2272 "liesuper.web"
+
+%line 2273 "liesuper.web"
+
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!* nr_solved>> ;prin2!*" identities solved of ";
+prin2!* nr_computed;
+if indentation_level!*=0 then terpri!* t else
+ <<terpri!* nil;
+for i:=1:indentation_level!* do prin2!*"| ";terpri!* nil>>
+
+%:93%
+%line 2180 "liesuper.web"
+;
+%84:%
+%line 2168 "liesuper.web"
+
+%line 2169 "liesuper.web"
+%88:%
+%line 2241 "liesuper.web"
+
+%line 2242 "liesuper.web"
+prin2!*"Starting stage ";prin2!*(stage:=stage+1);prin2!*":";terpri!* nil;
+prin2!*"Reordering the commutators...";terpri!* nil
+
+%:88%
+%line 2169 "liesuper.web"
+;
+find_unprocessed_commutators_of bracketname;
+%89:%
+%line 2245 "liesuper.web"
+
+%line 2246 "liesuper.web"
+prin2!*"Searching for identities...";terpri!* nil
+
+%:89%
+%line 2171 "liesuper.web"
+;
+identity_list:=find_Jacobi_identities_of bracketname
+
+%:84%
+%line 2181 "liesuper.web"
+;
+end
+
+%:85%
+%line 2159 "liesuper.web"
+;
+print_statistics_of bracketname;
+!*nat:=environment;
+end$
+
+%:83%%95:%
+%line 2316 "liesuper.web"
+
+%line 2317 "liesuper.web"
+lisp operator unsolved_identities_of;
+lisp procedure unsolved_identities_of bracketname;
+begin scalar unsolved_identities,id;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("UNSOLVED_IDENTITIES_OF:",bracketname,"is not a liebracket",nil,t);
+unsolved_identities:=get(bracketname, 'unsolved_identities);
+unsolved_identities:=
+for each identity in unsolved_identities join
+if(id:=aeval caddr identity)neq 0 then
+list list( 'list,cadr identity,id);
+put(bracketname, 'unsolved_identities,unsolved_identities);
+return 'list . unsolved_identities;
+end$
+
+%:95%%96:%
+%line 2341 "liesuper.web"
+
+lisp operator print_statistics_of;
+lisp procedure print_statistics_of bracketname;
+begin scalar
+vector_structure,m,m_used,n,n_used
+,vector_i,entry_i_j,nr_solved,total;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("PRINTS_STATISTICS_OF:",bracketname,"is not a liebracket",nil,t);
+%49:%
+%line 1355 "liesuper.web"
+
+vector_structure:=get(bracketname, 'vector_structure);
+m:=get(bracketname, 'even_dimension);n:=get(bracketname, 'odd_dimension);
+m_used:=get(bracketname, 'even_used);n_used:=get(bracketname, 'odd_used)
+
+%:49%
+%line 2346 "liesuper.web"
+;
+nr_solved:=0;
+for i:=-n_used:m_used do begin
+vector_i:=getv(vector_structure,n+i);
+for j:=i:m_used do
+if(entry_i_j:=getv(vector_i,m-j))and
+cddr(entry_i_j)and car entry_i_j neq '(s
+)
+then(nr_solved:=nr_solved+1);
+end;
+total:=((m_used+n_used)^2-m_used+n_used)/2;
+if total=0 then rederr("PRINT_STATISTICS_OF: first define used area");
+terpri!* t;
+prin2!*"Statistics for liebracket ";maprin bracketname;terpri!* nil;
+prin2!* m_used;prin2!*" even and ";prin2!* n_used;
+prin2!*" odd generators used";terpri!* nil;
+prin2!* nr_solved;prin2!*" commutators solved of ";prin2!* total;
+prin2!*" (";prin2!*((nr_solved*100)/total);prin2!*" %)";terpri!* nil;
+prin2!* length get(get(bracketname, 'generatorname), 'kvalue);
+prin2!*" linear dependencies found";terpri!* nil;
+total:=for each parameter in get(bracketname, 'parameters)sum
+length get(parameter, 'kvalue);
+prin2!* total;prin2!*" parameters solved";terpri!* nil;
+prin2!* length get(bracketname, 'unsolved_identities);
+prin2!*" unsolved identities";terpri!* t;
+end$
+
+
+%:96%%98:%
+%line 2398 "liesuper.web"
+
+%line 2399 "liesuper.web"
+lisp procedure generator_rtypefn u;
+nil$
+
+%:98%%99:%
+%line 2415 "liesuper.web"
+lisp procedure set_generator(val,value);if length val neq 2 then
+%line 2416 "liesuper.web"
+ rederr("SET_GENERATOR: generator must have one integer argument")
+else begin scalar generatorname,bracketname,i,valuelist,
+identity,solution,
+nr_computed,nr_solved,environment,origin;
+generatorname:=car val;
+bracketname:=get(generatorname, 'bracketname);
+i:=reval cadr val;
+value:=aeval value;
+%100:%
+%line 2438 "liesuper.web"
+
+%line 2439 "liesuper.web"
+if not atom i or
+((not fixp i)or i<-get(bracketname, 'odd_dimension)
+or i>get(bracketname, 'even_dimension))then
+
+msgpri("SET_GENERATOR:",val,"invalid or out of range",nil,t);
+valuelist:=operator_coeff(value,generatorname);
+if cadr valuelist neq 0 then
+
+msgpri("SET_GENERATOR:",cadr valuelist,
+"not a sum of generators",nil,t);
+for each term in cddr valuelist do
+if length(term:=cadr term)neq 2 or
+not atom cadr term or
+
+((not fixp cadr term)or cadr term<-get(bracketname, 'odd_dimension)
+or cadr term>get(bracketname, 'even_dimension))then
+
+msgpri("SET_GENERATOR:",term,"invalid or out of range",nil,t)
+
+%:100%
+%line 2424 "liesuper.web"
+;
+if
+ 'used!* memq cddr fkern val then rmsubs();
+setk1(val,value,t);
+%101:%
+%line 2475 "liesuper.web"
+
+%line 2476 "liesuper.web"
+environment:=!*nat;!*nat:=t;
+%102:%
+%line 2495 "liesuper.web"
+
+%line 2496 "liesuper.web"
+
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"Adjusting the commutators of ">> ;maprin val;prin2!*"...";
+terpri!* nil;
+if !*print_identities then
+ <<
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"| ========================">> ;
+terpri!* nil;>>
+
+%:102%
+%line 2477 "liesuper.web"
+;
+(indentation_level!*:=indentation_level!*+1);
+nr_computed:=0;nr_solved:=0;
+for j:=-get(bracketname, 'odd_dimension):get(bracketname, 'even_dimension)do
+if j neq 0 and(i neq j or i<0)then
+begin
+(nr_computed:=nr_computed+1);
+identity:=%103:%
+%line 2510 "liesuper.web"
+
+%line 2511 "liesuper.web"
+mk!*sq subs2 subtrsq(simp_liebracket(list(bracketname,i,j)),
+simp_liebracket(list(bracketname,value,j)))
+
+%:103%
+%line 2484 "liesuper.web"
+;
+origin:=list( 'list,i,j);
+%91:%
+%line 2254 "liesuper.web"
+
+%line 2255 "liesuper.web"
+if !*print_identities and identity neq 0 then
+begin
+for i:=1:indentation_level!* do prin2!*"| ";maprin origin;terpri!* nil;
+
+for i:=1:indentation_level!* do prin2!*"| ";maprin identity;terpri!* nil;
+end
+
+%:91%
+%line 2486 "liesuper.web"
+;
+solution:=relation_analysis(identity,bracketname);
+%94:%
+%line 2293 "liesuper.web"
+
+if solution neq 0 then
+if member(solution, '(unsolvable nested_commutator invalid_generator))then
+
+put(bracketname, 'unsolved_identities,
+list( 'list,origin,identity) . get(bracketname, 'unsolved_identities))
+else if car solution=generatorname or car solution= 'list then
+begin(nr_solved:=nr_solved+1);
+if not !*print_identities then
+ <<
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"*** Identity ">> ;maprin origin;
+prin2!*" solved for: ";maprin solution;terpri!* nil>>
+end
+else(nr_solved:=nr_solved+1)
+
+%:94%
+%line 2488 "liesuper.web"
+;
+%92:%
+%line 2260 "liesuper.web"
+
+%line 2261 "liesuper.web"
+if !*print_identities and solution neq 0 then
+begin
+if member(solution, '(unsolvable nested_commutator invalid_generator))
+then
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"Not solved.">>
+else <<if car solution=generatorname or car solution= 'list then
+
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"*** Solved for: ">>
+else
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!*"Solved for: ">> ;
+maprin solution>> ;
+
+if indentation_level!*=0 then terpri!* t else
+ <<terpri!* nil;
+for i:=1:indentation_level!* do prin2!*"| ";terpri!* nil>> ;
+end
+
+%:92%
+%line 2489 "liesuper.web"
+;
+end;
+%93:%
+%line 2272 "liesuper.web"
+
+%line 2273 "liesuper.web"
+
+ <<
+for i:=1:indentation_level!* do prin2!*"| ";prin2!* nr_solved>> ;prin2!*" identities solved of ";
+prin2!* nr_computed;
+if indentation_level!*=0 then terpri!* t else
+ <<terpri!* nil;
+for i:=1:indentation_level!* do prin2!*"| ";terpri!* nil>>
+
+%:93%
+%line 2491 "liesuper.web"
+;
+(indentation_level!*:=indentation_level!*-1);
+!*nat:=environment
+
+%:101%
+%line 2427 "liesuper.web"
+;
+end$
+
+%:99%%104:%
+%line 2526 "liesuper.web"
+
+%line 2527 "liesuper.web"
+lisp procedure clear_generator val;
+if atom val then rederr("CLEAR_GENERATOR: clear associated liebracket instead")
+else if length val neq 2 then
+rederr("CLEAR_GENERATOR: generator must have one integer argument")
+else begin scalar generatorname,kvalue,h;
+generatorname:=car val;
+val:=list(generatorname,reval cadr val);
+kvalue:=get(generatorname, 'kvalue);
+if(h:=assoc(val,kvalue))then
+begin
+put(generatorname, 'kvalue,delete(h,kvalue));
+
+msgpri("CLEAR_GENERATOR: clearing",val,"may lead to errors",nil,nil);
+end
+else
+msgpri("CLEAR_GENERATOR:",val,"not found",nil,nil);
+end$
+
+%:104%%106:%
+%line 2592 "liesuper.web"
+lisp procedure add_degrees(degree1,degree2);
+if degree1 then(car degree1+car degree2) . add_degrees(cdr
+degree1,cdr degree2)$
+
+%:106%%107:%
+%line 2611 "liesuper.web"
+lisp operator degree_component_sequence;
+%line 2612 "liesuper.web"
+lisp procedure degree_component_sequence(bracketname,degree_sequence);
+begin scalar degree_length;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("DEGREE_COMPONENT_SEQUENCE:",bracketname,"is not a liebracket",nil,t);
+degree_sequence:=if null degree_sequence then degree_sequence else if atom
+degree_sequence then list degree_sequence else if
+car degree_sequence= 'list then cdr degree_sequence else degree_sequence;
+degree_length:=get(bracketname, 'degree_length);
+degree_sequence:=
+for each component in degree_sequence collect
+if fixp component and component>0 and component leq degree_length then
+component
+else
+
+msgpri("DEGREE_COMPONENT_SEQUENCE: multigrading has no component",
+component,nil,nil,t);
+put(bracketname, 'degree_sequence,degree_sequence);
+end$
+
+%:107%%108:%
+%line 2635 "liesuper.web"
+lisp procedure permuted_degree(degree,sequence);
+if null sequence then degree else permute_degree(degree,sequence)$
+
+lisp procedure permute_degree(degree,sequence);
+if sequence then
+nth(degree,car sequence) . permute_degree(degree,cdr sequence)$
+
+%:108%%109:%
+%line 2661 "liesuper.web"
+lisp procedure degree_of1(bracketname,element);
+if atom element then
+if
+((not fixp element)or element<-get(bracketname, 'odd_dimension)
+or element>get(bracketname, 'even_dimension))then
+
+msgpri("DEGREE_OF: cannot determine degree of",element,nil,nil,t)
+else
+permuted_degree(car
+getv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+element),
+get(bracketname, 'degree_sequence))
+else
+if car element=bracketname or car element= 'list then
+add_degrees(degree_of1(bracketname,cadr element),
+degree_of1(bracketname,caddr element))
+else if car element=get(bracketname, 'generatorname)then
+degree_of1(bracketname,cadr element)
+else
+msgpri("DEGREE_OF: cannot determine degree of",element,nil,nil,t)$
+
+%:109%%110:%
+%line 2686 "liesuper.web"
+lisp operator degree_of;
+%line 2687 "liesuper.web"
+lisp procedure degree_of element;
+begin scalar operatorname,bracketname,check_element;
+if(element:=reval element)=0 then return nil;
+if not atom element then
+begin
+operatorname:=car element;
+if get(operatorname, 'rtype)= 'liebracket then bracketname:=operatorname
+else if get(operatorname, 'rtype)= 'algebra_generator then
+bracketname:=get(operatorname, 'bracketname)
+end;
+if null bracketname then%111:%
+%line 2708 "liesuper.web"
+
+%line 2709 "liesuper.web"
+ begin
+check_element:=element;
+while not atom check_element and
+member(car check_element, '(quotient plus minus difference))do
+check_element:=cadr check_element;
+if not atom check_element then
+(if car check_element= 'times then
+%112:%
+%line 2727 "liesuper.web"
+
+%line 2728 "liesuper.web"
+while null bracketname and(check_element:=cdr check_element)do
+ <<if not atom car check_element then
+begin
+operatorname:=car car check_element;
+if get(operatorname, 'rtype)= 'liebracket then bracketname:=operatorname
+else if get(operatorname, 'rtype)= 'algebra_generator then
+bracketname:=get(operatorname, 'bracketname)
+end;
+if bracketname then element:=car check_element>>
+
+
+%:112%
+%line 2716 "liesuper.web"
+
+else
+begin
+operatorname:=car check_element;
+if get(operatorname, 'rtype)= 'liebracket then bracketname:=operatorname
+else if get(operatorname, 'rtype)= 'algebra_generator then
+bracketname:=get(operatorname, 'bracketname);
+if bracketname then element:=check_element
+end)
+end
+
+%:111%
+%line 2697 "liesuper.web"
+;
+if null bracketname then
+
+msgpri("DEGREE_OF: cannot determine degree of",element,nil,nil,t);
+return 'list . degree_of1(bracketname,element)
+end$
+
+%:110%%114:%
+%line 2769 "liesuper.web"
+
+%line 2770 "liesuper.web"
+lisp procedure integer_valued degree;
+if null degree then t
+else if fixp car degree then integer_valued cdr degree$
+
+%:114%%115:%
+%line 2778 "liesuper.web"
+lisp operator define_degree;
+%line 2779 "liesuper.web"
+lisp procedure define_degree(generator,degree);
+begin scalar generatorname,bracketname,info;
+%116:%
+%line 2795 "liesuper.web"
+
+%line 2796 "liesuper.web"
+if atom generator then
+
+msgpri("DEGREE:",generator,"invalid generator",nil,t);
+generatorname:=car generator;
+
+if get(generatorname, 'rtype)neq 'algebra_generator then
+
+msgpri("DEGREE:",generatorname,"is not an algebra generator",nil,t);
+bracketname:=get(generatorname, 'bracketname);
+generator:=reval cadr generator;
+if
+((not fixp generator)or generator<-get(bracketname, 'odd_dimension)
+or generator>get(bracketname, 'even_dimension))then
+
+msgpri("DEGREE: generator index",
+generator,"out of range",nil,t)
+
+%:116%
+%line 2781 "liesuper.web"
+;
+%113:%
+%line 2761 "liesuper.web"
+
+if not integer_valued(degree:=if null degree then degree else if atom
+degree then list degree else if
+car degree= 'list then cdr degree else degree)or
+length degree neq get(bracketname, 'degree_length)then
+
+msgpri("DEGREE:", 'list . degree,"invalid degree",nil,t)
+
+%:113%
+%line 2782 "liesuper.web"
+;
+info:=
+getv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+generator);
+
+putv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+generator,
+degree . cadr info . cddr info);
+end$
+
+%:115%%117:%
+%line 2815 "liesuper.web"
+
+%line 2816 "liesuper.web"
+lisp operator change_degree_length;
+lisp procedure change_degree_length(bracketname,degree_length);
+begin scalar m,n,old_length,shortage,extension,info,degree;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("CHANGE_DEGREE_LENGTH:",bracketname,"is not a liebracket",nil,t);
+if not fixp degree_length or degree_length<=0 then
+rederr("CHANGE_DEGREE_LENGTH: degree length should be >= 0");
+m:=get(bracketname, 'even_dimension);
+n:=get(bracketname, 'odd_dimension);
+old_length:=get(bracketname, 'degree_length);
+shortage:=degree_length-old_length;
+if shortage>0 then extension:=for i:=1:shortage collect 0;
+%118:%
+%line 2831 "liesuper.web"
+
+%line 2832 "liesuper.web"
+for i:=-n:m do
+begin info:=
+getv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+i);
+degree:=if extension then append(car info,extension)
+else sub_list(car info,degree_length);
+
+putv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+i,
+degree . cadr info . cddr info)
+end
+
+%:118%
+%line 2827 "liesuper.web"
+;
+put(bracketname, 'degree_length,degree_length);
+end$
+
+%:117%%119:%
+%line 2843 "liesuper.web"
+
+%line 2844 "liesuper.web"
+lisp procedure sub_list(l,n);
+if l and n>0 then car l . sub_list(cdr l,n-1)$
+
+%:119%%121:%
+%line 2885 "liesuper.web"
+lisp procedure definition_of1 listed_generator;
+%line 2886 "liesuper.web"
+definition_of car listed_generator$
+
+lisp procedure definition_of generator;
+begin scalar generatorname,bracketname;
+%116:%
+%line 2795 "liesuper.web"
+
+%line 2796 "liesuper.web"
+if atom generator then
+
+msgpri("DEGREE:",generator,"invalid generator",nil,t);
+generatorname:=car generator;
+
+if get(generatorname, 'rtype)neq 'algebra_generator then
+
+msgpri("DEGREE:",generatorname,"is not an algebra generator",nil,t);
+bracketname:=get(generatorname, 'bracketname);
+generator:=reval cadr generator;
+if
+((not fixp generator)or generator<-get(bracketname, 'odd_dimension)
+or generator>get(bracketname, 'even_dimension))then
+
+msgpri("DEGREE: generator index",
+generator,"out of range",nil,t)
+
+%:116%
+%line 2890 "liesuper.web"
+;
+return cadr
+getv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+generator);
+end$
+
+lisp procedure history_of1 listed_generator;
+history_of car listed_generator$
+
+lisp procedure history_of generator;
+begin scalar generatorname,bracketname;
+%116:%
+%line 2795 "liesuper.web"
+
+%line 2796 "liesuper.web"
+if atom generator then
+
+msgpri("DEGREE:",generator,"invalid generator",nil,t);
+generatorname:=car generator;
+
+if get(generatorname, 'rtype)neq 'algebra_generator then
+
+msgpri("DEGREE:",generatorname,"is not an algebra generator",nil,t);
+bracketname:=get(generatorname, 'bracketname);
+generator:=reval cadr generator;
+if
+((not fixp generator)or generator<-get(bracketname, 'odd_dimension)
+or generator>get(bracketname, 'even_dimension))then
+
+msgpri("DEGREE: generator index",
+generator,"out of range",nil,t)
+
+%:116%
+%line 2899 "liesuper.web"
+;
+return cddr
+getv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+generator);
+end$
+
+%:121%%122:%
+%line 2918 "liesuper.web"
+
+%line 2919 "liesuper.web"
+lisp procedure sub_degree(degree1,degree2);
+if null degree1 then t
+else if null degree2 then nil
+else if car degree1=car degree2 then
+sub_degree(cdr degree1,cdr degree2)$
+
+%:122%%123:%
+%line 2934 "liesuper.web"
+
+%line 2935 "liesuper.web"
+lisp operator generators_of_degree;
+lisp procedure generators_of_degree(bracketname,degree);
+begin scalar even_used,odd_used,generatorname,kvalue;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("GENERATORS_OF_DEGREE:",bracketname,"is not a liebracket",nil,t);
+if not integer_valued(degree:=if null degree then degree else if atom
+degree then list degree else if
+car degree= 'list then cdr degree else degree)then
+
+msgpri("DEGREE:", 'list . degree,"invalid degree",nil,t);
+even_used:=get(bracketname, 'even_used);
+odd_used:=get(bracketname, 'odd_used);
+generatorname:=get(bracketname, 'generatorname);
+kvalue:=get(generatorname, 'kvalue);
+%124:%
+%line 2957 "liesuper.web"
+
+%line 2958 "liesuper.web"
+return 'list .
+for i:=-odd_used:even_used join
+if i neq 0 and null assoc(list(generatorname,i),kvalue)and
+sub_degree(degree,
+permuted_degree(car
+getv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+i),
+get(bracketname, 'degree_sequence)))
+then
+list list(generatorname,i)
+
+%:124%
+%line 2945 "liesuper.web"
+;
+end$
+
+%:123%%125:%
+%line 2973 "liesuper.web"
+
+%line 2974 "liesuper.web"
+lisp operator commutators_of_degree;
+lisp procedure commutators_of_degree(bracketname,degree);
+begin scalar
+vector_structure,m,m_used,n,n_used
+,vector_i,entry_i_j,info_list,
+degree_sequence,degree_i;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("COMMUTATORS_OF_DEGREE:",bracketname,"is not a liebracket",nil,t);
+%49:%
+%line 1355 "liesuper.web"
+
+vector_structure:=get(bracketname, 'vector_structure);
+m:=get(bracketname, 'even_dimension);n:=get(bracketname, 'odd_dimension);
+m_used:=get(bracketname, 'even_used);n_used:=get(bracketname, 'odd_used)
+
+%:49%
+%line 2979 "liesuper.web"
+;
+info_list:=get(bracketname, 'info_list);
+if not integer_valued(degree:=if null degree then degree else if atom
+degree then list degree else if
+car degree= 'list then cdr degree else degree)then
+
+msgpri("DEGREE:", 'list . degree,"invalid degree",nil,t);
+degree_sequence:=get(bracketname, 'degree_sequence);
+%126:%
+%line 2990 "liesuper.web"
+
+%line 2991 "liesuper.web"
+return 'list .
+for i:=-n_used:m_used join
+ <<vector_i:=getv(vector_structure,n+i);
+degree_i:=car getv(info_list,n+i);
+for j:=i:m_used join
+if(null(entry_i_j:=getv(vector_i,m-j))or
+null cddr(entry_i_j))and
+sub_degree(degree,
+permuted_degree(add_degrees(degree_i,
+car getv(info_list,n+j)),
+degree_sequence))
+then
+list list(bracketname,i,j)
+>>
+
+%:126%
+%line 2984 "liesuper.web"
+;
+end$
+
+%:125%%127:%
+%line 3054 "liesuper.web"
+
+%line 3055 "liesuper.web"
+lisp operator new_generators;
+lisp procedure new_generators commutator_list;
+begin scalar operatorname,bracketname,arg1,arg2,indx,
+generator,degree,definition,history;
+return
+if atom commutator_list then commutator_list
+else <<
+operatorname:=car commutator_list;
+if operatorname= 'list then
+ 'list . for each commutator in cdr commutator_list collect
+new_generators reval commutator
+else
+if not get(operatorname, 'rtype)= 'liebracket then commutator_list
+else
+%128:%
+%line 3075 "liesuper.web"
+
+%line 3076 "liesuper.web"
+begin
+bracketname:=operatorname;
+arg1:=cadr commutator_list;
+arg2:=caddr commutator_list;
+if
+((not fixp arg1)or arg1<-get(bracketname, 'odd_dimension)
+or arg1>get(bracketname, 'even_dimension))or
+((not fixp arg2)or arg2<-get(bracketname, 'odd_dimension)
+or arg2>get(bracketname, 'even_dimension))then
+return commutator_list;
+%129:%
+%line 3091 "liesuper.web"
+
+%line 3092 "liesuper.web"
+if even_element(operatorname,commutator_list)then
+%130:%
+%line 3100 "liesuper.web"
+
+%line 3101 "liesuper.web"
+begin
+indx:=get(operatorname, 'even_used)+1;
+if indx<=get(operatorname, 'even_dimension)
+then
+ <<put(operatorname, 'even_used,indx);
+generator:=list(get(operatorname, 'generatorname),indx);
+%132:%
+%line 3127 "liesuper.web"
+
+%line 3128 "liesuper.web"
+degree:=add_degrees(car
+getv(get(operatorname, 'info_list),get(operatorname, 'odd_dimension)+arg1),
+car
+getv(get(operatorname, 'info_list),get(operatorname, 'odd_dimension)+arg2));
+history:=add_histories(cddr
+getv(get(operatorname, 'info_list),get(operatorname, 'odd_dimension)+arg1),
+cddr
+getv(get(operatorname, 'info_list),get(operatorname, 'odd_dimension)+arg2));
+definition:=list( 'list,arg1,arg2);
+
+putv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+indx,degree . definition . history)
+
+%:132%
+%line 3107 "liesuper.web"
+>> ;
+end
+
+%:130%
+%line 3093 "liesuper.web"
+
+else
+%131:%
+%line 3110 "liesuper.web"
+
+%line 3111 "liesuper.web"
+begin
+indx:=get(operatorname, 'odd_used)+1;
+if indx<=get(operatorname, 'odd_dimension)
+then
+ <<put(operatorname, 'odd_used,indx);
+indx:=-indx;
+generator:=list(get(operatorname, 'generatorname),indx);
+%132:%
+%line 3127 "liesuper.web"
+
+%line 3128 "liesuper.web"
+degree:=add_degrees(car
+getv(get(operatorname, 'info_list),get(operatorname, 'odd_dimension)+arg1),
+car
+getv(get(operatorname, 'info_list),get(operatorname, 'odd_dimension)+arg2));
+history:=add_histories(cddr
+getv(get(operatorname, 'info_list),get(operatorname, 'odd_dimension)+arg1),
+cddr
+getv(get(operatorname, 'info_list),get(operatorname, 'odd_dimension)+arg2));
+definition:=list( 'list,arg1,arg2);
+
+putv(get(bracketname, 'info_list),get(bracketname, 'odd_dimension)+indx,degree . definition . history)
+
+%:132%
+%line 3118 "liesuper.web"
+>> ;
+end
+
+%:131%
+%line 3095 "liesuper.web"
+
+
+%:129%
+%line 3082 "liesuper.web"
+;
+return if generator then
+setk(commutator_list,generator)
+else commutator_list
+end
+
+%:128%
+%line 3069 "liesuper.web"
+>> ;
+end$
+
+%:127%%133:%
+%line 3139 "liesuper.web"
+lisp procedure add_histories(history1,history2);
+%line 3140 "liesuper.web"
+if fixp history2 then list( 'list,history1,history2)
+else
+if fixp history1 then 'list . history1 . cdr history2
+else 'list . append(list history1,cdr history2)$
+
+%:133%%134:%
+%line 3150 "liesuper.web"
+lisp operator list_used;
+%line 3151 "liesuper.web"
+lisp procedure list_used bracketname;
+ <<
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("LIST_USED:",bracketname,"is not a liebracket",nil,t);
+list( 'list,get(bracketname, 'even_used),get(bracketname, 'odd_used))>> $
+
+%:134%%135:%
+%line 3158 "liesuper.web"
+
+%line 3159 "liesuper.web"
+lisp operator define_used;
+lisp procedure define_used(bracketname,used_list);
+begin scalar even_used,odd_used;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("DEFINE_USED:",bracketname,"is not a liebracket",nil,t);
+if atom(used_list)or car(used_list)neq 'list or
+length(used_list)neq 3 then
+
+msgpri("DEFINE_USED:",used_list,"invalid list of dimensions",nil,t);
+even_used:=cadr used_list;
+odd_used:=caddr used_list;
+if even_used>get(bracketname, 'even_dimension)or
+odd_used>get(bracketname, 'odd_dimension)
+then rederr("DEFINE_USED: dimensions out of range");
+put(bracketname, 'even_used,even_used);
+put(bracketname, 'odd_used,odd_used);
+end$
+
+%:135%%138:%
+%line 3206 "liesuper.web"
+lisp procedure liebracket decl_list;
+%line 3207 "liesuper.web"
+begin scalar bracketname,generatorname,m,n,
+algebra_elements,parameters,rtype,vector_structure,info_list;
+for each decl in decl_list do
+begin if length decl<4 then
+
+msgpri("LIEBRACKET:",decl,"invalid liebracket declaration",nil,t);
+%139:%
+%line 3226 "liesuper.web"
+
+%line 3227 "liesuper.web"
+bracketname:=car decl;generatorname:=cadr decl;
+m:=reval caddr decl;n:=reval cadddr decl;
+if decl:=cddddr decl then
+ <<algebra_elements:=car decl;algebra_elements:=if null algebra_elements then algebra_elements else if atom
+algebra_elements then list algebra_elements else if
+car algebra_elements= 'list then cdr algebra_elements else algebra_elements;
+if cdr decl then parameters:=cadr decl;parameters:=if null parameters then parameters else if atom
+parameters then list parameters else if
+car parameters= 'list then cdr parameters else parameters>>
+
+%:139%
+%line 3213 "liesuper.web"
+;
+%140:%
+%line 3240 "liesuper.web"
+
+%line 3241 "liesuper.web"
+if not idp bracketname or not idp generatorname or not fixp m or not
+fixp n or m<0 or n<0 then
+
+msgpri("LIEBRACKET:",decl,"invalid liebracket declaration",nil,t);
+if get(bracketname, 'simpfn)then
+
+msgpri("LIEBRACKET: operator",bracketname,
+"invalid as liebracket",nil,t);
+if rtype:=get(bracketname, 'rtype)then
+
+msgpri("LIEBRACKET:",rtype,bracketname,"invalid as liebracket",t);
+if get(generatorname, 'simpfn)then
+
+msgpri("LIEBRACKET: operator",generatorname,
+"invalid as generator",nil,t);
+if rtype:=get(generatorname, 'rtype)then
+
+msgpri("LIEBRACKET:",rtype,generatorname,"invalid as generator",t)
+
+%:140%
+%line 3214 "liesuper.web"
+;
+%141:%
+%line 3277 "liesuper.web"
+
+%144:%
+%line 3338 "liesuper.web"
+
+%line 3339 "liesuper.web"
+%143:%
+%line 3327 "liesuper.web"
+
+%line 3328 "liesuper.web"
+vector_structure:=mkvect(m+n);
+for i:=-n:m do putv(vector_structure,n+i,mkvect(m-i));
+for i:=-n:0 do putv(getv(vector_structure,n+i),m, '(s
+) . nil . 0);
+for j:=1:m do
+ <<putv(getv(vector_structure,n),m-j, '(s
+) . nil . 0);
+putv(getv(vector_structure,n+j),m-j, '(s
+) . nil . 0)>>
+
+%:143%
+%line 3339 "liesuper.web"
+;
+info_list:=mkvect(m+n);
+for i:=-n:m do putv(info_list,n+i, '(0) . i . i)
+
+%:144%
+%line 3278 "liesuper.web"
+;
+put(bracketname, 'vector_structure,vector_structure);
+put(bracketname, 'info_list,info_list);
+put(bracketname, '!*jacobi_var!*,list t);
+put(bracketname, 'even_dimension,m);
+put(bracketname, 'odd_dimension,n);
+put(bracketname, 'even_used,0);
+put(bracketname, 'odd_used,0);
+put(bracketname, 'degree_length,1);
+put(bracketname, 'algebra_elements,algebra_elements);
+put(bracketname, 'parameters,parameters);
+put(bracketname, 'oplist,
+bracketname . generatorname . 'list . 'df . algebra_elements);
+put(bracketname, 'resimp_fn, 'resimp_liebracket);
+put(bracketname, 'generatorname,generatorname);
+put(bracketname, 'rtype, 'liebracket);
+put(bracketname, 'simpfn, 'simp_liebracket);
+put(generatorname, 'bracketname,bracketname);
+put(generatorname, 'rtype, 'algebra_generator);
+put(generatorname, 'simpfn, 'simpiden);
+flag(list bracketname, 'full)
+
+%:141%
+%line 3215 "liesuper.web"
+;
+end;
+end$
+
+%:138%%145:%
+%line 70 "list2vector.ch"
+
+lisp operator save_liebracket;
+lisp procedure save_liebracket(bracketname,savefile);
+begin scalar generatorname,vector_list;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("SAVE_LIEBRACKET:",bracketname,"is not a liebracket",nil,t);
+generatorname:=get(bracketname, 'generatorname);
+rmsubs();
+out savefile;
+write"lisp$";
+terpri();terpri();
+%147:%
+%line 3398 "liesuper.web"
+
+%line 3399 "liesuper.web"
+write"if not getd 'simp_liebracket then";terpri();
+write"rederr(",
+"""Load the Lie superalgebra package before reading this file""",")$";
+terpri();terpri()
+
+%:147%
+%line 80 "list2vector.ch"
+;
+for each property in 'klist . cddr
+ '(vector_structure info_list !*jacobi_var!* even_dimension odd_dimension
+even_used odd_used degree_length degree_sequence algebra_elements
+parameters oplist resimp_fn
+generatorname rtype simpfn commutator_list identity_list
+unsolved_identities kvalue)do
+
+ <<prin2"put('";prin1 bracketname;prin2",'";prin1 property;prin2",'";
+prin1 get(bracketname,property);prin2")$";terpri();terpri()>> ;
+%146:%
+%line 97 "list2vector.ch"
+
+vector_list:=for each el in vector2list get(bracketname, 'vector_structure)
+collect vector2list el;
+prin2"put('";prin1 bracketname;
+prin2",'VECTOR_STRUCTURE,list2vector(for each el in '";
+prin1 vector_list;prin2" collect list2vector el))$";terpri();terpri();
+vector_list:=vector2list get(bracketname, 'info_list);
+prin2"put('";prin1 bracketname;prin2",'INFO_LIST,list2vector '";
+prin1 vector_list;prin2")$";terpri();terpri()
+
+%line 3394 "liesuper.web"
+
+%:146%
+%line 83 "list2vector.ch"
+;
+write"flag('(",bracketname,"),'full)$";terpri();terpri();
+for each property in 'klist .
+ '(bracketname rtype simpfn kvalue)do
+
+ <<prin2"put('";prin1 generatorname;prin2",'";prin1 property;prin2",'";
+prin1 get(generatorname,property);prin2")$";terpri();terpri()>> ;
+%149:%
+%line 3434 "liesuper.web"
+
+%line 3435 "liesuper.web"
+write"repair_vector_structure_of '",bracketname,"$";terpri();terpri()
+
+%:149%
+%line 87 "list2vector.ch"
+;
+write"algebraic$ end$";
+shut savefile;
+end$
+
+%:145%%148:%
+%line 3420 "liesuper.web"
+
+%line 3421 "liesuper.web"
+lisp procedure repair_vector_structure_of bracketname;
+begin scalar
+vector_structure,m,m_used,n,n_used
+,!*jacobi_var!*,vector_i,entry_i_j;
+%49:%
+%line 1355 "liesuper.web"
+
+vector_structure:=get(bracketname, 'vector_structure);
+m:=get(bracketname, 'even_dimension);n:=get(bracketname, 'odd_dimension);
+m_used:=get(bracketname, 'even_used);n_used:=get(bracketname, 'odd_used)
+
+%:49%
+%line 3423 "liesuper.web"
+;
+!*jacobi_var!*:=get(bracketname, '!*jacobi_var!*);
+for i:=-n_used:m_used do
+begin vector_i:=getv(vector_structure,n+i);
+for j:=i:m_used do
+if(entry_i_j:=getv(vector_i,m-j))and car(entry_i_j)= '(t)
+then
+putv(vector_i,m-j,!*jacobi_var!* . cdr entry_i_j);
+end;
+end$
+
+%:148%%150:%
+%line 3448 "liesuper.web"
+
+%line 3449 "liesuper.web"
+lisp operator print_liebracket;
+lisp procedure print_liebracket bracketname;
+begin scalar
+vector_structure,m,m_used,n,n_used
+,vector_i,commutator_i_j;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("PRINT_LIEBRACKET:",bracketname,"is not a liebracket",nil,t);
+%49:%
+%line 1355 "liesuper.web"
+
+vector_structure:=get(bracketname, 'vector_structure);
+m:=get(bracketname, 'even_dimension);n:=get(bracketname, 'odd_dimension);
+m_used:=get(bracketname, 'even_used);n_used:=get(bracketname, 'odd_used)
+
+%:49%
+%line 3453 "liesuper.web"
+;
+for i:=-n_used:m_used do
+begin vector_i:=getv(vector_structure,n+i);
+for j:=i:m_used do
+if(i neq 0)and(j neq 0)and(i neq j or i<0)and
+(commutator_i_j:=getv(vector_i,m-j))and
+(commutator_i_j:=aeval cddr commutator_i_j)then
+varpri(commutator_i_j,
+list( 'setk,mkquote list(bracketname,i,j),mkquote commutator_i_j),
+ 'only);
+end;
+end$
+
+%:150%%151:%
+%line 3485 "liesuper.web"
+
+%line 3486 "liesuper.web"
+lisp operator change_dimensions_of;
+lisp procedure change_dimensions_of(bracketname,m,n);
+begin scalar old_vector_structure,old_m,old_n,new_m,new_n,old_vector_i,entry_i_j,
+vector_structure,old_info_list,info_list,vector_i,m_used,n_used,
+degree_length,kernel_list;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("CHANGE_DIMENSIONS_OF:",bracketname,"is not a liebracket",nil,t);
+old_m:=get(bracketname, 'even_dimension);
+old_n:=get(bracketname, 'odd_dimension);
+new_m:=min(m,old_m);new_n:=min(n,old_n);
+m_used:=min(new_m,get(bracketname, 'even_used));
+n_used:=min(new_m,get(bracketname, 'odd_used));
+old_vector_structure:=get(bracketname, 'vector_structure);
+old_info_list:=get(bracketname, 'info_list);
+%144:%
+%line 3338 "liesuper.web"
+
+%line 3339 "liesuper.web"
+%143:%
+%line 3327 "liesuper.web"
+
+%line 3328 "liesuper.web"
+vector_structure:=mkvect(m+n);
+for i:=-n:m do putv(vector_structure,n+i,mkvect(m-i));
+for i:=-n:0 do putv(getv(vector_structure,n+i),m, '(s
+) . nil . 0);
+for j:=1:m do
+ <<putv(getv(vector_structure,n),m-j, '(s
+) . nil . 0);
+putv(getv(vector_structure,n+j),m-j, '(s
+) . nil . 0)>>
+
+%:143%
+%line 3339 "liesuper.web"
+;
+info_list:=mkvect(m+n);
+for i:=-n:m do putv(info_list,n+i, '(0) . i . i)
+
+%:144%
+%line 3499 "liesuper.web"
+;
+%152:%
+%line 3514 "liesuper.web"
+
+%line 3515 "liesuper.web"
+for i:=-new_n:new_m do
+begin
+old_vector_i:=getv(old_vector_structure,old_n+i);
+vector_i:=getv(vector_structure,n+i);
+for j:=i:new_m do
+if(entry_i_j:=getv(old_vector_i,old_m-j))then
+putv(vector_i,m-j,entry_i_j);
+putv(info_list,n+i,getv(old_info_list,old_n+i));
+end
+
+%:152%
+%line 3500 "liesuper.web"
+;
+put(bracketname, 'vector_structure,vector_structure);
+put(bracketname, 'info_list,info_list);
+put(bracketname, 'even_dimension,m);
+put(bracketname, 'odd_dimension,n);
+put(bracketname, 'even_used,m_used);
+put(bracketname, 'odd_used,n_used);
+%153:%
+%line 3539 "liesuper.web"
+
+%line 3540 "liesuper.web"
+if m>old_m or n>old_n then
+begin
+degree_length:=get(bracketname, 'degree_length);
+change_degree_length(bracketname,2*degree_length);
+change_degree_length(bracketname,degree_length);
+kernel_list:=
+for each dependency in get(get(bracketname, 'generatorname), 'kvalue)collect
+car dependency;
+for each kernel in kernel_list do setk(kernel,aeval kernel);
+end
+
+%:153%
+%line 3507 "liesuper.web"
+;
+end$
+
+%:151%%156:%
+%line 3587 "liesuper.web"
+
+%line 3588 "liesuper.web"
+lisp procedure liebracket_stat;
+begin scalar arguments;
+arguments:=xread nil;
+arguments:=
+if atom arguments or car arguments neq '!*comma!* then
+arguments
+else cdr arguments;
+scan();
+return default_liebracket!* . arguments;
+end$
+
+%:156%%157:%
+%line 3609 "liesuper.web"
+
+%line 3610 "liesuper.web"
+lisp procedure liebracket_prifn commutator;
+begin
+prin2!*"[";
+inprint( '!*comma!*,0,cdr commutator);
+prin2!*"]";
+end$
+
+%:157%%159:%
+%line 3627 "liesuper.web"
+lisp operator default_liebracket;
+%line 3628 "liesuper.web"
+
+lisp procedure default_liebracket bracketname;
+begin
+remprop(default_liebracket!*, 'prifn);
+default_liebracket!*:=bracketname;
+put(default_liebracket!*, 'prifn, 'liebracket_prifn);
+end$
+
+%:159%%163:%
+%line 3737 "liesuper.web"
+
+%line 3738 "liesuper.web"
+lisp operator transform_liebracket;
+lisp procedure transform_liebracket(bracketname,new_bracketname,
+new_generatorname,basis_transformation);
+begin scalar generatorname,even_bound,odd_bound,transform_vector,inverse_vector,
+new_generator,transformed_sq,splitted_sf,generator_list,x_gap,y_gap,
+new_even_used,new_odd_used,result;
+
+if get(bracketname, 'rtype)neq 'liebracket then
+
+msgpri("TRANSFORM_LIEBRACKET:",bracketname,"is not a liebracket",nil,t);
+generatorname:=get(bracketname, 'generatorname);
+%162:%
+%line 3719 "liesuper.web"
+
+%line 3720 "liesuper.web"
+if null !*full_transformation then
+begin even_bound:=get(bracketname, 'even_used);
+odd_bound:=get(bracketname, 'odd_used);
+end
+else
+begin even_bound:=get(bracketname, 'even_dimension);
+odd_bound:=get(bracketname, 'odd_dimension);
+end;
+transform_vector:=mkvect(even_bound+odd_bound);
+inverse_vector:=mkvect(even_bound+odd_bound)
+
+
+%:162%
+%line 3746 "liesuper.web"
+;
+%164:%
+%line 3759 "liesuper.web"
+
+%line 3760 "liesuper.web"
+%166:%
+%line 3841 "liesuper.web"
+
+if atom basis_transformation or car basis_transformation neq 'list
+then
+msgpri("TRANSFORM_LIEBRACKET",basis_transformation,
+"not valid as a basis transformation",nil,t);
+basis_transformation:=
+for each transformation_rule in cdr basis_transformation collect
+ <<if not
+(eqexpr transformation_rule and
+not atom cadr transformation_rule and
+car cadr transformation_rule=new_generatorname)or not
+ <<new_generator:=cadr cadr(transformation_rule);
+
+(fixp new_generator and new_generator neq 0 and new_generator<=even_bound and
+new_generator>=-odd_bound)>>
+then
+msgpri("TRANSFORM_LIEBRACKET:",cadr(transformation_rule),
+"not allowed as a new generator",nil,t);
+transformed_sq:=simp caddr(transformation_rule);
+splitted_sf:=split_form(numr transformed_sq,list(generatorname));
+if not
+null car splitted_sf and
+for each generator in cdr splitted_sf product
+if(generator:=cadr car generator)*new_generator>0 and
+
+(fixp generator and generator neq 0 and generator<=even_bound and
+generator>=-odd_bound)then 1 else 0=1 then
+
+msgpri("TRANSFORM_LIEBRACKET",cadr(transformation_rule),
+"must be a sum of generators with right sign",nil,t);
+
+for each generator in cdr splitted_sf do
+if not member(generator:=car generator,generator_list)then
+generator_list:=generator . generator_list
+;
+putv(transform_vector,odd_bound+new_generator,transformed_sq . splitted_sf);
+
+numr subtrsq(!*k2q cadr(transformation_rule),transformed_sq)>>
+
+%:166%
+%line 3760 "liesuper.web"
+;
+%167:%
+%line 3871 "liesuper.web"
+
+%line 3872 "liesuper.web"
+if length generator_list neq length basis_transformation then
+rederr"TRANSFORM_LIEBRACKET: inconsistent transformation";
+if basis_transformation then
+basis_transformation:=caadr solvesys(basis_transformation,generator_list);
+for each generator in generator_list do
+ <<transformed_sq:=car basis_transformation;
+putv(inverse_vector,odd_bound+cadr generator,
+transformed_sq . split_form(numr transformed_sq,list(new_generatorname)));
+basis_transformation:=cdr basis_transformation>>
+
+%:167%
+%line 3761 "liesuper.web"
+;
+%168:%
+%line 3927 "liesuper.web"
+
+ <<
+x_gap:=y_gap:=0;
+repeat x_gap:=x_gap+direction
+until abs(x_gap)>bound or(null getv(inverse_vector,odd_bound+x_gap)
+and null assoc(list(generatorname,x_gap),get(generatorname, 'kvalue)));
+if abs(x_gap)>bound then x_gap:=nil;
+repeat y_gap:=y_gap+direction
+until abs(y_gap)>bound or null getv(transform_vector,odd_bound+y_gap);
+while x_gap do <<
+putv(inverse_vector,odd_bound+x_gap,mksq(list(new_generatorname,y_gap),1) .
+list(nil,list(new_generatorname,y_gap) . 1));
+putv(transform_vector,odd_bound+y_gap,mksq(list(generatorname,x_gap),1) .
+list(nil,list(generatorname,x_gap) . 1));
+repeat x_gap:=x_gap+direction
+until abs(x_gap)>bound or(null getv(inverse_vector,odd_bound+x_gap)
+and null assoc(list(generatorname,x_gap),get(generatorname, 'kvalue)));
+if abs(x_gap)>bound then x_gap:=nil;
+repeat y_gap:=y_gap+direction
+until abs(y_gap)>bound or null getv(transform_vector,odd_bound+y_gap)>> ;new_even_used:=y_gap-1>> where direction=1,bound=even_bound;
+ <<
+x_gap:=y_gap:=0;
+repeat x_gap:=x_gap+direction
+until abs(x_gap)>bound or(null getv(inverse_vector,odd_bound+x_gap)
+and null assoc(list(generatorname,x_gap),get(generatorname, 'kvalue)));
+if abs(x_gap)>bound then x_gap:=nil;
+repeat y_gap:=y_gap+direction
+until abs(y_gap)>bound or null getv(transform_vector,odd_bound+y_gap);
+while x_gap do <<
+putv(inverse_vector,odd_bound+x_gap,mksq(list(new_generatorname,y_gap),1) .
+list(nil,list(new_generatorname,y_gap) . 1));
+putv(transform_vector,odd_bound+y_gap,mksq(list(generatorname,x_gap),1) .
+list(nil,list(generatorname,x_gap) . 1));
+repeat x_gap:=x_gap+direction
+until abs(x_gap)>bound or(null getv(inverse_vector,odd_bound+x_gap)
+and null assoc(list(generatorname,x_gap),get(generatorname, 'kvalue)));
+if abs(x_gap)>bound then x_gap:=nil;
+repeat y_gap:=y_gap+direction
+until abs(y_gap)>bound or null getv(transform_vector,odd_bound+y_gap)>> ;new_odd_used:=-y_gap-1>> where direction=-1,bound=odd_bound
+
+%:168%
+%line 3762 "liesuper.web"
+
+
+%:164%
+%line 3747 "liesuper.web"
+;
+%169:%
+%line 3947 "liesuper.web"
+
+%line 3948 "liesuper.web"
+%170:%
+%line 3963 "liesuper.web"
+
+%line 3964 "liesuper.web"
+put(bracketname, 'save_vector_structure,get(bracketname, 'vector_structure))
+
+%:170%
+%line 3948 "liesuper.web"
+;
+result:=errorset(list( 'transform_table,mkquote bracketname,mkquote generatorname,
+mkquote new_bracketname,mkquote new_generatorname,
+mkquote even_bound,mkquote odd_bound,
+mkquote new_even_used,mkquote new_odd_used,
+mkquote transform_vector,mkquote inverse_vector),t,t);
+%178:%
+%line 4167 "liesuper.web"
+
+%line 4168 "liesuper.web"
+put(bracketname, 'vector_structure,get(bracketname, 'save_vector_structure));
+remprop(bracketname, 'save_vector_structure);
+put(generatorname, 'simpfn, 'simpiden);
+remprop(generatorname, 'inverse_vector);
+remflag(list generatorname, 'full);
+remprop(generatorname, 'bounds)
+
+%:178%
+%line 3954 "liesuper.web"
+;
+if result then return
+list( 'list,
+( 'list . for i:=1:new_even_used collect mk!*sq car getv(transform_vector,odd_bound+i)),
+( 'list . for i:=1:new_odd_used collect mk!*sq car getv(transform_vector,odd_bound+-i)))
+
+%:169%
+%line 3748 "liesuper.web"
+;
+end$
+
+%:163%%171:%
+%line 3982 "liesuper.web"
+
+%line 3983 "liesuper.web"
+lisp procedure transform_table(bracketname,generatorname,
+new_bracketname,new_generatorname,even_bound,odd_bound,
+new_even_used,new_odd_used,
+transform_vector,inverse_vector);
+begin scalar m,n,vector_structure,vector_i,
+save_vector_structure,save_vector_i,save_entry_i_j,arg_i,arg_j,degree_length;
+remprop(new_generatorname, 'simpfn);
+apply1( 'liebracket,list list(new_bracketname,new_generatorname,
+even_bound,odd_bound,
+get(bracketname, 'algebra_elements),get(bracketname, 'parameters)));
+%175:%
+%line 4086 "liesuper.web"
+
+%line 4087 "liesuper.web"
+%173:%
+%line 4039 "liesuper.web"
+
+%line 4040 "liesuper.web"
+put(generatorname, 'inverse_vector,inverse_vector);
+put(generatorname, 'bounds,odd_bound . even_bound);
+put(generatorname, 'simpfn, 'simp_transform_vector);
+flag(list generatorname, 'full);
+rmsubs()
+
+%:173%
+%line 4087 "liesuper.web"
+;
+save_vector_structure:=get(bracketname, 'save_vector_structure);
+m:=get(bracketname, 'even_dimension);n:=get(bracketname, 'odd_dimension);
+%143:%
+%line 3327 "liesuper.web"
+
+%line 3328 "liesuper.web"
+vector_structure:=mkvect(m+n);
+for i:=-n:m do putv(vector_structure,n+i,mkvect(m-i));
+for i:=-n:0 do putv(getv(vector_structure,n+i),m, '(s
+) . nil . 0);
+for j:=1:m do
+ <<putv(getv(vector_structure,n),m-j, '(s
+) . nil . 0);
+putv(getv(vector_structure,n+j),m-j, '(s
+) . nil . 0)>>
+
+%:143%
+%line 4090 "liesuper.web"
+;
+for i:=-odd_bound:even_bound do begin
+save_vector_i:=getv(save_vector_structure,n+i);
+vector_i:=getv(vector_structure,n+i);
+arg_i:=getv(inverse_vector,odd_bound+i);
+for j:=i:even_bound do
+if(save_entry_i_j:=getv(save_vector_i,m-j))and
+cddr(save_entry_i_j)then
+(if car save_entry_i_j neq '(s
+)then
+putv(vector_i,m-j,nil . nil . aeval cddr save_entry_i_j))
+else putv(vector_i,m-j,
+nil . nil . mk!*sq transform_commutator(new_bracketname,arg_i,getv(inverse_vector,odd_bound+j)))
+end;
+put(bracketname, 'vector_structure,vector_structure);
+rmsubs()
+
+%:175%
+%line 3993 "liesuper.web"
+;
+%176:%
+%line 4135 "liesuper.web"
+
+for i:=-new_odd_used:new_even_used do
+if(arg_i:=getv(transform_vector,odd_bound+i))then
+for j:=i:new_even_used do
+if(arg_j:=getv(transform_vector,odd_bound+j))and
+i neq 0 and j neq 0 and(i neq j or i<0)then
+relation_analysis(mk!*sq subtrsq(simp!* list(new_bracketname,i,j),
+subs2 transform_commutator(bracketname,arg_i,arg_j)),
+new_bracketname);
+put(new_bracketname, 'even_used,new_even_used);
+put(new_bracketname, 'odd_used,new_odd_used)
+
+%:176%
+%line 3994 "liesuper.web"
+;
+%177:%
+%line 4158 "liesuper.web"
+
+%line 4159 "liesuper.web"
+degree_length:=if get(bracketname, 'degree_sequence)then
+length get(bracketname, 'degree_sequence)
+else get(bracketname, 'degree_length);
+change_degree_length(new_bracketname,degree_length);
+for i:=-new_odd_used:new_even_used do
+if i neq 0 then
+define_degree(list(new_generatorname,i),degree_of(mk!*sq car getv(transform_vector,odd_bound+i)))
+
+%:177%
+%line 3995 "liesuper.web"
+;
+end$
+
+%:171%%172:%
+%line 4019 "liesuper.web"
+
+%line 4020 "liesuper.web"
+
+lisp procedure simp_transform_vector generator;
+begin scalar generatorname,i,bounds,inverse_vector,value;
+generatorname:=car generator;
+i:=cadr generator;
+bounds:=get(generatorname, 'bounds);
+inverse_vector:=get(generatorname, 'inverse_vector);
+if i<-car bounds or i>cdr bounds then
+
+msgpri("TRANSFORM_LIEBRACKET:",generator,
+"out of the transformation range. Use 'on fulltransformation;'.",nil,t);
+return
+if value:=getv(inverse_vector,car bounds+i)then car value
+else simpiden generator
+end$
+
+%:172%%174:%
+%line 4063 "liesuper.web"
+
+%line 4064 "liesuper.web"
+lisp procedure transform_commutator(bracketname,transformed_i,transformed_j);
+quotsq(build_sum(bracketname,list(cdr transformed_j,cdr transformed_i)),
+!*f2q multf(denr car transformed_i,denr car transformed_j))$
+
+%:174%%180:%
+%line 4198 "liesuper.web"
+
+%line 4199 "liesuper.web"
+symbolic procedure fkern u;
+begin scalar x,y;
+if atom u then return list(u,nil);
+if get(car u, 'rtype)= 'liebracket and
+fixp cadr u and fixp caddr u then
+return fkern_liebracket u;
+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$
+
+%:180%%181:%
+%line 4234 "liesuper.web"
+symbolic procedure fkern_liebracket commutator;
+%line 4235 "liesuper.web"
+begin scalar bracketname,i,j,entry_i_j;
+bracketname:=car commutator;
+i:=cadr commutator;
+j:=caddr commutator;
+entry_i_j:=
+getv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+i),
+get(bracketname, 'even_dimension)-j);
+if null entry_i_j then entry_i_j:=
+
+putv(getv(get(bracketname, 'vector_structure),
+get(bracketname, 'odd_dimension)+i),
+get(bracketname, 'even_dimension)-j,nil . list(commutator,nil) . nil)
+else if null cadr entry_i_j then
+rplaca(cdr entry_i_j,list(commutator,nil));
+return cadr entry_i_j;
+end$
+
+%:181%%182:%
+%line 4259 "liesuper.web"
+
+%line 4260 "liesuper.web"
+symbolic procedure prepsq!* u;
+begin scalar x,!*combinelogs;
+if null numr u then return 0;
+x:=setkorder
+append((for each j in factors!*
+join if not idp j then nil
+else if get(j, 'rtype)= 'liebracket then
+ordn get_all_kernels(numr u,j)
+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 !*div
+or upl!* or dnl!*
+then replus prepsq!*1(numr u,denr u,nil)
+else sqform(u,function prepsq!*2);
+setkorder x;
+return u
+end$
+
+%:182%%183:%
+%line 4281 "liesuper.web"
+end;
+%line 4282 "liesuper.web"
+
+%:183%
diff --git a/web/reduce/rweb/appl/source/supervf.red b/web/reduce/rweb/appl/source/supervf.red
new file mode 100644
index 0000000000..621117e5ef
--- /dev/null
+++ b/web/reduce/rweb/appl/source/supervf.red
@@ -0,0 +1,330 @@
+%5:%
+%line 70 "supervf.web"
+
+symbolic$
+write"Super vectorfield package for REDUCE 3.4, $Revision: 0.94 $"$terpri()$
+%7:%
+%line 120 "supervf.web"
+
+%line 121 "supervf.web"
+algebraic operator ext$
+
+%:7%
+%line 73 "supervf.web"
+
+algebraic$
+
+%:5%%8:%
+%line 144 "supervf.web"
+lisp operator super_vectorfield;
+lisp procedure super_vectorfield(operator_name,even_dimension,
+odd_dimension,variables);
+begin
+if not idp operator_name then
+
+msgpri("SUPER_VECTORFIELD:",operator_name,"is not an identifier",nil,t);
+if not fixp even_dimension or even_dimension<0 or
+not fixp odd_dimension or odd_dimension<0 then
+rederr("SUPER_VECTORFIELD: improper dimensions");
+put(operator_name, 'simpfn, 'super_der_simp);
+flag(list(operator_name), 'full);
+put(operator_name, 'even_dimension,even_dimension);
+put(operator_name, 'odd_dimension,odd_dimension);
+put(operator_name, 'variables,if null variables then variables else if atom
+variables then list variables else if
+car variables= 'list then cdr variables else variables);
+end$
+
+%:8%%9:%
+%line 212 "supervf.web"
+lisp procedure merge_lists(x1,x2);
+begin scalar cx1,cx2,lx2,clx2,oddskip,sign;
+%10:%
+%line 219 "supervf.web"
+
+%line 220 "supervf.web"
+sign:=1;
+x1:=reverse x1;
+if x1 then cx1:=car x1 else goto b;
+a:if x2 then cx2:=car x2 else goto b;
+if cx1<cx2 then goto b;
+lx2:=cx2 . lx2;
+oddskip:=not oddskip;
+x2:=cdr x2;
+goto a
+
+%:10%
+%line 214 "supervf.web"
+;
+b:%11:%
+%line 231 "supervf.web"
+
+%line 232 "supervf.web"
+if null x1 then return sign . nconc(reversip lx2,x2);
+if null lx2 then return sign . nconc(reversip x1,x2);
+clx2:=car lx2;
+if cx1=clx2 and cx1>0 then return nil;
+if cx1>clx2 then goto b1;
+%12:%
+%line 241 "supervf.web"
+
+%line 242 "supervf.web"
+x2:=clx2 . x2;
+lx2:=cdr lx2;
+oddskip:=not oddskip;
+goto b
+
+%:12%
+%line 237 "supervf.web"
+;
+b1:%13:%
+%line 248 "supervf.web"
+
+%line 249 "supervf.web"
+x2:=cx1 . x2;
+x1:=cdr x1;
+if oddskip and cx1>0 then sign:=-sign;
+cx1:=car x1;
+goto b
+
+%:13%
+%line 238 "supervf.web"
+
+
+%:11%
+%line 215 "supervf.web"
+;
+end$
+
+%:9%%14:%
+%line 262 "supervf.web"
+
+lisp procedure ext_mult(x1,x2);
+(if null x then nil ./ 1
+else if null cdr x then 1 ./ 1
+else(((!*a2k( 'ext . cdr x) .^ 1) .* car x) .+ nil) ./ 1)
+where x=merge_lists(cdr x1,cdr x2)$
+
+%:14%%15:%
+%line 283 "supervf.web"
+
+lisp procedure super_der_simp u;
+if length u=2 then%16:%
+%line 296 "supervf.web"
+
+%line 297 "supervf.web"
+ begin scalar derivation_name,variables,even_components,odd_components,
+splitted_numr,splitted_denr;
+derivation_name:=reval car u;
+variables:=get(derivation_name, 'variables);
+u:=simp!* cadr u;
+%18:%
+%line 345 "supervf.web"
+
+splitted_numr:=split_form(numr u, '(ext));
+splitted_numr:=
+(list( 'ext) . car splitted_numr) . cdr splitted_numr;
+splitted_denr:=split_form(denr u, '(ext));
+splitted_denr:=
+(list( 'ext) . car splitted_denr) . cdr splitted_denr;
+even_components:=for i:=1:get(derivation_name, 'even_dimension)collect
+(nth(variables,i) . split_ext(component, '(ext)))
+where component=simp!* list(derivation_name,0,i);
+odd_components:=for i:=1:get(derivation_name, 'odd_dimension)collect
+(i . split_ext(component, '(ext)))
+where component=simp!* list(derivation_name,1,i)
+
+%:18%
+%line 303 "supervf.web"
+;
+return subtrsq(
+quotsq(addsq(even_action(even_components,splitted_numr),
+odd_action(odd_components,splitted_numr)),denr u ./ 1),
+quotsq(multsq(numr u ./ 1,even_action(even_components,splitted_denr)),
+multf(denr u,denr u) ./ 1));
+end
+
+%:16%
+%line 285 "supervf.web"
+
+else simpiden u$
+
+%:15%%17:%
+%line 329 "supervf.web"
+
+lisp procedure split_ext(sq,op_list);
+begin scalar denr_sq,splitted_form;
+denr_sq:=denr sq;
+splitted_form:=split_form(numr sq,op_list);
+return(list( 'ext) . cancel(car splitted_form ./ denr_sq)) .
+for each kc_pair in cdr splitted_form collect
+(car kc_pair . cancel(cdr kc_pair ./ denr_sq))
+end$
+
+%:17%%19:%
+%line 363 "supervf.web"
+
+%line 364 "supervf.web"
+lisp procedure even_action(components,splitted_form);
+begin scalar action;
+action:=nil ./ 1;
+for each kc_pair in splitted_form do
+action:=addsq(action,
+even_action_sf(components,cdr kc_pair,car kc_pair,1));
+return action;
+end$
+
+%:19%%20:%
+%line 377 "supervf.web"
+
+%line 378 "supervf.web"
+lisp procedure even_action_sf(components,sf,ext_kernel,fac);
+begin scalar action;
+action:=nil ./ 1;
+while not domainp sf do
+ <<action:=addsq(action,even_action_term(components,lt sf,ext_kernel,fac));
+sf:=red sf>> ;
+return action;
+end$
+
+%:20%%21:%
+%line 399 "supervf.web"
+
+lisp procedure even_action_term(components,term,ext_kernel,fac);
+addsq(even_action_pow(components,car term,
+ext_kernel,!*f2q multf(fac,cdr term)),
+even_action_sf(components,cdr term,
+ext_kernel,multf(fac,!*p2f car term)))$
+
+%:21%%22:%
+%line 410 "supervf.web"
+
+lisp procedure even_action_pow(components,pow,ext_kernel,fac);
+begin scalar kernel,n,component,derivative,action,active_components;
+kernel:=car pow;n:=cdr pow;
+%23:%
+%line 422 "supervf.web"
+
+%line 423 "supervf.web"
+if(component:=assoc(kernel,components))then
+return
+ <<derivative:=if n=1 then 1 ./ 1 else((((kernel .^ n-1) .* n) .+ nil) ./ 1);
+action:=component_action(component,ext_kernel,derivative);
+multsq(action,fac)>>
+
+%:23%
+%line 414 "supervf.web"
+;
+%27:%
+%line 490 "supervf.web"
+
+%line 491 "supervf.web"
+active_components:=find_active_components(kernel,components,nil)
+
+%:27%
+%line 415 "supervf.web"
+;
+%28:%
+%line 498 "supervf.web"
+
+%line 499 "supervf.web"
+action:=nil ./ 1;
+for each component in active_components do
+ <<derivative:=diffp(pow,car component);
+action:=addsq(action,component_action(component,ext_kernel,derivative))>> ;
+return multsq(action,fac)
+
+%:28%
+%line 416 "supervf.web"
+;
+end$
+
+%:22%%24:%
+%line 442 "supervf.web"
+
+lisp procedure component_action(component,ext_kernel,coefficient);
+begin scalar action;
+action:=nil ./ 1;
+for each kc_pair in cdr component do
+(if numr ext_product then
+action:=addsq(action,
+multsq(multsq(ext_product,even_coefficient),coefficient)))
+where ext_product=ext_mult(car kc_pair,ext_kernel),
+even_coefficient=cdr kc_pair;
+return action;
+end$
+
+%:24%%25:%
+%line 464 "supervf.web"
+
+lisp procedure find_active_components(kernel,components,components_found);
+begin
+components_found:=
+update_components(kernel .
+((if depl_entry then cdr depl_entry)where depl_entry=assoc(kernel,depl!*)),
+components,components_found)$
+if not atom kernel then
+for each element in kernel do
+components_found:=find_active_components(element,components,components_found);
+return components_found;
+end$
+
+%:25%%26:%
+%line 479 "supervf.web"
+
+lisp procedure update_components(dependencies,components,components_found);
+begin scalar component;
+for each kernel in dependencies do
+if(component:=assoc(kernel,components))
+and not assoc(kernel,components_found)then
+components_found:=component . components_found;
+return components_found;
+end$
+
+%:26%%29:%
+%line 519 "supervf.web"
+
+%line 520 "supervf.web"
+lisp procedure odd_action(components,splitted_form);
+begin scalar action,sign,derivative,kernel,coefficient,component;
+action:=nil ./ 1;
+for each kc_pair in splitted_form do
+ <<kernel:=car kc_pair;
+coefficient:=!*f2q cdr kc_pair;
+sign:=t;
+for each i in cdr kernel do
+ <<sign:=not sign;
+derivative:=!*a2k delete(i,kernel);
+component:=assoc(i,components);
+action:=addsq(action,
+component_action(component,derivative,
+if sign then negsq coefficient else coefficient))
+>>
+>> ;
+return action;
+end$
+
+%:29%%30:%
+%line 544 "supervf.web"
+
+%line 545 "supervf.web"
+lisp operator super_product;
+lisp procedure super_product(x,y);
+begin scalar splitted_x,splitted_y,product;
+splitted_x:=split_ext(simp x, '(ext));
+splitted_y:=split_ext(simp y, '(ext));
+product:=nil ./ 1;
+for each term_x in splitted_x do
+for each term_y in splitted_y do
+product:=addsq(product,
+multsq(multsq(cdr term_x,cdr term_y),
+ext_mult(car term_x,car term_y)));
+return mk!*sq subs2 product;
+end$
+
+%:30%%31:%
+%line 561 "supervf.web"
+end;
+%line 562 "supervf.web"
+
+%:31%
diff --git a/web/reduce/rweb/appl/source/tools.red b/web/reduce/rweb/appl/source/tools.red
new file mode 100644
index 0000000000..0dfa537ee9
--- /dev/null
+++ b/web/reduce/rweb/appl/source/tools.red
@@ -0,0 +1,446 @@
+%2:%
+%line 64 "tools.web"
+symbolic$
+write"Algebraic operator tools for REDUCE 3.4, $Revision: 1.4 $"$terpri()$
+algebraic$
+
+%:2%%7:%
+%line 129 "tools.web"
+lisp procedure get_first_kernel(form,oplist);
+gfk(form,if null oplist then oplist else if atom
+oplist then list oplist else if
+car oplist= 'list then cdr oplist else oplist,nil)$
+
+lisp procedure gfk(form,oplist,l);
+if l or domainp form then l
+else gfk(red form,oplist,
+gfk(lc form,oplist,
+if not atom x and member(car x,oplist)
+then x else l))
+where x=mvar form$
+
+%:7%%8:%
+%line 146 "tools.web"
+
+%line 147 "tools.web"
+lisp procedure get_all_kernels(form,oplist);
+gak(form,if null oplist then oplist else if atom
+oplist then list oplist else if
+car oplist= 'list then cdr oplist else oplist,nil)$
+
+lisp procedure gak(form,oplist,l);
+if domainp form
+then l
+else gak(red form,oplist,
+gak(lc form,oplist,
+if not atom x and member(car x,oplist)and not member(x,l)
+then l:=aconc(l,x)else l))
+where x=mvar form$
+
+%:8%%9:%
+%line 163 "tools.web"
+
+%line 164 "tools.web"
+lisp procedure get_recursive_kernels(form,oplist);
+grk(form,if null oplist then oplist else if atom
+oplist then list oplist else if
+car oplist= 'list then cdr oplist else oplist,nil)$
+
+lisp procedure grk(form,oplist,l);
+if domainp form
+then l else grk(red form,oplist,
+grk(lc form,oplist,
+%10:%
+%line 177 "tools.web"
+
+%line 178 "tools.web"
+if not atom x
+then begin scalar y;
+for each arg in cdr x do
+if(y:=simp arg)neq 0 then
+l:=grk(numr y,oplist,l);
+return if member(car x,oplist)and not member(x,l)
+then x . l else l end
+else l
+
+%:10%
+%line 171 "tools.web"
+))
+where x=mvar form$
+
+%:9%%14:%
+%line 280 "tools.web"
+
+%line 281 "tools.web"
+lisp procedure split_f(form,oplist,fact,kc_list);
+if null form then kc_list
+else if domainp form then
+addf(multf(fact,form),
+car kc_list) . cdr kc_list
+else if not atom mvar form and member(car mvar form,oplist)then
+if not ldeg form=1 or get_first_kernel(lc form,oplist)then
+
+msgpri("SPLIT_F: expression not linear w.r.t.",
+ 'list . oplist,nil,nil,t)
+else split_f(red form,oplist,fact,
+update_kc_list(kc_list,mvar form,multf(fact,lc form)))
+else split_f(red form,oplist,fact,
+split_f(lc form,oplist,
+multf(fact,!*p2f lpow form),kc_list))$
+
+%:14%%15:%
+%line 300 "tools.web"
+
+%line 301 "tools.web"
+lisp procedure split_form(form,oplist);
+split_f(form,oplist,1,nil . nil)$
+
+%:15%%16:%
+%line 309 "tools.web"
+lisp procedure list_assoc(car_exprn,a_list);
+%line 310 "tools.web"
+if null a_list then a_list else if caar a_list=car_exprn then a_list
+else list_assoc(car_exprn,cdr a_list)$
+
+%:16%%17:%
+%line 322 "tools.web"
+lisp procedure update_kc_list(kc_list,kernel,coefficient);
+%line 323 "tools.web"
+(if rest_list then <<rplaca(rest_list,caar rest_list . addf(cdar
+rest_list,coefficient));kc_list>> else
+car kc_list . (kernel . coefficient) . cdr kc_list)
+where rest_list=list_assoc(kernel,cdr kc_list)$
+
+%:17%%18:%
+%line 347 "tools.web"
+
+%line 348 "tools.web"
+put( 'operator_coeff, 'psopfn, 'operator_coeff_1)$
+
+lisp procedure operator_coeff_1 u;
+if length u neq 2 then rederr("OPERATOR_COEFF: wrong number of arguments")
+else operator_coeff(car u,reval cadr u)$
+
+%:18%%19:%
+%line 370 "tools.web"
+
+%line 371 "tools.web"
+lisp procedure operator_coeff(exprn,oplist);
+begin scalar numr_ex,denr_ex,kc_list;
+oplist:=if null oplist then oplist else if atom
+oplist then list oplist else if
+car oplist= 'list then cdr oplist else oplist;
+exprn:=simp!* exprn;numr_ex:=numr exprn;denr_ex:=denr exprn;
+kc_list:=split_form(numr_ex,oplist);
+return 'list . !*ff2a(car kc_list,denr_ex) .
+for each kc_pair in cdr kc_list collect
+list( 'list,car kc_pair,!*ff2a(cdr kc_pair,denr_ex));
+end$
+
+%:19%%20:%
+%line 402 "tools.web"
+
+%line 403 "tools.web"
+lisp procedure dump_operators(form,oplist,fact);
+if null form then nil
+else if domainp form then multf(fact,form)
+else if not atom mvar form and member(car mvar form,oplist)then
+dump_operators(red form,oplist,fact)
+else
+addf(dump_operators(red form,oplist,fact),
+dump_operators(lc form,oplist,multf(fact,!*p2f lpow form)))$
+
+%:20%%21:%
+%line 413 "tools.web"
+
+%line 414 "tools.web"
+put( 'independent_part, 'psopfn, 'independent_part_1)$
+
+lisp procedure independent_part_1 u;
+if length u neq 2 then rederr("INDEPENDENT_PART: wrong number of arguments")
+else independent_part(car u,reval cadr u)$
+
+lisp procedure independent_part(exprn,oplist);
+begin scalar numr_ex,denr_ex;
+oplist:=if null oplist then oplist else if atom
+oplist then list oplist else if
+car oplist= 'list then cdr oplist else oplist;
+exprn:=simp!* exprn;numr_ex:=numr exprn;denr_ex:=denr exprn;
+return !*ff2a(dump_operators(numr_ex,oplist,1),denr_ex);
+end$
+
+%:21%%22:%
+%line 464 "tools.web"
+
+lisp procedure multi_split_f(form,kernel_list,multi_power,fact,pc_list);
+if null form then pc_list
+else if domainp form then
+if multi_power then update_kc_list(pc_list,multi_power,multf(fact,form))
+else addf(multf(fact,form),car pc_list) . cdr pc_list
+else multi_split_f(red form,kernel_list,multi_power,fact,
+if member(mvar form,kernel_list)then
+multi_split_f(lc form,kernel_list,lpow form . multi_power,fact,pc_list)
+else multi_split_f(lc form,kernel_list,multi_power,
+multf(fact,!*p2f lpow form),pc_list))$
+
+
+%:22%%23:%
+%line 481 "tools.web"
+
+lisp procedure multi_split_form(form,kernel_list);
+multi_split_f(form,kernel_list,nil,1,nil . nil)$
+
+%:23%%24:%
+%line 496 "tools.web"
+
+%line 497 "tools.web"
+put( 'multi_coeff, 'psopfn, 'multi_coeff_1)$
+
+lisp procedure multi_coeff_1 u;
+if length u neq 2 then rederr("MULTI_COEFF: wrong number of arguments")
+else multi_coeff(car u,reval cadr u)$
+
+%:24%%25:%
+%line 509 "tools.web"
+lisp procedure multi_coeff(exprn,kernel_list);
+%line 510 "tools.web"
+begin scalar numr_ex,denr_ex,pc_list;
+kernel_list:=if null kernel_list then kernel_list else if atom
+kernel_list then list kernel_list else if
+car kernel_list= 'list then cdr kernel_list else kernel_list;
+exprn:=simp!* exprn;
+numr_ex:=numr exprn;denr_ex:=denr exprn;
+for each generator in kernel_list do if depends(denr_ex,generator)
+then
+msgpri("MULTI_COEFF: expression is not polynomial w.r.t. ",
+ 'list . kernel_list,nil,nil,t);
+pc_list:=multi_split_form(numr_ex,kernel_list);
+return 'list . !*ff2a(car pc_list,denr_ex) .
+for each pc_pair in cdr pc_list collect
+list( 'list,convert_multi_power car pc_pair,!*ff2a(cdr pc_pair,denr_ex));
+end$
+
+%:25%%26:%
+%line 529 "tools.web"
+
+%line 530 "tools.web"
+lisp procedure convert_multi_power multi_power;
+ 'times . for each power in multi_power collect
+if cdr power=1 then car power else list( 'expt,car power,cdr power)$
+
+%:26%%28:%
+%line 588 "tools.web"
+
+%line 589 "tools.web"
+lisp procedure split_arguments(arg_list,oplist,splitted_list);
+if null arg_list then splitted_list
+else split_arguments(cdr arg_list,oplist,
+multf(denr first_arg,car splitted_list) .
+split_form(numr first_arg,oplist) .
+cdr splitted_list)where first_arg=simp!* car arg_list$
+
+%:28%%29:%
+%line 604 "tools.web"
+lisp procedure split_operator u;
+%line 605 "tools.web"
+split_arguments(cdr u,get(car u, 'oplist),1 . nil)$
+
+%:29%%31:%
+%line 669 "tools.web"
+lisp procedure process_arg_stack(arg_stack,op_name,arg_list,fact);
+%line 670 "tools.web"
+if null arg_stack then multsq(!*f2q fact,
+apply1(get(op_name, 'resimp_fn),op_name . arg_list))
+else process_comp_list(car arg_stack,cdr arg_stack,op_name,arg_list,fact)$
+
+%:31%%32:%
+%line 678 "tools.web"
+
+%line 679 "tools.web"
+lisp procedure process_comp_list(comp_list,arg_stack,op_name,arg_list,fact);
+addsq(process_independent_part(car comp_list,arg_stack,op_name,arg_list,fact),
+process_components(cdr comp_list,arg_stack,op_name,arg_list,fact))$
+
+%:32%%33:%
+%line 691 "tools.web"
+lisp procedure process_independent_part(independent_part,arg_stack,
+%line 692 "tools.web"
+op_name,arg_list,fact);
+if null independent_part then nil . 1
+else
+process_arg_stack(arg_stack,op_name,1 . arg_list,multf(fact,independent_part))$
+
+
+%:33%%34:%
+%line 701 "tools.web"
+lisp procedure process_components(comp_list,arg_stack,op_name,arg_list,fact);
+%line 702 "tools.web"
+if null comp_list then nil . 1
+else
+addsq(process_components(cdr comp_list,arg_stack,op_name,arg_list,fact),
+process_arg_stack(arg_stack,op_name,caar comp_list . arg_list,
+multf(fact,cdar comp_list)))$
+
+%:34%%35:%
+%line 713 "tools.web"
+lisp procedure build_sum(op_name,arg_stack);
+%line 714 "tools.web"
+process_arg_stack(arg_stack,op_name,nil,1)$
+
+%:35%%36:%
+%line 727 "tools.web"
+lisp procedure simp_multilinear u;
+%line 728 "tools.web"
+quotsq(build_sum(car u,cdr splitted_list),!*f2q car splitted_list)
+where splitted_list=split_operator u$
+
+%:36%%38:%
+%line 750 "tools.web"
+
+%line 751 "tools.web"
+put( 'multilinear, 'stat, 'rlis)$
+
+lisp procedure multilinear u;
+for each decl in u do
+begin scalar op_name,resimp_fn;
+if length decl neq 2 and length decl neq 3 then
+
+msgpri(nil,decl,"invalid multilinear declaration",nil,t);
+if not idp(op_name:=car decl)then
+
+msgpri(nil,op_name,"invalid as operator",nil,t);
+put(op_name, 'oplist,if null cadr decl then cadr decl else if atom
+cadr decl then list cadr decl else if
+car cadr decl= 'list then cdr cadr decl else cadr decl);
+if(length decl=3 and(resimp_fn:=caddr decl))or
+(resimp_fn:=get(op_name, 'resimp_fn))or
+(resimp_fn:=get(op_name, 'simpfn))then put(op_name, 'resimp_fn,resimp_fn)
+else put(op_name, 'resimp_fn, 'simpiden);
+put(op_name, 'simpfn, 'simp_multilinear);
+flag(list(op_name), 'full);
+end$
+
+%:38%%41:%
+%line 795 "tools.web"
+
+%line 796 "tools.web"
+put( 'linear_solve, 'psopfn, 'linear_solve_1)$
+
+lisp procedure linear_solve_1 u;
+if length u neq 2 then
+rederr("LINEAR_SOLVE: wrong number of arguments")
+else linear_solve(car u,cadr u)$
+
+%:41%%43:%
+%line 845 "tools.web"
+
+%line 846 "tools.web"
+lisp procedure linear_solve(exprn,kernel);
+begin scalar kord!*,form;
+kernel:=!*a2k kernel;
+%42:%
+%line 814 "tools.web"
+
+%line 815 "tools.web"
+exprn:=fctrf numr simp!* exprn;
+exprn:=if domainp car exprn then cdr exprn else(car exprn . 1) . cdr exprn;
+form:=for each factor in exprn join
+if depends(factor,kernel)then list factor;
+if length form=1 then form:=numr car form else
+
+msgpri("LINEAR_SOLVE: expression not linear with respect to",
+kernel,nil,nil,t)
+
+%:42%
+%line 849 "tools.web"
+;
+setkorder list kernel;
+form:=reorder form;
+if(mvar form=kernel)and(ldeg form=1)and
+not depends(lc form,kernel)and not depends(red form,kernel)then
+return !*ff2a(negf red form,lc form)
+else
+msgpri("LINEAR_SOLVE: expression not linear with respect to",
+kernel,nil,nil,t);
+end$
+
+%:43%%44:%
+%line 863 "tools.web"
+
+%line 864 "tools.web"
+put( 'linear_solve_and_assign, 'psopfn, 'linear_solve_and_assign_1)$
+
+lisp procedure linear_solve_and_assign_1 u;
+if length u neq 2 then
+rederr("LINEAR_SOLVE_AND_ASSIGN: wrong number of arguments")
+else linear_solve_and_assign(car u,cadr u)$
+
+lisp procedure linear_solve_and_assign(exprn,kernel);
+setk(kernel,linear_solve(exprn,kernel))$
+
+%:44%%47:%
+%line 926 "tools.web"
+
+%line 927 "tools.web"
+put( 'solvable_kernels, 'psopfn, 'solvable_kernels_1)$
+
+lisp procedure solvable_kernels_1 u;
+if length u neq 3 then
+rederr("SOLVABLE_KERNELS: wrong number of arguments")
+else solvable_kernels(car u,cadr u,caddr u)$
+
+%:47%%49:%
+%line 964 "tools.web"
+
+%line 965 "tools.web"
+lisp procedure list_merge(element,merge_list);
+if member(element,merge_list)then merge_list else element .
+merge_list$
+
+%:49%%50:%
+%line 984 "tools.web"
+lisp procedure mk_kernel_list(form,k_oplist,c_oplist,forbidden,kernel_list);
+%line 985 "tools.web"
+if domainp form then kernel_list
+else(
+if not atom kernel then
+mk_kernel_list(red form,k_oplist,c_oplist,forbidden,
+mk_kernel_list(lc form,k_oplist,c_oplist,
+if member(car kernel,c_oplist)then t else forbidden,
+if member(car kernel,k_oplist)then
+if not forbidden and ldeg form=1 and
+not get_first_kernel(lc form,c_oplist)then
+list_merge(kernel,car kernel_list) . cdr kernel_list
+else
+car kernel_list . list_merge(kernel,cdr kernel_list)
+else kernel_list))
+else mk_kernel_list(red form,k_oplist,c_oplist,forbidden,
+mk_kernel_list(lc form,k_oplist,c_oplist,forbidden,kernel_list))
+)where kernel=mvar form$
+
+%:50%%51:%
+%line 1012 "tools.web"
+
+%line 1013 "tools.web"
+lisp procedure solvable_kernels(exprn,k_oplist,c_oplist);
+begin scalar form,kernel_list,forbidden_kernels;
+form:=numr simp!* exprn;
+k_oplist:=if null k_oplist then k_oplist else if atom
+k_oplist then list k_oplist else if
+car k_oplist= 'list then cdr k_oplist else k_oplist;
+c_oplist:=if null c_oplist then c_oplist else if atom
+c_oplist then list c_oplist else if
+car c_oplist= 'list then cdr c_oplist else c_oplist;
+kernel_list:=mk_kernel_list(form,k_oplist,c_oplist,nil,nil . nil);
+forbidden_kernels:=cdr kernel_list;
+kernel_list:=car kernel_list;
+for each kernel in forbidden_kernels do kernel_list:=delete(kernel,kernel_list);
+return 'list . kernel_list;
+end$
+
+%:51%%52:%
+%line 1027 "tools.web"
+end;
+%line 1028 "tools.web"
+
+%:52%
diff --git a/web/reduce/rweb/appl/supervf.web b/web/reduce/rweb/appl/supervf.web
new file mode 100644
index 0000000000..838a6445c2
--- /dev/null
+++ b/web/reduce/rweb/appl/supervf.web
@@ -0,0 +1,569 @@
+% Copyright (c) 1991 Marcel Roelofs, University of Twente, Enschede,
+% The Netherlands.
+%
+% $Header: supervf.web,v 0.94 92/02/26 17:29:57 roelofs Exp $
+%
+\input specification
+\def\Version$#1Revision: #2 ${Version #2}
+\def\title{SUPER VECTORFIELD}
+\font\titlefont=cmcsc10 scaled\magstep3
+\font\ttitlefont=cmtt10 scaled\magstep4
+\def\topofcontents{\null\vfill
+\centerline{\titlefont The {\ttitlefont SUPER VECTORFIELD} package for REDUCE}
+\vskip15pt\centerline{\Version$Revision: 0.94 $}
+\vskip15pt\centerline{\sc Marcel Roelofs}\vfill}
+\def\enditem{\medskip\noindent\ignorespaces}
+% single control sequences are used by WEB
+\def\BZ{{\bf Z}}
+\def\BN{{\bf N}}
+\def\BR{{\bf R}}
+\def\CinfU{C^\infty(U)}
+\def\dd#1#2{{\displaystyle{\partial #1\over\partial #2}}}
+
+@*=Super vectorfields in REDUCE. In this \.{WEB} file we shall implement
+the action of $\BZ_2$ graded vectorfields on $\BZ_2$ graded functions.
+The package is partially based on a former package by Gragert and
+Kersten, which also implemented $\BZ_2$ graded forms and operators
+like exterior differentiation, Lie derivatives, etc. Since our methods
+nowadays mainly consist of using vectorfields, there is no direct
+need for an implementation of these operators.
+
+\medskip
+
+\noindent The ``banner line'' defined here is intended for
+indentification purposes on loading. It should be changed whenever
+this file is modified. System dependent changes, however, should be
+made in a separate change file.
+
+@d banner="Super vectorfield package for REDUCE 3.4, $Revision: 0.94 $"
+
+@ We define the following macros for clarity.
+@d change_to_symbolic_mode =symbolic
+@d change_to_algebraic_mode =algebraic
+@d stop_with_error(string_1,expr_1,string_2,expr_2) = @/
+ msgpri(string_1,expr_1,string_2,expr_2,t) @;
+@d message(string_1,expr_1,string_2,expr_2) = @/
+ msgpri(string_1,expr_1,string_2,expr_2,nil) @;
+@d operator_name_of=car
+@d arguments_of=cdr
+@d first_argument_of=cadr
+@d second_argument_of=caddr
+@d first_element_of=car
+@d rest_of=cdr
+@d skip_list=cdr %Skip the |'list| in front of an algebraic list%
+
+@ The following macros are intended as common programming idioms.
+@d incr(x) = (x:=x+1)@;
+@d decr(x) = (x:=x-1)@;
+
+@ A new REDUCE switch can be introduced using the following code.
+
+@d initialize_global(global_name,value)=@/
+global '(global_name)$@/
+global_name:=value
+
+@d new_switch(switch_name,value)=@/
+initialize_global(!* @& switch_name,value)$@/
+flag('(switch_name),'switch)
+
+@ We do all initializations in the beginning of the package.
+@u
+change_to_symbolic_mode$@/
+write banner$terpri()$@/
+@<Lisp initializations@>
+change_to_algebraic_mode$
+
+@ We shall start with a (very) short description of the local picture of a
+graded manifold and vectorfields on these graded manifolds. For a more
+detailed description we refer to B. Kostant, Lecture Notes in
+Mathematics 570 (1977).
+
+The local picture of a {\it graded manifold} is $U\subset\BR^m$ open
+together with the {\it graded commutative algebra}
+$
+\CinfU\otimes\Lambda(n)
+$
+where $\Lambda(n)$ is the antisymmetric (exterior) algebra on $n$
+elements $s_1,\dots,s_n$, with $\BZ_2$-degree $\vert s_i\vert=1$ and $s_i
+s_j=-s_j s_i$.
+A particular element $f\in\CinfU\otimes\Lambda(n)$ is represented by
+$
+f=\sum_\mu f_\mu s_\mu
+$
+where
+$$\mu\in M_n=\{\mu=(\mu_1,\dots,\mu_k) \mid
+\mu_i\in\BN,1\leq\mu_1<\mu_2<\cdots< \mu_k\leq n\},$$
+$s_\mu=s_{\mu_1}s_{\mu_2}\cdots s_{\mu_k}$ and $f_\mu\in\CinfU$.
+
+{\it Graded vectorfields} on a graded manifold
+$(U,\CinfU\otimes\Lambda(n))$ are introduced as graded derivations of
+the algebra $\CinfU\otimes\Lambda(n)$. It can be shown that they
+constitute a left $\CinfU\otimes\Lambda(n)$-module. Locally a graded
+vectorfield $V$ is represented as
+$$
+V=\sum_{i=1}^m f_i\dd{}{x_i} + \sum_{j=1}^n g_j\dd{}{s_j}
+$$
+with $f_i,g_j\in\CinfU\otimes\Lambda(n)$ and $x_i$ $(i=1,\dots,m)$ a
+local coordinate system on $U$.
+
+The derivations $\dd{}{x_i}$ are even, while the derivation
+$\dd{}{s_j}$ are odd; they satisfy the relations
+$$
+ \dd{x_i}{x_k}=\delta_{ik},\qquad \dd{s_j}{x_k}=0,\qquad
+ \dd{x_i}{x_\ell}=0,\qquad \dd{s_j}{s_\ell}=\delta_{j\ell}.
+$$
+
+@ In REDUCE we shall represent the elements $s_\mu\in\Lambda(n)$ by
+EXT($\mu_1,\dots,\mu_k$). Thus elements of $\CinfU\otimes\Lambda(n)$
+can be implemented in REDUCE as ordinary algebraic expressions.
+
+@<Lisp ini...@>=
+algebraic operator ext$
+
+@*1 Initializing vectorfields.
+In order to introduce graded vectorfields, we need to know the
+local coordinates $x_i$ on $U$, as well as the components of
+$\dd{}{x_i}$ and $\dd{}{s_j}$.
+
+In this file we want to implement vectorfields as algebraic operators
+with a simplification procedure which takes care of the action on a function.
+It is our purpose to keep the local coordinates and the components
+local to one vectorfield at a time.
+
+The following procedure initializes a super vectorfield. The macro
+|make_oplist| is taken from the TOOLS package; it transforms algebraic
+and lisp lists and identifiers into the appropriate lisp lists.
+
+We will not give all components of the vectorfield here: it is much
+easier to give them separately, as we shall see in the sequel.
+
+@d make_oplist(op_list)=@/if null op_list then op_list else if atom
+op_list then list op_list else if
+car op_list='list then cdr op_list else op_list @;
+
+@u lisp operator super_vectorfield;
+lisp procedure super_vectorfield(operator_name,even_dimension,
+ odd_dimension,variables);
+begin
+ if not idp operator_name then @/
+ stop_with_error("SUPER_VECTORFIELD:",operator_name,"is not an identifier",nil);
+ if not fixp even_dimension or even_dimension<0 or
+ not fixp odd_dimension or odd_dimension<0 then@/
+ rederr("SUPER_VECTORFIELD: improper dimensions");
+ put(operator_name,'simpfn,'super_der_simp);
+ flag(list(operator_name),'full);@/
+ put(operator_name,'even_dimension,even_dimension);@/
+ put(operator_name,'odd_dimension,odd_dimension);@/
+ put(operator_name,'variables,make_oplist(variables));
+end$
+
+@*1 Implementation of exterior multiplication.
+Before we can implement the action of a graded vectorfield on a
+graded function we need to have a function that computes the
+(exterior) multiplication of two elements of $\Lambda(n)$.
+
+If we have two elements EXT($i_1,\dots,i_n$) and
+EXT($j_1,\dots,j_m$) then the product will be 0 or an expression of
+the form $\pm{}$EXT(\dots). In order to find this result we need to
+merge the lists $(i_1,\dots,i_n)$ and $(j_1,\dots,j_m)$ into one
+ordered list, taking into account the signs that occur due to the
+switching of all pairs of elements of the lists.
+
+In fact, since it is needed for cohomology computations by van den
+Hijligenberg and Post, we shall implement an even more general
+procedure: given two {\it ordered} lists $(i_1,\dots,i_m)$ and
+$(j_1,\dots,j_m)$, return the list which results from merging the two
+lists into one ordered lists, together with a sign due to the
+switching of indices. The elements of the list need, however, not only
+be positive integers anymore, but may also be negative integers, with
+the proviso that switching two negative integers does {\it not} cause
+a sign.
+
+The algorithm is rather simple: given two lists |x1| and |x2| we
+construct the merged list |x2| as follows (the notation |cx1| is an
+abbreviation for |car x1|, and the same for all other lists):
+
+\medskip
+\item{1.} reverse |x1| (|x1| is now ordered reversely) and move all
+the elements of |x2|, with which the first element of |x1| (i.e.\ the
+highest element) has to be interchanged for merging both lists, in
+reverse order on the list |lx2|. Keep track if the number of elements
+of |lx2| is odd or even with help of the boolean |oddskip|.
+
+\item{2.} if either |x1| or |lx2| is empty return the appropriate
+result.
+
+\item{3.} if |cx1=clx2| then we can return |nil| if both are positive,
+due to the anticommutativity.
+
+\item{4.} if |cx1>clx2| put |cx1| in front of |x2| and adjust the sign
+according to |oddskip| only if |cx1| is positive: if |cx1| is
+negative, so are all elements of |lx2| and thus no sign need to be added.
+Continue with 2.
+
+\item{5.} if |cx1<=clx2| put |clx2| in front of |x2| and adjust
+|oddskip|. Continue with 2.
+
+\enditem
+Since it is used quite frequently, we shall implement this procedure
+using labels in order to prevent overhead caused by (recursive)
+function calls.
+
+@u lisp procedure merge_lists(x1,x2);
+begin scalar cx1,cx2,lx2,clx2,oddskip,sign;
+@<Prepare |x1|, |x2| and |lx2|, if ready |goto b|@>;
+b: @<Weave all elements of |x1| and |lx2| in front of |x2|, return if done@>;
+end$
+
+@ The implementation of step 1.
+@<Prepare |x1|, |x2| and |lx2|, if ready |goto b|@>=
+ sign:=1;
+ x1:=reverse x1;
+ if x1 then cx1:=car x1 @+else goto b;
+a: if x2 then cx2:=car x2 @+else goto b;
+ if cx1<cx2 then goto b;
+ lx2:=cx2 . lx2;@/
+ oddskip:=not oddskip;@/
+ x2:=cdr x2;@/
+ goto a
+
+@ The implementation of steps 2 and 3.
+@<Weave all elements of |x1| and |lx2| in front of |x2|, return if done@>=
+ if null x1 then @+return sign . nconc(reversip lx2,x2);
+ if null lx2 then @+return sign . nconc(reversip x1,x2);
+ clx2:=car lx2;
+ if cx1=clx2 and cx1>0 then @+return nil;
+ if cx1>clx2 then goto b1;
+ @<Move first element of |lx2| to |x2| and |goto b|@>;
+b1: @<Move first element of |x1| to |x2| and |goto b|@>
+
+@ The implementation of step 5.
+@<Move first element of |lx2| to |x2| and |goto b|@>=
+ x2:=clx2 . x2;@/
+ lx2:=cdr lx2;@/
+ oddskip:=not oddskip;@/
+ goto b
+
+@ And finally step 4.
+@<Move first element of |x1| to |x2| and |goto b|@>=@/
+ x2:=cx1 . x2;@/
+ x1:=cdr x1;
+ if oddskip and cx1>0 then sign:=-sign;
+ cx1:=car x1;@/
+ goto b
+
+@ It's a piece of cake now the write a procedure for the
+multiplication of two ``EXT'' kernels. By definition |ext()| is equal
+to 1.
+
+@d sign_of=car
+@d arg_list_of=cdr
+
+@u
+lisp procedure ext_mult(x1,x2);
+(if null x then nil ./ 1
+ else @+if null arg_list_of x then 1 ./ 1
+ else (((!*a2k('ext . arg_list_of x) .^ 1) .* sign_of x) .+ nil) ./ 1)@/
+where x=merge_lists(arguments_of x1,arguments_of x2)$
+
+@*=The simplification procedure for vectorfields.
+The only thing left now is to implement the action of a vectorfield
+on a function by means of the simplification procedure
+|super_der_simp|.
+
+If $V$ is a vectorfield we shall assume that the components of
+$\dd{}{x_i}$ and $\dd{}{s_j}$ are given by $V(0,i)$ and $V(1,j)$,
+respectively.
+
+Since we want to be able to look at the value of the components, we have to make
+the following distinction: if a vectorfield has just one argument it
+is the action on a function, otherwise we just have to return the
+value of the kernel.
+
+@u
+lisp procedure super_der_simp u;
+if length u=2 then @<Return the action of the vectorfield on a function@>
+else simpiden u$
+
+@ The action is not very complicated: collect all the even and odd
+components of the vectorfield and apply the vectorfield to the
+numerator and denominator of the function, using the quotient rule.
+
+Notice that we don't want denominators of any function to contain
+odd variables, since such an expression can always be rewritten to a
+finite expression without odd variables in the denominator.
+
+@<Return the action of the vectorfield...@>=
+begin scalar derivation_name,variables,even_components,odd_components,@|
+ splitted_numr,splitted_denr;
+ derivation_name:=reval operator_name_of u;@/
+ variables:=get(derivation_name,'variables);@/
+ u:=simp!* first_argument_of u;
+ @<Get the lists |splitted_numr|, |splitted_denr|, |even_components|
+and |odd_components|@>;
+ return subtrsq(@|
+ quotsq(addsq(even_action(even_components,splitted_numr),@|
+ odd_action(odd_components,splitted_numr)), denr u ./ 1),@|
+ quotsq(multsq(numr u ./ 1, even_action(even_components,splitted_denr)),@|
+ multf(denr u,denr u) ./ 1));
+end
+
+@*1 Getting the vectorfield components.
+Finding all linear kernels of an algebraic operator and their
+coefficients in a standard form is performed by the procedure
+|split_form| of the TOOLS package, which acts on standard forms.
+Since it is more convenient for the components of the vectorfield to
+have the coefficients returned by |split_form| as standard quotients
+instead of standard forms, the following procedure applies
+|split_form| to the numerator of a standard quotient and takes care of
+the necessary conversion of the coefficients to standard quotients.
+
+In order to allow simple processing of the lists the independent part
+must be preceded by |ext()|.
+
+@d independent_part_of=car
+@d kc_list_of=cdr
+@d kernel_of=car
+@d coefficient_of=cdr
+
+@u
+lisp procedure split_ext(sq,op_list);
+begin scalar denr_sq,splitted_form;
+ denr_sq:=denr sq;
+ splitted_form:=split_form(numr sq,op_list);
+ return (list('ext) . cancel(independent_part_of splitted_form ./ denr_sq)) .
+ for each kc_pair in kc_list_of splitted_form collect@/
+ (kernel_of kc_pair . cancel(coefficient_of kc_pair ./ denr_sq))
+end$
+
+@ For a proper action of |even_action| and |odd_action| all components
+need to be decomposed into ``EXT'' kernels and their coefficients.
+Since the action is most conveniently performed recursively on
+standard forms, the numerator and denominator are decomposed at
+standard form level.
+
+@<Get the lists ...@>=
+ splitted_numr:=split_form(numr u,'(ext));@/
+ splitted_numr:=
+ (list('ext) . independent_part_of splitted_numr) . kc_list_of splitted_numr;@/
+ splitted_denr:=split_form(denr u,'(ext));@/
+ splitted_denr:=
+ (list('ext) . independent_part_of splitted_denr) . kc_list_of splitted_denr;@/
+ even_components:=for i:=1:get(derivation_name,'even_dimension) collect@/
+ (nth(variables,i) . split_ext(component,'(ext)))@|
+ where component=simp!* list(derivation_name,0,i);@/
+ odd_components:=for i:=1:get(derivation_name,'odd_dimension) collect@/
+ (i . split_ext(component,'(ext)))@|
+ where component=simp!* list(derivation_name,1,i)
+
+@*1 Action of the even components.
+The action of the even part of a vectorfield on a function is fairly
+simple at top level: just add the actions on all kernel-coefficient pairs.
+
+@u
+lisp procedure even_action(components,splitted_form);
+begin scalar action;
+ action:=nil ./ 1;
+ for each kc_pair in splitted_form do@/
+ action:=addsq(action,
+ even_action_sf(components,coefficient_of kc_pair,kernel_of kc_pair,1));
+ return action;
+end$
+
+@ The action on a standard form is the sum of the actions on all
+terms. If the last term is a domain element we don't have to take it
+into consideration.
+
+@u
+lisp procedure even_action_sf(components,sf,ext_kernel,fac);
+begin scalar action;
+ action:=nil ./ 1;
+ while not domainp sf do
+ <<action:=addsq(action,even_action_term(components,lt sf,ext_kernel,fac));
+ sf:=red sf>>;
+ return action;
+end$
+
+@ For the action on the leading term we use the derivation property: the
+action on the leading power has to be added to the action on the
+leading coefficient. The last argument of |even_action_sf| is the
+product of all leading powers which have already been treated and with
+which the result has to be multiplied.
+
+For reasons of efficiency it is more convenient to have the factor as
+in standard quotient in |even_action_pow|.
+
+@d term_pow=car
+@d term_coeff=cdr
+
+@u
+lisp procedure even_action_term(components,term,ext_kernel,fac);
+addsq(even_action_pow(components,term_pow term,
+ ext_kernel,!*f2q multf(fac,term_coeff term)),@|
+ even_action_sf(components,term_coeff term,
+ ext_kernel,multf(fac,!*p2f term_pow term)))$
+
+@ Finally we have to implement the action on leading powers. For this
+we have to find all dependencies of the main variable on local coordinates
+occuring in the vectorfield, and act accordingly.
+
+@u
+lisp procedure even_action_pow(components,pow,ext_kernel,fac);
+begin scalar kernel,n,component,derivative,action,active_components;
+ kernel:=car pow; n:=cdr pow; %|pow=kernel^n|%
+ @<If |kernel| is one the even local coordinates, return the action on |pow|@>;
+ @<Find all the dependencies of |kernel| and construct |active_components|@>;
+ @<Return the sum of the actions of |active_components| on |pow|@>;
+end$
+
+@ We can check if |kernel| is one of the local coordinates by a simple
+|assoc| on |components|.
+
+@<If |kernel| is one the even ...@>=
+if (component:=assoc(kernel,components)) then
+return
+ <<derivative:=if n=1 then 1 ./ 1 @+else ((((kernel .^ n-1 ) .* n) .+ nil) ./ 1);
+ action:=component_action(component,ext_kernel,derivative);@/
+ multsq(action,fac)>>
+
+@ The procedure |component_action| takes care of returning the sum of all
+products of the |kc_pairs| in |component| with |ext_kernel| and
+|derivative|.
+
+Recall that super vectorfields have a left $\CinfU\otimes\Lambda(n)$
+module structure. This means that we have to take care that the
+arguments in the |ext_mult| call have to be in the right order:
+components of the vectorfield left and the |ext_kernel|'s from the
+function right. Of course, if the product of the two ``EXT'' kernels
+is zero, there is no need to consider the summand.
+
+@d combined_product(x,y,z)=@/multsq(multsq(x,y),z)
+
+@u
+lisp procedure component_action(component,ext_kernel,coefficient);
+begin scalar action;
+ action:=nil ./ 1;
+ for each kc_pair in kc_list_of component do@/
+ (if numr ext_product then@/
+ action:=addsq(action,
+ combined_product(ext_product,even_coefficient,coefficient)))@|
+ where ext_product=ext_mult(kernel_of kc_pair,ext_kernel),@|
+ even_coefficient=coefficient_of kc_pair;
+ return action;
+end$
+
+@ If a kernel is not one of the local coordinates, it may still depend
+on them, in which case we can still differentiate it w.r.t. such a coordinate.
+
+The following procedure tries finds all active components in |kernel|
+as completely as possible.
+
+@d get_dependencies_of(kernel)=
+ ((if depl_entry then cdr depl_entry) where depl_entry=assoc(kernel,depl!*))
+
+@u
+lisp procedure find_active_components(kernel,components,components_found);
+begin
+ components_found:=@|
+ update_components(kernel . get_dependencies_of(kernel),
+ components,components_found)$
+ if not atom kernel then
+ for each element in kernel do@/
+ components_found:=find_active_components(element,components,components_found);
+ return components_found;
+end$
+
+@ The procedure |update_components| takes care that |components_found|
+contains all active components just once.
+
+@u
+lisp procedure update_components(dependencies,components,components_found);
+begin scalar component;
+ for each kernel in dependencies do
+ if (component:=assoc(kernel,components))
+ and not assoc(kernel,components_found) then@/
+ components_found:=component . components_found;
+ return components_found;
+end$
+
+@
+@<Find all the dependencies of |kernel| and construct |active_components|@>=@/
+active_components:=find_active_components(kernel,components,nil)
+
+@ Once we know all active components we can simply apply |diffp| to
+compute the derivatives of |pow| and |component_action| to compute the
+action of the different components. Recall that the final result has
+to be multiplied with |fac|.
+
+@<Return the sum of the actions of |active_components| on |pow|@>=
+action:=nil ./ 1;
+for each component in active_components do
+ <<derivative:=diffp(pow,kernel_of component);
+ action:=addsq(action,component_action(component,ext_kernel,derivative))>>;
+return multsq(action,fac)
+
+@*1 Action of the odd components.
+The action of the odd components is much simpler than the action of
+the even components since the dependencies are clear at once: the only
+dependency on odd variables are the indices of the ``EXT'' kernels.
+
+Odd differentiations can cause an additional sign:
+$$
+ \dd{}{s_{i_j}}s_{i_1}\dots,s_{i_j},\dots,s_{i_n}=
+ (-1)^{j-1}s_{i_1}\dots,\widehat{s_{i_j}},\dots,s_{i_n}
+$$
+Additional signs are governed by the boolean |sign|.
+After the deletion of one index we have to apply |!*a2k| in order to
+get a unique kernel.
+
+@u
+lisp procedure odd_action(components,splitted_form);
+begin scalar action,sign,derivative,kernel,coefficient,component;
+ action:=nil ./ 1;
+ for each kc_pair in splitted_form do
+ <<kernel:=kernel_of kc_pair;@/
+ coefficient:=!*f2q coefficient_of kc_pair;@/
+ sign:=t;@/
+ for each i in arguments_of kernel do
+ <<sign:=not sign;@/
+ derivative:=!*a2k delete(i,kernel);@/
+ component:=assoc(i,components);@/
+ action:=addsq(action,
+ component_action(component,derivative,
+ if sign then negsq coefficient @+else coefficient))
+ >>
+ >>;
+ return action;
+end$
+
+@*=Multiplication of graded expressions. Since it is useful in
+practical problems, we shall finally implement a procedure
+|super_product| for multiplying two graded expressions. Using some of
+the above procedures this is not difficult at all.
+
+@u
+lisp operator super_product;
+lisp procedure super_product(x,y);
+begin scalar splitted_x,splitted_y,product;
+ splitted_x:=split_ext(simp x,'(ext));
+ splitted_y:=split_ext(simp y,'(ext));@/
+ product:=nil ./ 1;
+ for each term_x in splitted_x do
+ for each term_y in splitted_y do@/
+ product:=addsq(product,@|
+ combined_product(coefficient_of term_x,coefficient_of term_y,@|
+ ext_mult(kernel_of term_x,kernel_of term_y)));
+ return mk!*sq subs2 product;
+end$
+
+@ The end of a REDUCE input file must be marked with |end|.
+
+@u end;
+
+@*=Index. This section contains a cross reference index of all
+identifiers, together with the numbers of the mdules in which they are
+used. Underlined entries correspond to module numbers where the
+identifier was declared.
+
+
+
diff --git a/web/reduce/rweb/appl/sym_cond_example b/web/reduce/rweb/appl/sym_cond_example
new file mode 100644
index 0000000000..b455a6b763
--- /dev/null
+++ b/web/reduce/rweb/appl/sym_cond_example
@@ -0,0 +1,200 @@
+% This file contains all the necessary statements for computing the
+% symmetries of the KdV equations up to a certain order. By changing
+% some of the statements in the first part of the file, it may be easily
+% adapted to compute symmetries of other (systems of) equations.
+
+load tools,integrator,supervf;
+
+% Give the set of dependent variables u,v,... etc.
+dependent_variables := {u}$
+
+% Since for the odd variable numbers are given instead of variables we introduce
+% odd_offset, the number after which the dependent odd variables start (and continue
+% consecutively) and the number of odd variables:
+odd_offset:=0$
+nr_odd_variables:=0$
+
+% Give the order of the system of pde's
+order_pde := 3$
+
+% Give the order of the symmetries one wants to consider
+order_sym := 5$
+
+% Give the expressions for the t derivatives ut,vt,... of the dependent variables
+ut:=u3+u*u1$
+
+% Give the set of nonlocal variables to be considered as well.
+nonlocal_variables := {}$
+nonlocal_odd_offset := 0$
+nr_odd_nonlocal := 0$
+
+% Give the x and t derivatives px and pt of all nonlocal variables p.
+
+% Specify the functions f(1),...,f(n), f(-1),...,f(-m) here.
+% If not specified, the functions will be made dependent on
+% the proper variables further on.
+
+algebraic operator f,c;
+
+nr_odd_f:=nr_odd_variables$
+nr_even_f:=nr_variables$
+nr_odd_c:=0$
+nr_even_c:=0$
+
+% Give or give not information during construction of equations
+% Useful when computing large examples.
+write_mke:=nil$
+
+%--------------------------------------------------------------------------------
+% Make no changes behind this line. We will now compute the symmetry conditions
+% for the vectorfield f(1)*d/du + f(2)*d/dv + ... + D_x(f(1))*d/du_1 + ...,
+% where f(1),f(2),... depend on the variables
+% x,t, u,v,... ,u1,v1,..., un,vn,..., p1,...,pm, if n is the order of the
+% symmetry and p1,...,pm are all the nonlocal variables considered;
+
+nr_variables := length dependent_variables$
+nr_nonlocal := length nonlocal_variables$
+
+dim_vars := 2 + nr_nonlocal + nr_variables*(order_pde + order_sym + 1)$
+dim_odd_vars := max(odd_offset + nr_odd_variables*(order_pde + order_sym + 1),
+ nonlocal_odd_offset + nr_odd_nonlocal)$
+
+vars := for i:=1:order_pde + order_sym + 1 join
+ for j:=1:nr_variables collect mkid(part(dependent_variables,j),i)$
+vars := x . t . append(nonlocal_variables, append(dependent_variables,vars))$
+
+algebraic operator equ,var_x;
+
+initialize_equations(equ,nr_variables+nr_odd_variables,vars,
+ {c,nr_even_c,nr_odd_c},{f,nr_even_f,nr_odd_f});
+
+vectorfield(ddx,vars);
+vectorfield(ddt,vars);
+
+% The following procedure gives the number of D_x^n(ui) if ui is the i-th
+% local variable
+algebraic procedure var_nr(i,n);
+ 2+nr_nonlocal+n*nr_variables+i$
+
+algebraic procedure odd_var_nr(i,n);
+ odd_offset+n*nr_odd_variables+i$
+
+for i:=1:dim_vars do var_x i:=part(vars,i);
+
+% We construct the components of the total derivatives D_x and D_t
+ddx(0,1) := 1$
+ddx(0,2) := 0$
+for i:=1:nr_nonlocal do
+ ddx(0,2+i) := mkid(part(nonlocal_variables,i),x);
+for i:=1:nr_variables do
+ for n:=0:order_pde + order_sym do
+ ddx(0,var_nr(i,n)) := var_x(var_nr(i,n+1));
+for i:=1:nr_odd_nonlocal do
+ ddx(1,nonlocal_odd_offset+i):=mkid(mkid(ext,nonlocal_odd_offset+i),x);
+for i:=1:nr_odd_variables do
+ for n:=0:order_pde + order_sym do
+ ddx(1,odd_var_nr(i,n)) := ext(odd_var_nr(i,n+1));
+
+procedure mk_ddt;
+begin
+ ddt(0,1) := 0$
+ ddt(0,2) := 1$
+ for i:=1:nr_nonlocal do
+ ddt(0,2+i) := mkid(part(nonlocal_variables,i),t);
+ for i:=1:nr_variables do
+ ddt(0,var_nr(i,0)) := mkid(part(dependent_variables,i),t);
+ for i:=1:nr_variables do
+ for n:=1:order_sym do
+ ddt(0,var_nr(i,n)) := ddx ddt(0,var_nr(i,n-1));
+ for i:=1:nr_odd_nonlocal do
+ ddt(1,nonlocal_odd_offset+i):=mkid(mkid(ext,nonlocal_odd_offset+i),t);
+ for i:=1:nr_odd_variables do
+ ddt(1,odd_var_nr(i,0)) := mkid(mkid(ext,odd_offset+i),t);
+ for i:=1:nr_odd_variables do
+ for n:=1:order_sym do
+ ddt(1,odd_var_nr(i,n)) := ddx ddt(1,odd_var_nr(i,n-1));
+end$
+
+% For the construction of the symmetry condition we need to compute
+% the action of the linearisator of the system of pde's on
+% f(1),...,f(n),f(-1),...,f(-m)
+% We will save these as equ(1),...,equ(n+m)
+
+vectorfield(symmetry,vars);
+
+procedure make_prolongation;
+begin
+ for i:=1:nr_variables do
+ begin
+ symmetry(0,var_nr(i,0)) := f(i);
+ for n:=1:order_pde do <<
+ if write_mke then write "Prolongation of f(",i,") up to order ",n;
+ symmetry(0,var_nr(i,n)):=ddx symmetry(0,var_nr(i,n-1))>>;
+ end;
+ for i:=1:nr_odd_variables do
+ begin
+ symmetry(1,odd_var_nr(i,0)) := f(-i);
+ for n:=1:order_pde do <<
+ if write_mke then write "Prolongation of f(",-i,") up to order ",n;
+ symmetry(1,odd_var_nr(i,n)):=ddx symmetry(1,odd_var_nr(i,n-1))>>;
+ end;
+end$
+
+procedure make_equations;
+begin
+ for i:=1:nr_variables do
+ begin scalar evolution;
+ evolution:=mkid(part(dependent_variables,i),t);
+ if write_mke then write "Computing equation for f(",i,")";
+ equ(i):=ddt f(i) - symmetry evolution;
+ end;
+ for i:=1:nr_odd_variables do
+ begin scalar evolution;
+ evolution:=mkid(mkid(ext,odd_offset+i),t);
+ if write_mke then write "Computing equation for f(",-i,")";
+ equ(nr_variables+i):=ddt f(-i) - symmetry evolution;
+ end;
+ if not write_mke then
+ if (nr_variables+nr_odd_variables)=1 then write "Introduced equation 1"
+ else write "Introduced equations ",1,",...,",nr_variables+nr_odd_variables;
+end$
+
+% Check if f(-m),...,f(n) are already defined, if not make them
+% dependent on the proper variables.
+
+lisp operator has_no_definition;
+lisp procedure has_no_definition(opr,i);
+if assoc(list(opr,i),get(opr,'kvalue)) then nil else t$
+
+for i:=-nr_odd_variables:nr_variables do
+ if i neq 0 and has_no_definition(f,i) then
+ <<for k:=1:nr_variables do
+ for l:=0:order_sym do depend f(i),var_x(var_nr(k,l));
+ depend f(i),x,t
+ >>;
+
+% Define some handy abbreviations
+define es=integrate_equation,
+ seq=integrate_equations,
+ xes=integrate_exceptional_equation,
+ pr=show_equation,
+ preq=show_equations,
+ te=equations_used(),
+ pte=put_equations_used,
+ fu=functions_used,
+ pfu=put_functions_used;
+
+% Compute the prolongation of the vectorfield, the components of D_t
+% and finally all the equations.
+
+make_prolongation();
+mk_ddt();
+make_equations();
+
+% For the KdV, cracking the problem is utterly simple:
+% (other systems require more skill !!)
+
+auto_solve 1;
+
+end;
+
diff --git a/web/reduce/rweb/appl/symmetry.tex b/web/reduce/rweb/appl/symmetry.tex
new file mode 100644
index 0000000000..eb79fe7509
--- /dev/null
+++ b/web/reduce/rweb/appl/symmetry.tex
@@ -0,0 +1,974 @@
+\documentstyle[a4wide,fleqn]{article}
+
+\input mssymb
+
+\renewcommand{\theequation}{\thesection.\arabic{equation}}
+\setlength{\parindent}{0pt}
+\newtheorem{df}{Definition}[section]
+\newtheorem{lemma}[df]{Lemma}
+\newtheorem{th}[df]{Theorem}
+\newtheorem{rem}[df]{Remark}
+%\newtheorem{proof}[df]{Proof}
+\newtheorem{prop}[df]{Proposition}
+\newtheorem{cor}[df]{Corollary}
+\newtheorem{ex}[df]{Example}
+\newcommand{\Ng}{\setcounter{df}{0}}
+\newcommand{\rbox}{\begin{flushright} $ \Box $ \end{flushright}}
+
+\newcommand{\groot}{\displaystyle}
+\newcommand{\skipline}{\vspace{4mm}}
+
+\def\h{\hbox{$\goth h$}}
+\def\g{\hbox{$\goth g$}}
+\newtheorem{Definition}{Definition}[section]
+\newtheorem{Proposition}[Definition]{Proposition}
+
+\begin{document}
+
+\title{Lecture\\ Generalized Symmetries} \author{Paul H.M. Kersten \\
+Department of Applied Mathematics\\ University of Twente\\
+P.O. Box 217\\ 7500 AE Enschede\\ The Netherlands}
+
+
+\date{}
+\maketitle
+
+\begin{abstract}
+\mbox{\ }
+\end{abstract}
+
+\section{Introduction.}
+The classical notion of symmetry of a system of differential equations
+was based on transformations in the space of independent en dependent
+variables, transforming solutions into solutions. These symmetries are
+called {\it point} symmetries. The first generalization of this
+concept is to consider transformations of independent, dependent
+variables and first order partial derivatives, and transforming
+solutions into solutions. This leads to the socalled {\it contact}
+symmetries. Generalized symmetries, the subject of this lecture, can
+be understood as transformations in the space of independent,
+dependent variables and {\it all} partial derivatives \cite{O,V}.\\
+
+Notations will be as follows.\\
+$X$ is the space of independent variables, local coordinates being
+\begin{displaymath}
+ (x_1,...,x_p)
+\end{displaymath}
+$U$ is the space of dependent variables where local coordinates are
+\begin{displaymath}
+ (u^1,...,u^q)
+\end{displaymath}
+The $k^{th}$ order jetbundle $J^k(x,u)$ has local coordinates
+\begin{equation}
+\label{1.1a}
+ (x_i,u^{\alpha},u^{\alpha}_I) \qquad (|I| \leq k,i=1,...,p ; \alpha = 1,...,q)
+\end{equation}
+while the infinite jetbundle $J(x,u) = J^{\infty}(x,u)$ has local
+coordinates
+\begin{equation}
+\label{1.1b}
+ (x_i,u^{\alpha},u_I ^{\alpha}) \; \; |I| < \infty
+\end{equation}
+In (\ref{1.1a}),(\ref{1.1b}) we used the multiindex notation
+$I=(i_1,...,i_p) \; |I| = \sum\limits_{k=1}^p i_r$\\
+
+Throughout we shall use summation convention in case an index occurs
+twice; latin indices run from $1$ to $p$ while greek indices run from
+$1$ to $q$.\\
+
+Functions $f:J^k(x,u) \rightarrow \Bbb R$ are supposed to be
+$C^{\infty}$, while functions $g:J(x,u) \rightarrow \Bbb R$ are just
+those dependent on a {\it finite} number of variables, so in effect
+\begin{displaymath}
+ g = \pi_k^* f \mbox{ for some } f \mbox{ and } k,
+\end{displaymath}
+(see previous lectures).
+notation $f = f[u], g = g[u]$.\\
+A system of $k-th$ order differential equations is denoted by
+\begin{equation}
+\label{1.1c}
+ \Delta_j[u] = 0 \; (j=1,...,\l)
+\end{equation}
+where $\Delta_j$ is defined on $J^k(x,u)$.\\
+The total partial derivative operators $D_i$ are given by
+\begin{equation}
+\label{1.1d}
+ D_i = \frac{\partial}{\partial x _ {i}} + u^\alpha_{I,i}
+\frac{\partial}{\partial u_I^\alpha} \; \; (i=1,...,q)
+\end{equation}
+and they re-create in an algebraic way, what is realized classically
+by partial differentiation, using chain-rule.\\
+
+In section 2 we give a short recapitulation of the notion of
+infinitesimal symmetry. In section 3 the concept of generalized
+symmetry is given, some theorems are proved and an explicit example is
+given.\\
+In section 4 the notion of nonlocal symmetry, \cite{KV,KV2} being a
+generalization of generalized symmetry, is introduced and an illustration
+through the famous Korteweg-de Vries equation (KdV) is
+discussed. In the conclusions we point out that even generalizations
+of this concept are very interesting.\\
+
+Applications of symmetries to construct explicit solutions,
+conservation laws etc are beyond the scope of this lecture, and are
+dealt with in p.e. ref \cite{O}, \cite{KB}.
+
+\setcounter{equation}{0}
+\section{Classical Symmetries.}
+We give a short review of classical (infinitesimal) symmetries of
+differential equations.\\
+We start at a $k$-th order system of differential equations
+\begin{equation}
+\label{1.1}
+ \Delta_j[u] = 0 \; \; j = 1,\ldots,\l.
+\end{equation}
+A vector field $V \epsilon T(J^0(x,u))$ is given by
+\begin{equation}
+\label{1.2}
+ V = \xi^i(x,u) \frac{\partial}{\partial x ^ {i}} +
+\varphi_{\alpha}(x,u) \frac{\partial}{\partial u ^ {\alpha}}
+\end{equation}
+The $k^{th}$ prolongation of the vector field $V$ defined in
+$T(J^k(x,u))$ and denoted $pr^{k}(V)$ is given by
+\begin{equation}
+\label{1.3}
+ pr^{k}(V) = \xi^i (x,u) \frac{\partial}{\partial x ^ {i}} +
+\Phi_{\alpha}^I [u] \frac{\partial}{\partial u
+_{I} ^ {\alpha}}
+\end{equation}
+where
+\begin{equation}
+\label{1.4}
+ \Phi_{\alpha}^I [u] = D^I (\varphi_{\alpha}(x,u) - u_i^{\alpha}
+\xi^i (x,u)) + u_{I,i} ^{\alpha} \xi^i (x,u)
+\end{equation}
+and
+\begin{equation}
+\label{1.4a}
+ D^I = D_1^{i _{1}} o D_2^{i _ {2}} ... o D_p^{i _ {p}}
+\end{equation}
+
+Formula (\ref{1.4}) can be obtained by the conditions that the
+prolongation of the vector field $V$ leaves the contact structure
+\begin{equation}
+\label{1.5}
+ \omega_J^{\alpha} = du_J^{\alpha} - u_{J,i}^\alpha dx^i \; \;
+(|J| \leq k-1)
+\end{equation}
+invariant \cite{O}.\\
+We now arrive at the following definition.
+
+\begin{df}
+A vector field $V$ (\ref{1.2}) is a (infinitesimal) symmetry of the
+system of differential equations (\ref{1.1}) if
+\begin{equation}
+\label{1.6}
+ \hspace{5cm} pr^{(k)}(V)(\Delta_j) = 0 \; \; \mbox{ on } \Delta = 0
+\end{equation}
+We shall not compute symmetries here; but postpone it to the next
+section.\\
+Computerprograms to construct solutions of the symmetry condition
+(\ref{1.6}) are discussed in p.e. \cite{K}.
+\end{df}
+
+\setcounter{equation}{0}
+\section{Generalized Symmetries.}
+
+In this section we generalize the classical notion of infinitesimal
+symmetries to generalized symmetries, sometimes called
+Lie-B\"{a}cklund transformations: not te be confused with B\"{a}cklund
+transformations which are of a completely different nature.\\
+Remind that classically a vector field $V \epsilon T(J^0(x,u))$ is
+given by
+\begin{equation}
+\label{2.1}
+ V = \xi^i(x,u) \frac{\partial}{\partial x^{i}} + \varphi_\alpha(x,u)
+\frac{\partial}{\partial u_{\alpha}}
+\end{equation}
+We now pass to the infinite jetbundle $J(x,u)$ where local coordinates
+are given by
+\begin{displaymath}
+ (x^i,u^{\alpha},u^{\alpha}_I) \; \; I = (i_1,...,i_p) \; i_k \geq 0(k=1,...,p)
+\end{displaymath}
+functions $F:J(x,u) \rightarrow \Bbb R$ are to be understood to depend
+on an arbitrary but finite number of variables, $F=F[u]$.
+
+\begin{df}
+A (formal) generalized vector field is given by the following
+expression
+\begin{equation}
+\label{2.2}
+ V = \xi^i[u] \frac{\partial}{\partial x ^ {i}} +
+\varphi_{\alpha}[u] \frac{\partial}{\partial u ^ {\alpha}}
+\end{equation}
+The formal prolongation of $V$ to the infinite jetbundle is defined by
+\begin{equation}
+\label{2.3}
+ pr(V) = \xi^i[u] \frac{\partial}{\partial x ^{i}} +
+\Phi^J_{\alpha}[u] \frac{\partial}{\partial u^{\alpha}_{J}}
+\end{equation}
+whereas in the second term summation runs over $\alpha$ and all
+possible multiindices $J$ and
+\begin{equation}
+\label{2.4}
+ \Phi^J_{\alpha} = D^J(\varphi_{\alpha}[u] - \xi^i [u] u^{\alpha}_i) +
+\xi^i [u] u^{\alpha}_{J,i},
+\end{equation}
+compare this with formula (\ref{1.4}).\\
+
+{\bf Note} there arise no convergence problems in defining the action
+of an (infinitely) prolonged vector field on a function $F[u]$
+since the latter only depends on a finite number of variables.\\
+
+We now arrive at the definition of generalized symmetry.
+\end{df}
+
+\begin{df}
+A generalized vector field $V$ is a generalized symmetry of a system of
+differential equations
+\begin{displaymath}
+ \Delta_j[u] = 0 \; \; (j=1,...,\l)
+\end{displaymath}
+if and only if
+\begin{equation}
+\label{2.5}
+ pr(V)(\Delta_j) = 0 \; \; (j=1,...,\l)
+\end{equation}
+for solutions $u = f(x)$.\\
+
+{\bf Note} it can be proved that for applications one has in mind
+that condition (\ref{2.5}) results in
+\begin{equation}
+\label{2.6}
+ pr(V)(\Delta_j) = \sum P_{k,j}^J [u]D^J (\Delta_k) \; \;
+j=k=1,\ldots l \qquad |J|< \infty, \; \; P^J_{k,j}[u]\in C^\infty(J(x,u))
+\end{equation}
+or $pr(V)(\Delta_j) = 0$ when restricted to the manifold $Y \subset
+J(x,u)$ defined by the system of differential equations and all its
+differential consequences.\\
+
+The concept of evolutionary or vertical vector field is a great
+advantage in the computation of generalized symmetries.
+\end{df}
+
+\begin{df}
+ A generalized vector field
+\begin{equation}
+\label{2.7}
+ V = V_F = F_{\alpha}[u] \frac{\partial}{\partial u^\alpha}
+\end{equation}
+is called an evolutionary or vertical vector field.\\
+The set of functions $(F_{\alpha})$ is called the {\em characteristic} of the
+vector field $V$.\\
+
+Note that for evolutionary vector fields we have a very elegant way for
+the expression of the infinite prolongation (\ref{2.4}) i.e.
+\begin{equation}
+\label{2.8}
+ pr(V_F) = D^J(F_{\alpha} [u]) \frac{\partial}{\partial u ^{\alpha} _ {J}}
+\end{equation}
+because $\xi^i [u] \equiv 0 \; \; (i=1,\ldots,p)$.\\
+\end{df}
+
+Moreover every infinitely prolonged vector field $V$ (\ref{2.2},\ref{2.3})
+can be written as a sum of an evolutionary vector field and total
+partial derivative vector fields i.e.
+\begin{equation}
+\label{2.9}
+ pr(V) = pr(V_F) + \xi^i[u]D_i
+\end{equation}
+where the characteristic $F$ of the evolutionary vector field is given
+by
+\begin{equation}
+\label{2.10}
+ F_{\alpha}[u] = \varphi_{\alpha}[u] - u^{\alpha}_i \xi^i [u] \; \;
+(\alpha=1,\ldots,q)
+\end{equation}
+Since vector fields $\xi^i[u]D_i$ satisfy the symmetry condition
+(\ref{2.5}),(\ref{2.6}) in a trivial way; we can restrict the search for
+generalized symmetries to the search for {\it evolutionary} vector fields.\\
+
+To show the complexity of the computations involved in constructing
+generalized symmetries we compute {\it third} order symmetries of the
+potential form of Burgers' equation.
+
+\begin{ex}
+Burgers' equation is the following partial differential equation
+\begin{equation}
+\label{2.11}
+ u_t = u_1^2 + u_2 \; \; (u_1=u_x,u_2=u_{xx})
+\end{equation}
+Note that differential consequences are given by
+\begin{eqnarray}
+\label{2.11b}
+ u_{1t} & = & 2u_1u_2 + u_3 \qquad (u_{1t} = u_{xt})\\\nonumber
+ u_{2t} & = & 2u_2^2 + 2u_1u_3 + u_4\\
+ u_{3t} & = & 6u_2u_3 + 2u_1u_4 + u_5\nonumber
+\end{eqnarray}
+The characteristic of the evolutionary vector field $V_F$ is
+\begin{equation}
+\label{2.12}
+ F[u] = F(x,t,u,u_1,u_2,u_3)
+\end{equation}
+Since we restrict to the solution manifold $u_t,u_{1t},..$ can be
+eliminated by (\ref{2.11}),(\ref{2.11b})
+\end{ex}
+Now due to (\ref{2.8}) the symmetry condition (\ref{2.5}),(\ref{2.6})
+reduces to
+\begin{equation}
+\label{2.13}
+ D_tF - 2u_1 D_xF - D_x^2 F = 0
+\end{equation}
+
+\begin{equation}
+\begin{array}{ll}
+\label{2.14}
+ \mbox{i.e. }& F_t + F_u(u_1^2 + u_2) + F_{u_1} (2u_1u_2 + u_3) +
+ F_{u_2} (2u_2^2 + 2u_1u_3 + u_4)\\
+ &+ F_{u_3} (6u_2u_3 + 2u_1u_4 + u_5)\\
+ &- 2u_1(F_x + F_u u_1 + F_{u_1} u_2 + F_{u_2} u_3 + F_{u_3} u_4)\\
+ &- \{F_{xx} + F_{xu} u_1 + F_{xu_1} u_2 + F_{xu_2} + F_{xu_3} u_4\\
+ &+ u_1(F_{xu} + F_{uu} u_1 + F_{uu_1} u_2 + F_{uu_2} u_3 + F_{uu3} u_4)\\
+ &+ u_2(F_{xu_1} + F_{uu_1} u_1 + F_{u_1u_1} u_2 + F_{u_1u_2}
+ u_3 + F_{u_1u_3} u_4)\\
+ &+ u_3(F_{xu_2} + F_{uu_2} u_1 + F_{u_1u_2} u_2 + F_{u_2u_2} u_3 +
+ F_{u_2u_3} u_4)\\
+ &+ u_4(F_{xu_3} + F_{uu_3} u_1 + F_{u_1u_3} u_2 + F_{u_2u_3} u_3 +
+ F_{u_3u_3} u_4)\\
+ &+ F_u u_2 + F_{u_1} u_3 + F_{u_2} u_4 + F_{u_3} u_5 \} = 0
+\end{array}
+\end{equation}
+
+>From (\ref{2.14}) we see that the coefficient of $u_5$ vanishes
+identically. The vanishing of the coefficients of $u_4,u_4^2$ lead to
+\begin{eqnarray}
+\label{2.15}
+ u_4^2 : F_{u_3u_3} = 0
+\end{eqnarray}
+\begin{eqnarray}
+\label{2.16}
+ u_4 : -F_{xu_3} - u_1 F_{uu_3} - u_2 F_{u_1u_3} - u_3 F_{u_2u_3} = u_4
+\end{eqnarray}
+
+The first equation leads to the fact that $F_3$ is a polynomial of
+degree $\leq 1$ in $u_3$ while the second equation results in
+
+\begin{equation}
+\label{2.17}
+ F = \alpha(t)u_3 + \bar F(x,t,u,u_1,u_2)
+ \end{equation}
+
+Substitution of (\ref{2.17}) into (\ref{2.14}) leads to a polynomial
+of degree 2 in $u_3$, the coefficients of which have to vanish i.e.
+\begin{eqnarray}
+\label{2.18}
+ u_3^2 : \bar F_{u_2u_2} = 0
+\end{eqnarray}
+\begin{eqnarray}
+\label{2.19}
+ u_3 : \alpha'(t) + 6u_2\alpha(t) = 2 \bar F_{xu_2} + 2 \bar F{_uu_2} u_1 +
+ 2u_2 \bar F_{u_1u_2}
+\end{eqnarray}
+which results in
+
+\begin{equation}
+\label{2.20}
+ \bar F(x,t,u,u_1,u_2) = 3\alpha u_1u_2 + (\frac{1}{2} \alpha'x +
+\beta(t))u_2 + \tilde F(x,t,u,u_1)
+\end{equation}
+proceeding in this way we finally arrive at the fact that the solution
+of (\ref{2.13}) is a linear combination of 10 vector fields whose
+characteristics are given by
+
+\begin{equation}
+\label{2.21a}
+ \begin{array}{rcl}
+ F_0 &=& 1\\
+ F_1 &=& u_1\\
+ F_2 &=& tu_1 + \frac{1}{2} x\\
+ F_3 &=& u_2 + u_1^2\\
+ F_4 &=& t(u_2 + u_1^2) + \frac{1}{2} xu_1
+ \end{array}
+\end{equation}
+\begin{equation}
+\label{2.21b}
+ \begin{array}{rcl}
+ F_5 &=& t^2(u_2 + u_1^2) + txu_1 + (\frac{1}{2} t + \frac{1}{4} x^2)\\
+ F_6 &=& u_3 + 3u_1u_2 + u_1^3\\
+ F_7 &=& tF_6 + \frac{1}{2} x F_3\\
+ F_8 &=& t^2F_6 + txF_3 + (\frac{1}{2} t + \frac{1}{4} x^2)F_1\\
+ F_9 &=& t^3F_6 + \frac{3}{2} t^2 xF_3 + (\frac{3}{2} t^2 + \frac{3}{4}
+ tx^2)F_1 + \frac{3}{4} tx + \frac{1}{8} x^3\\
+ \end{array}
+\end{equation}
+ and\\
+\begin{eqnarray*}
+ F_{10} &=& \rho (x,t)e^{-u}
+\end{eqnarray*}
+whereas in (\ref{2.21b}) $\rho(x,t)$ is an arbitrary solution of the
+heat equation $\rho_t = \rho_{xx}$.
+
+The existence of a symmetry (\ref{2.21b}) reflects the fact that the
+equation at hand (\ref{2.11}) is in 1-1 correspondence with the heat
+equation. The general theorem concerning this was proved by Kumei \&
+Bluman \cite{KB}.\\
+At the moment a number of computerprograms is available in
+REDUCE,...,to handle the computations for symmetries p.e. \cite{K}.\\
+In order to introduce the Lie bracket of generalized vector fields we
+first prove the following lemma.
+
+\begin{lemma}
+ If $V_F$ is an evolutionary vector field then
+
+\begin{equation}
+\label{2.22}
+ [pr(V_F),D_i] = 0
+\end{equation}
+interpreted as componentwise.
+\end{lemma}
+
+\noindent{\bf Proof.} First of all $\frac{\partial}{\partial
+ u_j^\alpha} (D_iP) = \frac{\partial P}{\partial u_{J\backslash
+ i}^\alpha} + D_i(\frac{\partial}{\partial u_J^\alpha}P)$\\
+where $J\backslash i = (j_1,\ldots,j_{i-1},\ldots,j_p)$.\\
+This implies that
+
+\begin{equation}
+\label{2.23}
+ pr(V_F)(D_iP) = (D^J F_\alpha)\cdot \frac{\partial}{\partial
+ u_J^\alpha}(D_iP) = (D^J F_\alpha)D_i(\frac{\partial}{\partial
+ u_J^\alpha}P) + D^J F_\alpha \cdot \frac{\partial P}{\partial
+ u^\alpha_{J\backslash i}}
+\end{equation}
+We know that
+
+\begin{equation}
+\label{2.24}
+ D_i(pr(V_F)P) = D_i((D^J F_\alpha) \cdot \frac{\partial P}{\partial
+ u_J^\alpha}) = (D^J F\alpha)D_i(\frac{\partial
+ P}{\partial u_J^\alpha}) + (D_iD_JF_\alpha) \frac{\partial P}{\partial
+ u_J^\alpha}.
+\end{equation}
+
+By changing summation index $J$ tot $J\backslash i$ we see that the
+right hand sides in (\ref{2.23},\ref{2.24}) are equal, which proves
+the Lemma.\\
+As a corollary to this lemma we have
+\begin{equation}
+\label{2.25}
+ pr(V_F)(D^JP) = D^J(pr(V_F)P)
+\end{equation}
+
+\begin{th}
+Let $V_Q,V_R$ be two evolutionary vector fields and $pr(V_Q)$,
+$pr(V_R)$ their prolongations to $J(x,u)$ then the formal commutator is
+
+\begin{equation}
+\label{2.26}
+ [pr(V_Q),pr(V_R)] = \tilde S
+\end{equation}
+where $\tilde S$ is the prolongation of an evolutionary vector field
+
+\begin{equation}
+\label{2.27}
+ \tilde S = pr(V_S)
+\end{equation}
+and $S$ is defined by
+
+\begin{equation}
+\label{2.28}
+ S_\alpha = pr(V_Q)(R_\alpha) - pr(V_R)(Q_\alpha) \qquad \alpha=1,\ldots,q
+\end{equation}
+\end{th}
+
+\noindent{\bf Proof.} The definition of $S$ in (\ref{2.28}) is just
+the computation of the $\frac{\partial}{\partial u^\alpha}$ component in
+(\ref{2.26}).\\
+
+The component of $\partial_{u_J^\alpha}$ in $\tilde S$ (\ref{2.26}) is
+obtained from
+
+\begin{displaymath}
+ \tilde S_{u_J^\alpha} = pr(V_Q)D^J(R_\alpha) - pr(V_R)D^JQ_\alpha
+\end{displaymath}
+and by Lemma 2.1
+\begin{displaymath}
+ \tilde S_{u_J^\alpha} = D^J\{pr(V_Q)R_\alpha - pr(V_R)Q_\alpha\} =
+D^J S_\alpha
+\end{displaymath}
+stating that $\tilde S$ is just the prolongation of $V_S$ (cf.\ref{2.8}).\\
+>From theorem 6 and the symmetry condition (3.5,6), we now have the
+following
+
+\begin{th}
+the evolutionary generalized symmetries of a system of differential
+equations
+\begin{displaymath}
+ \Delta_J[u]=0 \qquad (j=1,\ldots,\ell
+\end{displaymath}
+constitute a Lie algebra by the Lie bracket (\ref{2.26}).
+\end{th}
+
+\begin{ex} (Burgers' equations)
+We compute some Lie brackets of evolutionary symmetries of example
+3.4, (\ref{2.21a}),(\ref{2.21b}).\\
+Take
+\begin{eqnarray*}
+ &Z_1=F_6=t(u_3+3u_1u_2+u^3_1) + \frac{1}{2}
+ x(u_2+u^2_1)\\
+ &X_1=u_1\\
+ &X_2=u_2+u^2_1\\
+ &X_3=u_3+3u_1u_2+u^3_1
+\end{eqnarray*}
+We now have the following result
+\begin{eqnarray*}
+ \left[V_{Z_1},V_{X_1}\right] &=& \frac{1}{2}V_{X_2}\\
+ \left[V_{Z_1},V_{X_2}\right] &=& V_{X_3}\\
+ \left[V_{Z_1},V_{X_3}\right] &=& \frac{3}{2}V_{X_4}
+\end{eqnarray*}
+where $V_{X_4}$ is a fourth-order generalized symmetry and
+\begin{displaymath}
+ X_4=u_4+3u^2_2+4u_1u_3+6u^2_1u_2+u^4_1
+\end{displaymath}
+In effect the generalized symmetries of example 3.4
+(\ref{2.21a}),(\ref{2.21b}) constitute on {\em infinite dimensional
+Lie algebra}.
+\end{ex}
+
+\setcounter{equation}{0}
+\section{Nonlocal symmetries.}
+
+Here we shall discuss special types of nonlocal symmetries as they
+arise in certain special types of coverings. The notion of covering
+has been introduced in \cite{KV} and \cite{KV2} (also called
+Wahlquist-Estabrook prolongation) and has been discussed by
+P. Gragert in his lecture \cite {G}.\\
+For simplicity we restrict to two independent variables
+$(x,t)(p=2)$.\\
+
+In the discussion of coverings or prolongation one starts at the
+infinite prolongation $Y$ of a $k$-th-order system of partial
+differential equations, i.e. the original system together with all of
+its differential consequences, defined on the infinite jet bundle
+$J((x,t),u)$ i.e.
+
+\begin{equation}
+\label{3.1}
+ D^J(\Delta_j[u]) = 0 \qquad j=1,\ldots,\ell,|J|<\infty
+\end{equation}
+
+An $s$-dimensional covering of (\ref{3.1}), with $(y_1,\ldots,y_s)$ as
+local coordinates in the fibres, requires the existence of functions
+\begin{displaymath}
+ X_r([u],y_1,\ldots,y_s),T_r([u],y_1,\ldots,y_s) \qquad r=1,\ldots,s
+\end{displaymath}
+such that the extended or generalized total partial derivative
+operators
+
+\begin{eqnarray}
+\label{3.2}
+ \tilde D_x & = & D_x + X_r \frac{\partial}{\partial_{y_r}}\nonumber\\
+ & & \hspace{5cm} \mbox{(summation $r=1,\ldots,s$)}\\
+ \tilde D_t & = & D_t + T_r \frac{\partial}{\partial_{y_r}}\nonumber
+\end{eqnarray}
+commute, i.e.
+
+\begin{equation}
+\label{3.3}
+ [\tilde D_x,\tilde D_t] = 0
+\end{equation}
+which yields besides (\ref{3.1}) the covering condition
+
+\begin{equation}
+\label{3.4}
+ \tilde D_xT_r - \tilde D_tX_r = 0 \; \; \; \mbox{ on (\ref{3.1}) }
+\end{equation}
+i.e.
+
+\begin{equation}
+\label{3.4a}
+ D_xT - D_tX + [X,T] = 0
+\end{equation}
+where $X=(X_1,\ldots,X_s) T=(T_1,\ldots,T_s)$ and the bracket in
+(\ref{3.4a}) is taken with respect to the fibre coordinates
+$y=(y_1,\ldots,y_s)$.\\
+
+As a special case we now consider coverings (\ref{3.2}),(\ref{3.4})
+where $X_r,T_r$ are independent of $y=(y_1,\dots,y_s)$; (\ref{3.4})
+then reduces to
+
+\begin{equation}
+\label{3.5}
+ D_x(T_r) - D_t(X_r) = 0 \; \; \; \mbox{ on (\ref{3.1}) } (r=1,\ldots,s)
+\end{equation}
+i.e. $X_r,T_r$ determines a conservation law for (\ref{3.1})
+and $Y_r=D_x^{-1}(X_r)$, as formal integral.\\
+
+Analogously to (\ref{2.6}) we now introduce a {\em nonlocal} vertical
+(generalized) vector field
+
+\begin{equation}
+\label{3.6}
+ V_F = F_\alpha([u],y_1,\ldots,y_s) \frac{\partial}{\partial u_\alpha}
+\end{equation}
+and its prolongation to the infinite jetbundle
+
+\begin{equation}
+\label{3.7}
+ pr(V_F) = \tilde D^J(F_\alpha([u],y_1,\ldots,y_s))
+\frac{\partial}{\partial u_J^\alpha}
+\end{equation}
+
+We now define the notion of nonlocal symmetry.
+
+\begin{df}
+
+A nonlocal vector field $V_F$ (\ref{3.6}) determines a nonlocal
+symmetry of (\ref{3.1}) if and only if
+
+\begin{equation}
+\label{3.8}
+ pr(V_F)(\Delta_j) = 0 \; \; \; \mbox{ on (\ref{3.1}) },
+j=1,\ldots,\ell
+\end{equation}
+where $pr(V_F)$ is defined by (\ref{3.7}).\\
+
+{\bf Note:} The interested reader, comparing this definition with the
+one given in Vinogradov \& Krasilshchik's work \cite{KV2}, might notice a
+difference; in order to keep things simple and to outline the ideas we
+just use this simplified definition.\\
+
+We apply the notion of nonlocal symmetries to the construction of
+nonlocal symmetries of the famous Korteweg-de Vries equation
+(KdV-equation).
+\end{df}
+
+\begin{ex}
+We start at the infinite prolongation of the KdV-equation i.e.,
+
+\begin{equation}
+\label{3.9}
+ u_t = uu_1 + u_3 \qquad (u_1=u_x,u_3=u_{xxx})
+\end{equation}
+and its differential consequences.\\
+
+If we apply the technique of the preceding section and search for
+generalized symmetries of (\ref{3.9}) with characteristic
+$F=F(u,u_1,\ldots,u_5)$, we arrive at the existence of
+
+\begin{equation}
+\label{3.10}
+ \begin{array}{rclrcl}
+ F_1 &=& u_1 &F_4 &=& 2u+xu_1+3t(uu_1+u_3)\nonumber\\
+ F_2 &=& uu_1+u_3 &F_5 &=& 1+tu_1\\
+ F_3 &=& \frac{5}{6} u_1u^2+\frac{10}{3}u_1u_2+\frac{5}{3}uu_3+u_5\nonumber
+ \end{array}
+\end{equation}
+being the characteristics of $5$ generalized symmetries $V_{F_i} \;
+(i=1,\ldots,5)$.\\
+\end{ex}
+
+Note that (\ref{2.3}),(\ref{2.4})
+
+\begin{equation}
+\label{3.11}
+ \begin{array}{rcll}
+ V_{F_1} &\doteq& \frac{\partial}{\partial x} , \qquad V_{F_2}
+ \doteq \frac{\partial}{\partial t} &(x,t \mbox{-translation
+ )}\\
+ V_{F_3} &\doteq& -x \frac{\partial}{\partial x} - 3t
+ \frac{\partial}{\partial t} + 2u \frac{\partial}{\partial u}
+ &(\mbox{scale transformation )}\\
+ V_{F_4} &\doteq& t \frac{\partial}{\partial x} +
+ \frac{\partial}{\partial u} &(\mbox{Gallilean Boost)}
+\end{array}
+\end{equation}
+
+It is an easy observation that $X_1=u, \; \; T_1=\frac{1}{2}u^2+u_2$
+yield a conservation law for KdV-equation (\ref{3.9})
+
+\begin{equation}
+\label{3.12}
+ D_xT_1-D_tX_1=0 \qquad \mbox{on (\ref{3.9}) }
+\end{equation}
+
+We introduce the {\em 1-dimensional covering} of (\ref{3.9}) with
+$y=D_x^{-1}(u)$, and we are interested in the existence of a nonlocal
+symmetry of (\ref{3.9}) i.e. solution of (\ref{3.8}) where
+
+\begin{equation}
+\label{3.13}
+ H=H(x,t,u,\ldots,u_s,y)
+\end{equation}
+i.e.
+\begin{equation}
+\label{3.14}
+ \tilde D_tH - u_1H - u \tilde D_xH - \tilde D_x^3H = 0
+\end{equation}
+\begin{eqnarray*}
+ \tilde D_x &=& D_x + u\frac{\partial}{\partial y}\\
+ \tilde D_t &=& D_t + (\frac{1}{2}u^2+u_2)\frac{\partial}{\partial y}
+\end{eqnarray*}
+
+Using an integration package the solution can be constructed in a
+straightforward way, but since this would be very lengthy we proceed
+in a more convenient way.\\
+First of all, note that KdV-equation is graded due to the scale
+transformation (\ref{3.11}).\\
+i.e.
+\begin{displaymath}
+ [u]=2 \; ; \; [x]=-1 \; ; \; [t]=-3 \; ; \; [D_x]=1 \; ; \;
+ [D_t]=3
+\end{displaymath}
+which implies
+
+\begin{equation}
+\label{3.15}
+ [F_1]=3 \; ; \; [F_2]=5 \; ; \; [F_3]=7 \; ; \; [F_4]=2 \; ; \; [F_5]=0.
+\end{equation}
+
+We now search for a nonlocal symmetry whose characteristic is of
+degree 4 and which is of polynomial degree 1 in $x,t,y$.\\
+
+>From this we arrive at the Ansatz, based on the grading (\ref{3.15})
+
+\begin{equation}
+\label{3.16}
+ H=t(F_3) + \alpha xF_2 + \beta {\bf y}u_1 + \gamma u_2 + \delta u^2u_1
+\end{equation}
+where $F_2,F_3$ are defined by (\ref{3.10}) and
+$\alpha,\beta,\gamma,\delta$ constants to be determined. The symmetry
+condition, due to the fact that $F_3,F_2$ satisfy (\ref{3.14})
+themselves, reduces to
+
+\begin{equation}
+\label{3.17}
+ \begin{array}{ll}
+ &F_3 - \alpha uF_2 - 3\alpha D_x^2F_2 + \beta(\frac{1}{2}u^2+\beta
+ {\bf y}(u_1^2+uu_2+u_4)\\
+ &+ \gamma(3u_1u_2+uu_3+u_5) + 2\delta u(uu_1+u_3)-u_1(\beta
+ {\bf y}u_1+\gamma u_2+\delta u^2)\\
+ &-u(\beta uu_1+\beta {\bf y}u_2+\gamma u_3+2\delta uu_1)\\
+ &-[4\beta u_1u_2+3\beta uu_3+\beta {\bf y}u_4+\gamma u_5+2\delta
+ uu_3+6\delta u_1u_2] = 0
+ \end{array}
+\end{equation}
+
+This condition leads to the following conditions for
+$\alpha,\beta,\gamma,\delta$
+
+\begin{equation}
+\label{3.18}
+ \begin{array}{rcl}
+ u_5 &:& 1-3\alpha + \gamma-\gamma = 0\\
+ uu_3 &:&
+ \frac{5}{3}-\alpha-3\alpha+\gamma+2\delta-\gamma-3\beta-2\delta=0\\
+ u_1u_2 &:&
+ \frac{10}{3}-9\alpha+\beta+3\gamma-\gamma-4\beta-6\delta=0\\
+ u^2u_1 &:&
+ \frac{5}{6}-\alpha+\frac{1}{2}\beta+2\delta-\delta-\beta-2\delta=0
+ \end{array}
+\end{equation}
+or equivalently
+
+\begin{equation}
+\label{3.19}
+ \begin{array}{l}
+ 1-3\alpha=0\\
+ \frac{5}{3}-4\alpha-3\beta=0\\
+ \frac{10}{3}-9\alpha-3\beta+2\gamma-6\delta=0\\
+ \frac{5}{6}-\alpha-\frac{1}{2}\beta-\delta=0
+ \end{array}
+\end{equation}
+solving (\ref{3.19}) we arrive at
+\begin{displaymath}
+ \alpha=\frac{1}{3} \; ,\; \beta=\frac{1}{9} \; ,\; \gamma=\frac{4}{3}
+ \; ,\; \delta=\frac{4}{9}
+\end{displaymath}
+which leads to the characteristic ({\em nonlocal}) of a symmetry of
+KdV-equation
+
+\begin{equation}
+\label{3.20}
+ H=tF_3+\frac{1}{3}xF_2+\frac{1}{9}yu_1+\frac{4}{3}u_2+\frac{4}{9}u^2u_1
+\end{equation}
+
+\setcounter{equation}{0}
+\section{Recursion Operators and Nonlocal Symmetries.}
+
+In this section we indicate the importance of nonlocal symmetries in
+connection with the existence of recursion operators.\\
+For simplicity we restrict to the case of (\ref{3.9}) two independent and one
+dependent variable, keeping the KdV-equation as principal example in
+mind.\\
+
+Let us take a deeper look at the (generalized) symmetry condition
+(\ref{2.5}),(\ref{3.8}) i.e.
+
+\begin{equation}
+\label{4.1}
+ pr(V)(\Delta)=0 \mbox{ on } Y.
+\end{equation}
+
+If we use the prolongation formula (\ref{2.8}),(\ref{3.7}) it is a
+straightforward procedure to see that the symmetry condition can be
+rewritten as
+
+\begin{equation}
+\label{4.2}
+ \sum(\frac{\partial\Delta}{\partial u_J}) D^J(F)=0
+\end{equation}
+which is reflected in (\ref{2.13}),(\ref{3.14}).\\
+This observation urges us to introduce the socalled {\it linearization
+operator} \cite{KV}
+
+\begin{equation}
+\label{4.3}
+ \ell_\Delta = \sum(\frac{\partial\Delta}{\partial u_J}) D^J
+\end{equation}
+while (\ref{4.1}),(\ref{2.5}) can be written as
+
+\begin{equation}
+\label{4.4}
+ \ell_\Delta F=0
+\end{equation}
+
+Suppose there exists a differential or integro- differential operator
+$\cal R$, and associated to it some $\cal S$ such that the following relation
+for operators, $\cal R,\cal S,$ hold
+
+\begin{equation}
+\label{4.5}
+ \ell_\Delta {\cal R}={\cal S}\ell_\Delta
+\end{equation}
+
+Now assume that $F_0$ is a characteristic of a generalized symmetry of
+$\Delta$ i.e.
+
+\begin{equation}
+\label{4.6}\
+ \ell_\Delta F_0=0
+\end{equation}
+
+We then have
+
+\begin{equation}
+\label{4.7}
+ \ell_\Delta({\cal R}F_0) = {\cal S}(\ell_\Delta F_0)=0
+\end{equation}
+i.e. ${\cal R}(F_0)$ is a characteristic of a generalized symmetry.\\
+
+More generally, if an {\bf operator $\cal R$ satisfying (\ref{4.5})}
+for some $\cal S$ exists then starting from a {\bf characteristic
+$F_0$} of a symmetry we obtain a {\bf infinite hierarchy} (if not
+zero) of generalized symmetrics whose {\bf characteristics} are
+defined by
+
+\begin{equation}
+\label{4.8}
+ {\cal F}_n={\cal R}^n(F_0) \qquad n=0,\ldots
+\end{equation}
+Such an operator $\cal R$ is called a {\bf recursion operator} for
+generalized symmetries
+
+\begin{ex}
+The KdV-equation
+
+\begin{equation}
+\label{4.9}
+ \Delta(u)=u_t-uu_1-u_3=0
+\end{equation}
+admits a recursion operator for symmetries
+
+\begin{equation}
+\label{4.10}
+ {\cal R}=D_x^2 + \frac{2}{3}u + \frac{1}{3}u_1D_x^{-1}
+\end{equation}
+where $D^{-1}_x$ has to be understood as a formal integral [1].
+It is a somewhat tedious calculation to show that
+
+\begin{equation}
+\label{4.11}
+ \ell_\Delta {\cal R} = {\cal R}\ell_\Delta
+\end{equation}
+i.e. ${\cal S}={\cal R}$.\\
+
+If we start with $F_1=u_1$ then
+
+\begin{equation}
+\label{4.12}
+\begin{array}{rcccccl}
+ F_2 &=& {\cal R}F_1 &=& {\cal R}u_1 &=& uu_1 + u_3\\
+ F_3 &=& {\cal R}^2F_1 &=& {\cal R}F_2 &=&
+ \frac{5}{6}u_1u^2+\frac{10}{3}u_1u_2+\frac{5}{3}uu_3+u_5
+\end{array}
+\end{equation}
+and so on.
+\end{ex}
+
+We are now in a position underlign the importance of the notion of
+nonlocal symmetry.\\
+First of all, if we would apply the recursion formula (\ref{4.8})
+starting at $F_4$ or $F_5$ (in effect $F_4={\cal R}F_5$) then in order to
+compute ${\cal R}F_4$ we would have to allow nonlocal variables $y$ to come
+in.\\
+Moreover the nonlocal characteristic $H$ (\ref{3.20}) is just nothing
+else but
+
+\begin{equation}
+\label{4.13}
+ H=3{\cal R}F_4
+\end{equation}
+
+Secondly, if we compute the generalized Lie-Bracket for generalized
+vector field (\ref{2.28}) and compute Lie-Brackets with the non local
+vector field $V_H$ we arrive at
+
+\begin{equation}
+\label{4.14}
+ \begin{array}{rcl}
+ \left[V_H,V_{F_1}\right] &=& c_1F_2\\
+ \left[V_H,V_{F_2}\right] &=& c_2F_3
+ \end{array}
+\end{equation}
+$c_1,c_2$ being some nonzero constants.\\
+
+In effect the nonlocal generalized symmetry $V_H$ acts as {\bf
+recursion symmetry}.\\
+
+{\bf Final Remarks.}\\
+In this lecture I have tried to give you an introduction to and an
+impression of the beautiful world of symmetries of differential
+equations, where a lot of research is needed to explore the beautiful
+structures in this field of applied mathematics.\\
+
+For the interested reader I would recommend the book of Bluman-Kumei
+\cite{KB} as a starting point, the book by Olver as a rigorous and
+deep discussion of all the mathematics involved, and the work of my
+Russian friends Vinagradov, Krasil'shchik for the beautiful and rich
+geometrical structures underlying all the notions.
+
+\begin{thebibliography}{999}
+\bibitem{O} Olver P.J.A., Applications of Lie Groups to Differential
+Equations Graduatem Texts in Mathematics 107. Springer Verlag, New
+York-Berlin-Heidelberg (1986).
+\bibitem{V} Vinagradov A.M., Local symmetries and conversation laws.
+Acta Applicandae Mathematicae Vol 3 (1984), pp. 21-78.
+\bibitem{KV} Krasil'shchik I.S. \& Vinagradov A.M., Nonlocal
+symmetries and the theory of coverings. Acta Applicandae Mathematicae
+Vol 3 (1984), pp. 79-96.
+\bibitem{KV2} Krasil'shchik I.S. \& Vinagradov A.M., Nonlocal Trends
+in the Geometry of Differential Equations: Symmetries, Conservation
+Laws, and B\"{a}cklund Transformations Acta Applicandae Mathematicae
+Vol 15 (1989), pp. 161-209.
+\bibitem{K} Kersten P.H.M., Infinitesimal Symmetries: a Computational
+Approach C.W.I. Tract 34. Centre for Mathematics and Computer Science,
+Amsterdam (1987).
+\bibitem{G} Gragert P.K.H., Prolongation algebras of nonlinear PDE,
+These Notes.
+\bibitem{KB} Kumei S. \& Bluman G., Symmetries and Differential
+Equations. Applied Mathematical Sciences 81. Springer Verlag, New
+York-Berlin-Heidelberg (1989).
+\end{thebibliography}
+
+\end{document}
diff --git a/web/reduce/rweb/appl/tools.web b/web/reduce/rweb/appl/tools.web
new file mode 100644
index 0000000000..8429c276c1
--- /dev/null
+++ b/web/reduce/rweb/appl/tools.web
@@ -0,0 +1,1032 @@
+% Copyright (c) 1991 Marcel Roelofs, University of Twente, Enschede,
+% The Netherlands.
+%
+% $Header: tools.web,v 1.4 92/02/06 17:32:32 roelofs Exp $
+%
+\input specification
+\def\Version$#1Revision: #2 ${Version #2}
+\def\title{TOOLS}
+\font\titlefont=cmcsc10 scaled\magstep3
+\font\ttitlefont=cmtt10 scaled\magstep4
+\def\topofcontents{\null\vfill
+\centerline{\titlefont The {\ttitlefont TOOLS} package for REDUCE}
+\vskip15pt\centerline{\Version$Revision: 1.4 $}
+\vskip15pt\centerline{\sc Marcel Roelofs}\vfill}
+
+@* Introduction. In this \.{RWEB} file we will describe some tools
+which facilitate working with algebraic operators and can be seen as
+rather general extensions to REDUCE. At the moment these tools
+are:\medskip
+
+\item{1.}Procedures to find one or all kernels of some specified
+algebraic operators in a standard form.
+
+\item{2.}The procedure |operator_coeff|, which is the analogue of the
+standard REDUCE procedure |coeff| for kernels of operators. The
+procedure |operator_coeff| is intended for expressions which are
+linear with respect to kernels of some specified algebraic operators
+and returns a list of these kernels, together with their coefficients.
+Related to this procedure is the procedure |independent_part| which
+extracts the part of an expression, not being a polynomial expression
+in kernels of some operators.
+
+\item{3.} The procedure |multi_coeff|, for finding the coefficients of
+the basis elements of a polynomial ring in an arbitrary number of
+variables.
+
+\item{4.} The procedure |simp_multilinear| to simplify a multilinear
+operator.
+
+\item{5.}The procedure |linear_solve| to solve linear expressions
+with respect to some specified kernel.
+
+\item{6.}The procedure |solvable_kernels| which analyses if an
+algebraic expression is linear with respect to kernels of some
+specified operators and returns all those kernels for which the
+coefficients do not depend on other operators. \medskip
+
+The ``banner line'' defined here is intended for indentification
+purposes on loading. It should be changed whenever this file is
+modified. System dependent changes, however, should be made in a
+separate change file.
+
+@d banner="Algebraic operator tools for REDUCE 3.4, $Revision: 1.4 $"
+
+@ We define the following macros for clarity. The reading of the file
+is done in symbolic mode.
+@d change_to_symbolic_mode =symbolic@;
+@d change_to_algebraic_mode =algebraic@;
+@d stop_with_error(string_1,expr_1,string_2,expr_2) = @/
+ msgpri(string_1,expr_1,string_2,expr_2,t) @;
+@d message(string_1,expr_1,string_2,expr_2) = @/
+ msgpri(string_1,expr_1,string_2,expr_2,nil) @;
+
+@u change_to_symbolic_mode$@/
+write banner$ terpri()$@/
+change_to_algebraic_mode$
+
+@ The following macros are intended as common programming idioms.
+@d incr(x) = (x:=x+1)@;
+@d decr(x) = (x:=x-1)@;
+
+@* Finding kernels of operators in standard forms. If one wants
+perform a lot of automated computations on algebraic expressions
+containing algebraic operators, it is very convenient to have a
+procedure that extracts one or more kernels of some specified
+operator(s) from these algebraic expressions automatically. For this
+purpose we will write the procedures |get_first_kernel|,
+|get_all_kernels| and |get_recursive_kernels| which extract one or all
+kernels from standard forms. We have chosen to let the procedures act
+on standard forms, because algebraic expressions are recursively built
+up out of standard forms. Therefore, in doing so, the searching can
+be done in an easy to understand recursive manner.
+
+A kernel of an operator looks like |a(1,2)| or |a()|, in general an
+algebraic operator together with its arguments. In lisp mode these
+kernels look like lists, the |car| of which is an algebraic
+operator, the |cdr| being its arguments.
+
+
+@ \specs |@!get_first_kernel|, |@!get_all_kernels| and |@!get_recursive_kernels|.
+\descr Syntax: \descno 1.|get_first_kernel(form,oplist)|,\nl
+ \descno 2.|get_all_kernels(form,oplist)|,\nl
+ \descno 3.|get_recursive_kernels(form,oplist)|.
+\descr Arguments:
+ \arg |form|: standard form.
+ \arg |oplist|: identifier or (algebraic or lisp) list of identifiers,
+ which should be algebraic operator(s).
+\descr Result: \descno 1.
+ the first kernel of operator(s) on
+ |oplist| occuring in |form| at top level,
+ i.e.\ not occuring as argument of another
+ operator.\nl
+ \descno 2.a (lisp) list of all kernels of
+ operator(s) on |oplist| occuring in |form| at
+ top level.\nl
+ \descno 3.a (lisp) list of all kernels of
+ operator(s) on |oplist| ocurring in
+ |form| at any level.
+
+@ The actual work of the procedures described above is done by
+recursive procedures one level below, which examines the main variable
+for the desired kernels and recursively examines the leading
+coefficient and the reductum (which are also standard forms). These
+recursive procedures have three arguments, the standard form involved,
+the list of operators and a list of kernels found so far
+(initially |nil|).
+
+The following macro definition makes sure that the second argument
+becomes a lisp list of identifiers.
+@d make_oplist(op_list)=@/if null op_list then op_list else if atom
+op_list then list op_list else if
+car op_list='list then cdr op_list else op_list @;
+
+@ The first procedure we want to discuss is
+|get_first_kernel(form,oplist)|. It returns the first occurence of a
+kernel of the specified operators occuring at top level. We can stop
+examining the standard form if we encounter a domain element.
+
+@u lisp procedure get_first_kernel(form,oplist);
+gfk(form,make_oplist(oplist),nil)$@#
+
+lisp procedure gfk(form,oplist,l);
+ if l or domainp form then l
+ else gfk(red form,oplist,
+ gfk(lc form,oplist,
+ if not atom x and member(car x,oplist)
+ then x @+else l))
+ where x=mvar form$
+
+@ The procedure |get_all_kernels(form,oplist)| returns a list of all kernels
+of the specified operators occuring in |form| at top level. In |gak|
+we use |aconc| instead of |cons| to add new kernels to |l|. We do
+this because most times we want to actually use the list obtained to
+reorder the standard form and in this way the reordering can be minimized.
+
+@u
+lisp procedure get_all_kernels(form,oplist);
+gak(form,make_oplist(oplist),nil)$@#
+
+lisp procedure gak(form,oplist,l);
+ if domainp form
+ then l
+ else gak(red form,oplist,
+ gak(lc form,oplist,
+ if not atom x and member(car x,oplist) and not member(x,l)
+ then l:=aconc(l,x) @+else l))@|
+ where x=mvar form$
+
+@ The procedure |get_recursive_kernels(form,oplist)| returns a list of all
+kernels of the specified operators occuring at any level in |form|
+(i.e. as main variables, arguments, arguments of arguments, etc).
+
+@u
+lisp procedure get_recursive_kernels(form,oplist);
+grk(form,make_oplist(oplist),nil)$@#
+
+lisp procedure grk(form,oplist,l);
+ if domainp form
+ then l @+else grk(red form,oplist,
+ grk(lc form,oplist,@|
+ @<Add all kernels occuring in |x| at any level@>))
+ where x=mvar form$
+
+@ We don't want to use the list obtained by |grk|
+for reordering, so here new operator elements are simply added to |l| by
+|cons|.
+@<Add all kernels...@>=
+ if not atom x
+ then begin scalar y;
+ for each arg in cdr x do
+ if (y:=simp arg) neq 0 then
+ l:=grk(numr y,oplist,l);
+ return if member(car x,oplist) and not member(x,l)
+ then x . l @+else l end
+ else l@;
+
+@* Finding coefficients of operator expressions. In REDUCE there is
+an easy way to get all coefficients of an algebraic expression
+regarded as polynomial expression w.r.t.\ some kernel, namely the
+procedure |coeff|. However, there is no mechanism available to get
+all coefficients of an algebraic expression regarded as a linear
+expression w.r.t.\ kernels of some specified operators, whereas such a
+mechanism is very often needed if one wants to do automated
+computations on expressions containing algebraic operators.
+
+Therefore, in this section we will write the analogue of the procedure
+|coeff| for kernels of some specified operators, the procedure
+|operator_coeff|.
+
+@
+\spec |@!operator_coeff|.
+ \descr Syntax:|operator_coeff(exprn,oplist)|.
+ \descr Arguments:
+ \arg |exprn|: algebraic expression.
+ \arg |oplist|: identifier or (algebraic or lisp) list of identifiers,
+ which should be algebraic operator(s).
+ \descr Result: returns an algebraic list, the first element of which
+ is the part of |exprn| being independent of
+ operator(s) on |oplist|, followed by zero or more
+ algebraic lists consisting of kernels of operators on
+ |oplist| and their coefficients in |exprn|. Here we
+ regard |exprn| to be a linear expression with respect
+ to all kernels of operator(s) on |oplist|. Before
+ the analysis, |exprn| is simplified.
+ \descr Errors: stops with an error message if |exprn| is not linear with
+ respect to all kernels of operator(s) on |oplist|.
+ \descr Examples: the call |operator_coeff(2*x(1)+3*y(2)+5*z(3),{x,y})| returns
+ the list \30|{5*z(3),{x(1),2},@/{y(2),3}}|, whereas
+ |operator_coeff(x(1)*x(2),x)| stops with an error message.
+
+@ Keeping in mind the procedure |get_all_kernels| we have written
+above, it is not difficult to think of how the procedure
+|operator_coeff| could act: first get a list of all desired kernels
+with help of |get_all_kernels| and reorder the numerator of |exprn|
+w.r.t.\ this list. Once one has done so, one is sure that, in case of
+linearity, all desired kernels occur as a main variable in a reduced
+part of the numerator and it's a piece of cake to check the linearity
+and to construct the desired list. In fact this is the way the first
+version of |operator_coeff| worked.
+Unfortunately it is not the most efficient way to obtain the
+desired result, since the numerator of |exprn| is scanned twice,
+namely in the procedures |get_all_kernels| and |reorder|.
+
+In the current version we will scan the expression $E$ only
+once and at the same time construct a list $L$, which contains the
+part of $E$ independent of operators on |oplist| together with all
+kernels of operators on |oplist| and their coefficients and which is
+almost ready for returning.
+
+As in the first version scanning is performed on standard forms. The
+actual version is based on the following fact: a standard form consist
+of a number of standard terms $T_i$, each of which is the product of a
+leading power $P_i$ and its coefficient $C_i$ which again is a
+standard form. In the sequel we will assume that the switch |exp| is
+|on|; this a legal assumption because otherwise |coeff|'ing and also
+|operator_coeff|'ing would become rather useless. We can now find all
+the kernels of operators on |oplist| and their coefficients in a
+standard term $T_i$ if we distinguish between the following
+situations:\medskip
+
+\item{1.} $T_i$ is |nil|. We have to take no action.
+\item{2.} $T_i$ is a domain element. In particular it is not a kernel
+of one of the operators on |oplist|, hence we can add up $T_i$ to the
+independent part of $L$.
+
+\item{3.} The main variable of $P_i$ is a kernel of one of the
+operators on |oplist| (the fact that |exp| is |on| assures us that
+the main variable is a kernel). If the leading degree is 1 and $C_i$
+does not contain kernels of operators on |oplist|, we can update $L$,
+otherwise we have to stop with an error message because the expression
+is not linear w.r.t. the operators on |oplist|.
+
+\item{4.} The main variable of $P_i$ is not a kernel of one of the
+operators on |oplist|. We can recursively examine $C_i$ for the
+occurence of appropriate kernels, if we keep in mind that the
+coefficients of kernels found there have to be multiplied with the
+additional factor $P_i$. \medskip
+
+@ The actions described above are implemented in the procedure
+|split_f|, which examines the leading term and recursively the
+reductum. The third argument |fact| is the standard form
+representing the product of all previous factors, by which the
+coefficients of kernels found in |form| have to be multiplied. Hence at
+top level it has to be initialized to 1. |kc_list| is a
+dotted pair the |car| of which is the part of the expression
+independent of operators on |oplist|, the |cdr| an association list of
+kernels and (standard form) coefficients. At top level it has to be
+initialized to |nil . nil|.
+
+@u
+lisp procedure split_f(form,oplist,fact,kc_list);
+if null form then kc_list
+else if domainp form then
+ addf(multf(fact,form),
+ car kc_list) . cdr kc_list
+else if not atom mvar form and member(car mvar form,oplist) then
+if not ldeg form = 1 or get_first_kernel(lc form,oplist) then
+stop_with_error("SPLIT_F: expression not linear w.r.t.",
+ 'list . oplist,nil,nil)
+else split_f(red form,oplist,fact,
+ update_kc_list(kc_list,mvar form,multf(fact,lc form)))
+else split_f(red form,oplist,fact,
+ split_f(lc form,oplist,
+ multf(fact,!*p2f lpow form),kc_list))$
+
+@ For convenience we will write a surrounding procedure
+|split_form|, which can be called at top level and initializes the
+third and fourth argument of |split_f|
+
+@u
+lisp procedure split_form(form,oplist);
+split_f(form,oplist,1,nil . nil)$
+
+@ For updating the |kc_list| as efficient as possible we
+need an |assoc|-like procedure |list_assoc|. If applied to an
+association list $L$, this procedure returns the remainder of $L$, the
+|car| of which would be the result of |assoc| applied to $L$.
+
+@u lisp procedure list_assoc(car_exprn,a_list);
+if null a_list then a_list else if caar a_list= car_exprn then a_list
+else list_assoc(car_exprn,cdr a_list)$
+
+@ In order to update the |kc_list| we first have to find out
+if the kernel w.r.t.\ which we update the list, is already occuring on
+it. If so, we have to adjust its coefficient, otherwise we can |cons|
+the kernel and coefficient in front of the list. Adjusting a
+coefficient is performed by using the procedures |list_assoc| and
+|rplaca| in order to avoid rebuilding of the entire list. The reader
+should verify that |rplaca| does not do any harm in this application,
+since it is replacing a list.
+
+@u lisp procedure update_kc_list(kc_list,kernel,coefficient);
+(if rest_list then @+<<rplaca(rest_list,caar rest_list . addf(cdar
+rest_list,coefficient)); kc_list>> else
+car kc_list . (kernel . coefficient) . cdr kc_list)
+where rest_list=list_assoc(kernel,cdr kc_list)$
+
+@ The procedure |operator_coeff| should be available in algebraic mode.
+We will, however, not make it an ordinary lisp operator, since this
+leads to unnecessary simplifications of the arguments and the result
+of |operator_coeff| (this is done in the standard REDUCE procedure
+|reval1|). Instead we will give |operator_coeff| the property |psopfn|
+with value |operator_coeff_1|. By this declaration the arguments of
+|operator_coeff| are passed to the procedure |operator_coeff_1| as one
+unevaluated list and the result is returned without further
+simplification.
+
+The procedure |operator_coeff_1| only checks for the right number of
+arguments, and passes them as genuine arguments to the lisp procedure
+|operator_coeff|. This means that we have access to |operator_coeff|
+in both algebraic and symbolic mode with the same appearance. In
+algebraic mode, however, the lisp procedure |operator_coeff| is not
+directly accessible (since it is not an lisp operator) but only via
+the construction described above. In symbolic mode |operator_coeff| is
+called directly.
+
+@u
+put('operator_coeff,'psopfn,'operator_coeff_1)$
+@#
+lisp procedure operator_coeff_1 u;
+if length u neq 2 then rederr("OPERATOR_COEFF: wrong number of arguments")
+else operator_coeff(car u,reval cadr u)$
+
+@ The real work is done by the procedure |operator_coeff|, which
+is quite simple: simplify the expression |exprn|, get its numerator,
+and finally apply |split_form| to it. After that we have to divide all
+coefficients by the denominator of |exprn| and convert the list
+returned by |split_form| into a list of algebraic lists.
+
+To simplify |exprn| we use |simp!*| instead of |simp| because |exprn|
+may sometimes be an expression which hasn't been simplified before
+(like an argument of some other simplification procedure), so we want
+a full simplification of |exprn| including a call of |subs2|, which is
+done by |simp!*|.
+
+In order to admit the second argument of |operator_coeff| to be a
+single operator as well as a list of operators we use the macro
+|make_oplist| described above.
+
+@u
+lisp procedure operator_coeff(exprn,oplist);
+begin scalar numr_ex,denr_ex,kc_list;
+ oplist:=make_oplist(oplist);
+ exprn:=simp!* exprn;numr_ex:=numr exprn;denr_ex:=denr exprn;
+ kc_list:=split_form(numr_ex,oplist);
+ return 'list . !*ff2a(car kc_list,denr_ex) .
+ for each kc_pair in cdr kc_list collect@|
+ list('list,car kc_pair,!*ff2a(cdr kc_pair,denr_ex));
+end$
+
+@ Sometimes we are only interested in the part of an expression
+independent of some operators instead of in the whole kernel
+coefficient list. Of course one can apply |operator_coeff| to the
+expression and get the independent part of it, but in time critical
+applications it is better to have a procedure |dump_operators| that
+only performs the essential actions of the procedure |split_f|,
+together with surrounding procedures |independent_part| and
+|independent_part_1|.
+
+The basic ideas to get the independent part of an expression during
+the scan of a standard form are exactly those underlying the procedure
+|split_f|, except that updating the kernel coefficient list is
+replaced by doing nothing. Notice that we have skipped the checks for
+linearity, hence |independent_part| is even more general than
+|operator_coeff| in the sense that we can also get the independent
+part of an expression which is not linear w.r.t.\ all kernels of the
+specified operator(s).
+
+However, we can get rid of the last argument |kc_list| of |split_f|,
+since we can simply add up all independent parts using |addf|.
+
+@u
+lisp procedure dump_operators(form,oplist,fact);
+if null form then nil
+else if domainp form then multf(fact,form)
+else if not atom mvar form and member(car mvar form,oplist) then @|
+ dump_operators(red form,oplist,fact)
+else
+ addf(dump_operators(red form,oplist,fact),@|
+ dump_operators(lc form,oplist,multf(fact,!*p2f lpow form)))$
+
+@ We copy the surrounding procedures without further comment.
+@u
+put('independent_part,'psopfn,'independent_part_1)$
+@#
+lisp procedure independent_part_1 u;
+if length u neq 2 then rederr("INDEPENDENT_PART: wrong number of arguments")
+else independent_part(car u,reval cadr u)$
+@#
+lisp procedure independent_part(exprn,oplist);
+begin scalar numr_ex,denr_ex;
+ oplist:=make_oplist(oplist);
+ exprn:=simp!* exprn;@/numr_ex:=numr exprn;denr_ex:=denr exprn;
+ return !*ff2a(dump_operators(numr_ex,oplist,1),denr_ex);
+end$
+
+@ The successful implementation of |operator_coeff| inspires us to
+also introduce a more general version of |coeff|, namely a procedure
+for finding the coefficients of basis elements of polynomial rings in
+an arbitrary number of variables. Given a list |kernel_list| of
+generators of such a ring, we can find all all basis elements and
+their coefficients together with the independent part of a standard
+form $F$ by analysing each standard term $T_i$ in $F$ in the following
+way, where $P_i$ and $C_i$ have the same meaning as in the
+introduction to the procedure |split_f|:\medskip
+
+\item{1.} $T_i$ is |nil|. We have to take no action.
+
+\item{2.} $T_i$ is a domain element. In particular does not contain a
+kernel of one of the generators on |kernel_list|, hence we can add up
+$T_i$ to the independent part of $L$.
+
+\item{3.} The main variable of $P_i$ is a kernel occuring in
+|kernel_list| (again the fact that |exp| is |on| assures us that the
+main variable is a kernel). Hence $T_i$ will give rise to at least one
+basis element. At the time being we cannot, however, be sure about the
+final form of the basis element, since $C_i$ may contain additional
+factors. Therefore we will add $P_i$ to the variable |multi_power|
+which is the list of powers found so far. Here we explicitly use the
+fact that the ordering of standard forms assures us that the powers of
+basis elements found twice in $F$ will be stored on |multi_power| in
+exactly the same order.
+
+\item{4.} The main variable of $P_i$ is not a kernel occuring in
+|kernel_list|. We can recursively examine $C_i$ for the occurence of
+appropriate kernels, if we keep in mind that the coefficients of
+kernels found there have to be multiplied with the additional factor
+$P_i$. \medskip
+
+The analysis described above is implement in the procedure
+|multi_split_f|.
+
+@d update_pc_list=update_kc_list
+@u
+lisp procedure multi_split_f(form,kernel_list,multi_power,fact,pc_list);
+if null form then pc_list
+else if domainp form then
+ if multi_power then update_pc_list(pc_list,multi_power,multf(fact,form))
+ else addf(multf(fact,form),car pc_list) . cdr pc_list
+else multi_split_f(red form,kernel_list,multi_power,fact,
+ if member(mvar form,kernel_list) then @|
+ multi_split_f(lc form,kernel_list,lpow form . multi_power,fact,pc_list)
+ else multi_split_f(lc form,kernel_list,multi_power,
+ multf(fact,!*p2f lpow form),pc_list))$
+
+
+@ As usual |multi_power|, |fact| and |pc_list| have to initialized to
+1 and |nil . nil|, respectively, at top level. Again we have a
+surrounding procedure |multi_split_form| to take care of this.
+
+@u
+lisp procedure multi_split_form(form,kernel_list);
+multi_split_f(form,kernel_list,nil,1,nil . nil)$
+
+@ At algebraic level we want to have a procedure
+|multi_coeff(exprn,kernel_list)| to our disposal, with |exprn| the
+multivariate expression to be analysed and |kernel_list| the list
+generators of the polynomial ring. The result of |multi_coeff| is a
+list, the first part of which is the independent part, followed by
+zero or more pairs of basis elements with their coefficients. Notice
+that unlike |coeff| returns its result in a sparse way.
+
+In order to avoid unnecessary simplification we will again use the
+|psopfn| mechanism to make |multi_coeff| available in algebraic mode.
+
+@u
+put('multi_coeff,'psopfn,'multi_coeff_1)$
+@#
+lisp procedure multi_coeff_1 u;
+if length u neq 2 then rederr("MULTI_COEFF: wrong number of arguments")
+else multi_coeff(car u,reval cadr u)$
+
+@ There is no use of analysing the numerator of |exprn| if it is
+not polynomial in the variables in |kernel_list|. Therefore we have to
+check that the denominator of |exprn| does not depend on any of the
+variables in |kernel_list|, before applying |multi_split_form| to the
+numerator of |exprn|.
+
+@u lisp procedure multi_coeff(exprn,kernel_list);
+begin scalar numr_ex,denr_ex,pc_list;
+ kernel_list:=make_oplist(kernel_list);
+ exprn:=simp!* exprn;@/
+ numr_ex:=numr exprn;denr_ex:=denr exprn;
+ for each generator in kernel_list do if depends(denr_ex,generator)
+ then stop_with_error(@|"MULTI_COEFF: expression is not polynomial w.r.t. ",
+ 'list . kernel_list,nil,nil);
+ pc_list:=multi_split_form(numr_ex,kernel_list);
+ return 'list . !*ff2a(car pc_list,denr_ex) .
+ for each pc_pair in cdr pc_list collect@|
+ list('list,convert_multi_power car pc_pair,!*ff2a(cdr pc_pair,denr_ex));
+end$
+
+@ A |multi_power| returned by |multi_split_f| is a list of standard
+powers, i.e. dotted pairs, the |car| of which are leading variables, the
+|cdr| leading degrees. For use in algebraic expression we have to
+convert it to the proper product of powers. Of course if the leading
+degree is 1, we can omit it from the result.
+
+@u
+lisp procedure convert_multi_power multi_power;
+'times . for each power in multi_power collect
+if cdr power=1 then car power else list('expt,car power,cdr power)$
+
+@* Simplifying multilinear operators. In REDUCE there is a rather
+elementary construct for dealing with operators that are linear in one
+argument. Using the procedures written above it is not very hard to
+deal with multilinear operators, if we take the notion of linearity as
+introduced above. Therefore we will introduce multilinear operators
+as a new type of operators in REDUCE by implementing a new
+simplification procedure |simp_multilinear| for multilinear operators
+and at the same time implement a |multilinear| statement to set up an
+environment for multilinear operators.
+
+Before we continue, let us give a more detailed description of what we
+understand by multilinearity exactly. If $P$ is multilinear operator
+w.r.t.\ operators $P_1,\dots,P_n$ and the result of |operator_coeff|
+applied to an expression $a_k$ w.r.t.\ the operators $P_1,\dots,P_n$
+is $$ a_k=f_{k,0}+\sum_{i_k=1}^{N_k} f_{k,i_k}p_{k,i_k}=
+\sum_{i_k=0}^{N_k} f_{k,i_k}p_{k,i_k}\qquad\hbox{with $p_{k,0}=1$}$$
+where $f_{k,0}$ is the part of $a_k$ independent of one of the
+operators $P_1,\dots,P_n$ and $p_{k,i_k}$ are operator elements of one
+of the operators $P_1,\dots,P_n$, then $P(a_1,\dots,a_m)$ must be
+simplified to
+$$P(a_1,\dots,a_m)=\sum_{i_1=0}^{N_1}\cdots\sum_{i_m=0}^{N_m}
+f_{1,i_1}\cdots f_{m,i_m} P(p_{1,i_1},\dots,p_{m,i_m})$$ To give an
+example, suppose that \\{wedge} is an operator representing the
+exterior multiplication of differential geometry and suppose that we
+have declared \\{wedge} to be multilinear w.r.t.\ to \\{wedge} and $d$,
+then $\\{wedge}(x+f(1)+d(1),wedge(d(1),d(2)))$ will be simplified to
+$(x+f(1))*\\{wedge}(1,wedge(d(1),d(2)))+\\{wedge}(d(1),\\{wedge}(d(1),d(2)))$
+where the components have to be simplified separately to take account
+for any other properties of exterior multiplication.
+
+@ The first step of simplifying a multilinear operator is splitting up
+its arguments. We can do this by applying |split_form| to the
+numerators of all arguments and at the same time keep track of the
+product of the denominators of all arguments, since the final result
+of the simplification has to be divided by this product.
+
+The actions necessary for splitting the arguments and keeping track of
+the denominators are implemented in the procedure |split_arguments|.
+The result (and third argument) |splitted_list| of |split_arguments|
+is a dotted pair, the |car| of which is the product of all
+denominators as a standard form, the |cdr| being the list of results
+of |split_form| applied to the numerator of all arguments in reverse
+order. |split_arguments| applied to a list of arguments |arg_list|,
+processes the first argument by updating the product of denominators
+and |cons|'ing the result of |split_form| applied to the numerator of it
+in front of the list of splitted arguments, and recursively splits the
+rest of the arguments. Hence at top level |splitted_list| has to be
+initialized to |1 . nil|.
+
+The procedure |split_arguments| is normally called from within a
+simplification procedure. This means that the arguments have not been
+simplified before. Therefore we must enforce full simplication of
+these arguments by applying |simp!*| to them before processing.
+
+@u
+lisp procedure split_arguments(arg_list,oplist,splitted_list);
+if null arg_list then splitted_list
+else split_arguments(cdr arg_list,oplist,
+ multf(denr first_arg,car splitted_list) . @|
+ split_form(numr first_arg,oplist) .
+ cdr splitted_list) @|where first_arg=simp!* car arg_list$
+
+@ For convenience we will write a surrounding procedure
+|split_operator|, in order to hide the last two arguments of
+|split_arguments|. Its only argument is an operator element, the
+arguments of which are to be splitted. For its proper operation it
+assumes that the multilinear operator under consideration has the
+property |oplist|, which is the list of operators w.r.t.\ which the
+operator is multilinear.
+
+@u lisp procedure split_operator u;@/
+split_arguments(cdr u,get(car u,'oplist),1 . nil)$
+
+@ Once we have a list of splitted arguments we can build up the sum of
+operator elements of all possible combinations of components of the
+(splitted) arguments. Since the list of splitted arguments is stored
+in reverse order, this can be done most conveniently by recursive
+procedures. If we consider one (splitted) argument of the operator
+under consideration as a list of components, and the whole argument
+list of the operator as a stack of component lists, we can build up
+the sum by applying two recursive procedures |process_arg_stack|,
+|process_comp_list| to the argument stack and component list(s)
+respectively.
+
+The procedure |process_arg_stack| and |process_comp_list| work as follows.
+The procedure |process_arg_stack| applies the procedure
+|process_comp_list| to the first component list of the argument stack
+it has been offered.
+
+The procedure |process_comp_list| applies the procedure
+|process_independent_part| to the independent part of the component
+list and adds it to the result of applying |process_components| to the
+other components.
+
+The procedure |process_components| takes the first component of the
+component list it has been offered and |cons|'es the kernel part of
+this component in front of the argument list of the elementary
+operator element being built up and updates the factor with which this
+elementary operator element has to be multiplied at the end by
+multiplying it with the coefficient part of the component being
+processed. Now, if the remaining part of the argument stack is
+empty the argument list of the elementary operator element is ready
+and we can simplify it, multiply it with the product of the
+coefficients and add it to the result (in fact this is done in the
+procedure |process_arg_stack|). Otherwise we must continue to build an
+argument list of an elementary operator element by applying
+|process_arg_stack| to the remaining part of the argument stack.
+Finally |process_components| has to be applied on the remaining part of
+the component list being processed. The procedure
+|process_independent_part| takes the similar actions appropriate for
+the independent part of a component list.
+
+Throughout the calls of all procedures explained above we need to
+know what is the current argument list and the current factor being
+built up. We therefore pass them to all procedures as the arguments
+|arg_list| and |fact|, which is the factor being build up as a
+standard form. Hence it is clear that the argument list and the factor
+have to be initialized to |nil| and 1, respectively.
+
+@ We mentioned that the elementary operator elements have to be
+simplified before they can be added. It would, however, be unwise
+simply to apply |simp| since the operator under consideration will
+have the procedure |simp_multilinear| as its simplification
+function\dots, leading to an infinite loop. For ordinary cases
+applying |simpiden| will be sufficient, but since we wish to take
+account for use of multilinear operators in special packages, we will
+add to each multilinear operator a property |resimp_fn|, which is the
+simplification function to be applied to an elementary operator
+element.
+
+With this knowledge we can implement the procedure |process_arg_stack|
+right away. Note that |fact| has to be converted into a standard
+quotient before multiplying the (simplified) operator kernel with it.
+This is done with help of the procedure |!*f2q|.
+
+@u lisp procedure process_arg_stack(arg_stack,op_name,arg_list,fact);
+if null arg_stack then multsq(!*f2q fact,
+ apply1(get(op_name,'resimp_fn),op_name . arg_list))
+else process_comp_list(car arg_stack,cdr arg_stack,op_name,arg_list,fact)$
+
+@ The procedure |process_comp_list| consists of adding the results of
+applying |process_independent_part| and |process_components| to the
+current component list.
+
+@u
+lisp procedure process_comp_list(comp_list,arg_stack,op_name,arg_list,fact);
+addsq(process_independent_part(car comp_list,arg_stack,op_name,arg_list,fact),
+ process_components(cdr comp_list,arg_stack,op_name,arg_list,fact))$
+
+@ Following our description of multilinearity, processing the
+independent part of an argument boils down to multiplying |fact|
+with it and adding the argument 1 to |arg_list|. If, however, the
+independent part is |nil|, i.e.\ the operator element being built up
+will contain a zero argument, thanks to multilinearity this operator
+element will not contribute to the result and we can return |result|
+immediately.
+
+@u lisp procedure process_independent_part(independent_part,arg_stack,
+ op_name,arg_list,fact);
+if null independent_part then nil . 1
+else
+ process_arg_stack(arg_stack,op_name,1 . arg_list,@|multf(fact,independent_part))$
+
+
+@ The procedure |process_components| has to process the |comp_list|
+until there are no more components of the argument being processed.
+
+@u lisp procedure process_components(comp_list,arg_stack,op_name,arg_list,fact);
+if null comp_list then nil . 1
+else
+ addsq(process_components(cdr comp_list,arg_stack,op_name,arg_list,fact),
+ process_arg_stack(arg_stack,op_name,caar comp_list . arg_list,
+ multf(fact,cdar comp_list)))$
+
+@ To hide the rather illogical arguments of |process_arg_stack| we will
+write a surrounding procedure |build_sum| for it. Recall that
+|arg_list| and |fact| have to be initialized to |nil| and 1,
+respectively.
+
+@u lisp procedure build_sum(op_name,arg_stack);@/
+process_arg_stack(arg_stack,op_name,nil,1)$
+
+@ With the procedures written above, the simplification function
+|simp_multilinear| can be written at once. We recall that the result
+of |split_arguments| is a dotted pair, the |car| of which is the
+product of the denominators of all arguments, the |cdr| the list of
+splitted arguments, a argument stack.
+
+For simplifying a multilinear operator it is clear that we need to
+know the operator name, in other words the |car| of the argument
+offered to |simp_multilinear| must be the operator name. To achieve
+this we must flag the operator under consideration |full|.
+
+@u lisp procedure simp_multilinear u;
+quotsq(build_sum(car u,cdr splitted_list),!*f2q car splitted_list) @|
+where splitted_list=split_operator u$
+
+@ The last step towards a successful introduction of multilinear
+operators in REDUCE, is the implementation of a procedure
+|multilinear| to set up the right environment for multilinear
+operators. It is our purpose to give meaning to the declaration
+$$\hbox{\\{multilinear} $P$(operator${}\mid{}$list of operators
+[,resimplification function]);}$$ as to declare $P$ a multilinear
+operator w.r.t.\ the operator(s) of the first argument and, if
+present, with the second argument as it's |resimp_fn|, otherwise
+|simpiden| if $P$ doesn't already possess a simpliciation or
+resimplification function.
+
+@ If we give |multilinear| the property |stat| with value |rlis| in
+order to allow for more multilinear declarations at a time, the
+declaration \\{multilinear} $P_1(\dots),\dots,P_n(\dots)$ will lead to
+the call $\\{multilinear} ((P_1\ \dots)\ {\dots}\allowbreak (P_n\ \dots))$. With
+this knowledge the source of |multilinear| is rather straightforward.
+Notice that since |stat=rlis| the procedure |multilinear| need not be
+a lisp operator.
+
+@u
+put('multilinear,'stat,'rlis)$@#
+
+lisp procedure multilinear u;
+for each decl in u do
+begin scalar op_name,resimp_fn;
+ if length decl neq 2 and length decl neq 3 then@|
+ stop_with_error(nil,decl,"invalid multilinear declaration",nil);
+ if not idp(op_name:=car decl) then
+ stop_with_error(nil,op_name,"invalid as operator",nil);
+ put(op_name,'oplist,make_oplist(cadr decl));
+ if (length decl=3 and (resimp_fn:=caddr decl)) or
+ (resimp_fn:=get(op_name,'resimp_fn)) or@|
+ (resimp_fn:=get(op_name,'simpfn)) then put(op_name,'resimp_fn,resimp_fn)
+ else put(op_name,'resimp_fn,'simpiden);
+ put(op_name,'simpfn,'simp_multilinear);
+ flag(list(op_name),'full);
+end$
+
+@* Solving linear expressions. We prefer not to use the REDUCE
+procedure |solve| for solving a kernel from an algebraic expression
+which we demand to be linear w.r.t.\ that kernel, because |solve|
+doesn't check for linearity and can give more than one solution in
+case of non linearity. Therefore we will write two quite
+straightforward procedures which do the job properly.
+
+@ \specs |@!linear_solve|, |@!linear_solve_and_assign|.
+ \descr Syntax: \descno 1. |linear_solve(exprn,kernel)|,\nl
+ \descno 2. |linear_solve_and_assign(exprn,kernel)|.
+ \descr Arguments:
+ \arg |exprn|: algebraic expression.
+ \arg |kernel|: kernel.
+ \descr Result:
+ \descno 1. solves |exprn| for |kernel| and returns the
+ solution, regarding |exprn| to be a linear equation w.r.t.\
+ |kernel|. Before solving, |exprn| is simplified.\nl
+ \descno 2. as |linear_solve|,
+ but also sets |kernel| equal to this solution.
+ \descr Errors: stops with an error message if |kernel| is not a
+ kernel, or if |exprn| is not linear w.r.t.\ |kernel|.
+
+@ The procedure |linear_solve| should be available in algebraic mode.
+We will use the same construction as for |operator_coeff| in order to
+avoid unnecessary simplification.
+
+@u
+put('linear_solve,'psopfn,'linear_solve_1)$
+@#
+lisp procedure linear_solve_1 u;
+if length u neq 2 then
+rederr("LINEAR_SOLVE: wrong number of arguments")
+else linear_solve(car u,cadr u)$
+
+@ If we are given an expression |exprn| linear in some kernel
+|kernel|, we should be aware that |exprn| may be multiplied by some
+factors, which might give trouble when solving the equation. In order
+to prevent this we will first determine the factor depending on
+|kernel|. For this purpose we shall use the standard REDUCE procedure
+|fctrf| which finds all factors in a standard form as a list
+containing the first factor as a standard form and all other factors
+as a standard quotient. If there are more factors depending on
+|kernel|, the system is not linear and we can return with an error
+message.
+
+@<If possible find the factor |form| of |exprn| that depends on |kernel|@>=
+exprn:=fctrf numr simp!* exprn;@/
+exprn:=if domainp car exprn then cdr exprn @+else (car exprn . 1) . cdr exprn;
+form:=for each factor in exprn join@+
+ if depends(factor,kernel) then list factor;
+if length form=1 then form:=numr car form else
+ stop_with_error("LINEAR_SOLVE: expression not linear with respect to",
+ kernel,nil,nil)
+
+@ The linearity of |form| can be checked rather easily: reorder form
+w.r.t.\ |kernel|. After this, |form| is linear w.r.t.\ |kernel| if and
+only if the main variable of |form| is |kernel|, the leading degree of
+|form| is 1 and the leading coefficient and the reductum of |form| do
+not depend on |kernel|.
+
+At this place it is convenient to explain how reordering of kernels is
+performed in REDUCE. In algebraic mode the kernel ordering can be
+affected by the command |korder|. This command puts all kernels
+following it on the list |kord!*| (a fluid system variable) and forces
+reevaluation of all algebraic expressions. The actual reordering is
+done by the procedure |reorder| which reorders standard forms using
+the list |kord!*|.
+
+If we declare |kord!*| to be local within all procedures where we want
+to reorder standard forms, we don't have to worry about the kernel
+ordering afterwards, because the values of fluid variables, which are
+used locally within a procedure, are saved on a stack when entering
+the procedure and restored after leaving it.
+
+The procedure |!*a2k| checks whether |kernel| is a kernel.
+
+@u
+lisp procedure linear_solve(exprn,kernel);
+begin scalar kord!*,form;
+ kernel:=!*a2k kernel;
+ @<If possible find the factor |form| of |exprn| that depends on |kernel|@>;
+ setkorder list kernel;
+ form:=reorder form;
+ if (mvar form=kernel) and (ldeg form =1) and
+ not depends(lc form,kernel) and not depends(red form,kernel) then
+ return !*ff2a(negf red form,lc form)
+ else stop_with_error("LINEAR_SOLVE: expression not linear with respect to",
+ kernel,nil,nil);
+end$
+
+@ |linear_solve_and_assign| can simply use the procedures |setk| and
+|linear_solve|. It will also get the |psopfn| mechanism to make it
+available in algebraic mode.
+
+@u
+put('linear_solve_and_assign,'psopfn,'linear_solve_and_assign_1)$
+@#
+lisp procedure linear_solve_and_assign_1 u;
+if length u neq 2 then
+rederr("LINEAR_SOLVE_AND_ASSIGN: wrong number of arguments")
+else linear_solve_and_assign(car u,cadr u)$
+@#
+lisp procedure linear_solve_and_assign(exprn,kernel);
+setk(kernel,linear_solve(exprn,kernel))$
+
+@* Restricted solving of linear expressions. In our programs we want
+to do a lot of automated computations on algebraic expressions
+containing algebraic operators. In particular we think it is
+convenient to have, together with the procedures |linear_solve| and
+|linear_solve_and_assign|, a procedure that searches an algebraic
+expression for kernels of some specified operator with respect to
+which the algebraic expression is linear, but with the coefficients of
+these kernels not depending on some other operators.
+
+Let us give an example in which such a procedure can be used
+fruitfully. Suppose we have an expression |a(3)*a(2)-a(1)| from which
+we want to solve one the |a(i)|'s automatically. Taking the first
+operator element at sight, we would get |a(3):=a(1)/a(2)|. This,
+however, is undesirable, because |a(2)| may be equated to 0 during the
+process, in which case we are in trouble. Therefore the solution
+should be |a(1):=a(3)*a(2)|.
+
+But how can we discover that we must solve for |a(1)|? The answer to
+this question is to use the procedure |solvable_kernels|, which
+we will specify in a moment: the call
+|solvable_kernels(a(3)*a(2)-a(1),a,a)| searches the expression
+|a(3)*a(2)-a(1)| for kernels of operator |a| (second argument), but
+only those which don't have coefficients containing kernels of
+operator |a| (third argument). Hence this call returns the list
+|{a(1)}| which is exactly the list of all kernels for which we may
+solve without risc.
+
+@ \spec |@!solvable_kernels|.
+ \descr Syntax: |solvable_kernels(exprn,k_oplist,c_oplist)|.
+ \descr Arguments:
+ \arg |exprn|: algebraic expression.
+ \arg |k_oplist|: identifier or (algebraic or lisp) list of identifiers,
+ which should be algebraic operator(s).
+ \arg |c_oplist|: identifier or (algebraic or lisp) list of identifiers,
+ which should be algebraic operator(s).
+ \descr Result: returns an algebraic list of all kernels
+ |opkern| for wich all the following conditions are
+ satisfied:\nl
+ \descno 1. |exprn| contains the kernel |opkern| for
+ some operator on |k_oplist|\nl
+ \descno 2. |exprn| is linear w.r.t.\ |opkern|\nl
+ \descno 3. the coefficient of |opkern| in |exprn| is
+ not a polynomial expression in any kernel of
+ operator(s) on |c_oplist|.\nl
+ Before the analysis, |exprn| is simplified.
+ \descr Examples: the call
+ |solvable_kernels(a(1)*(b(1)+c(1))+a(2)*b(2),a,c)|
+ returns the list |{a(2)}|.
+
+@ For |solvable_kernels| we will use the same construction as
+for |operator_coeff| to make it an lisp operator.
+
+@u
+put('solvable_kernels,'psopfn,'solvable_kernels_1)$
+@#
+lisp procedure solvable_kernels_1 u;
+if length u neq 3 then
+rederr("SOLVABLE_KERNELS: wrong number of arguments")
+else solvable_kernels(car u,cadr u,caddr u)$
+
+@ As for |operator_coeff| all the essential actions are taken while
+scanning the numerator $E$ of |exprn|, which is a standard form.
+Seeing $E$ as a sum $E=\sum T_i$ where $T_i=P_i\cdot C_i$, the product
+of a leading power and a leading coefficient, again, we can
+distinguish the following states for each term $T_i$: \medskip
+
+\item{1.} $T_i$ is domain element, hence in particular not a kernel of
+one of the operators on |k_oplist| or |c_oplist|. We have to take no action.
+
+\item{2.} The main variable of $P_i$ is a kernel of one of the
+operators on |k_oplist|. If the leading degree is one and $C_i$ does
+not contain kernels of operators on |c_oplist|, this kernel is a
+possible candidate for solving, otherwise it has to be marked as
+unsolvable.
+
+\item{3.} The main variable of $P_i$ is a kernel of one of the
+operators on |c_oplist|. We can now recursively examine the standard
+form $C_i$ and mark all kernels of operators on |k_oplist| found there
+as unsolvable.
+
+\item{4.} In all other cases we can recursively examine the standard
+form $C_i$, ignoring the factor $P_i$.
+
+\noindent Note that also in case 2.\ we have to check the form $C_i$,
+keeping in mind the conditions of case 3.: the main variable of $P_i$
+can be forbidden as well as allowed as a coefficient.
+
+@ Implementing the actions described above requires a function for
+merging an new element into a list. It is rather straightforward.
+
+@u
+lisp procedure list_merge(element,merge_list);
+if member(element,merge_list) then merge_list else element .
+merge_list$
+
+@ The actions described above are implemented in the procedure
+|mk_kernel_list|. The procedure examines the leading term and
+recursively the reductum of the standard form.
+
+The fifth argument of the procedure, |kernel_list|, is a dotted pair,
+the |car| of which is the list of all possible candidates for solving,
+the |cdr| the list of unsolvable kernels and is returned at the end.
+It is clear that, at top level, it has to be initialized to |nil . nil|.
+
+The fourth argument |forbidden| is a flag indicating if, at some
+higher level, a kernel of an operator on |c_oplist| has been
+encountered, hence that all kernels op operators on |k_oplist| found
+have to be marked as unsolvable. At top level is has to be initialized
+to |nil|.
+
+@u lisp procedure mk_kernel_list(form,k_oplist,c_oplist,forbidden,kernel_list);
+if domainp form then kernel_list
+else (
+ if not atom kernel then
+ mk_kernel_list(red form,k_oplist,c_oplist,forbidden,@|
+ mk_kernel_list(lc form,k_oplist,c_oplist,
+ if member(car kernel,c_oplist) then t @+else forbidden,
+ if member(car kernel,k_oplist) then
+ if not forbidden and ldeg form=1 and
+ not get_first_kernel(lc form,c_oplist) then@|
+ list_merge(kernel,car kernel_list) . cdr kernel_list
+ else
+ car kernel_list . list_merge(kernel,cdr kernel_list)
+ else kernel_list))
+ else mk_kernel_list(red form,k_oplist,c_oplist,forbidden,@|
+ mk_kernel_list(lc form,k_oplist,c_oplist,forbidden,kernel_list))
+ ) where kernel=mvar form$
+
+@ The procedure |solvable_kernels| is a piece of cake now:
+simplify |exprn|, get its numerator, apply |mk_kernel_list| to it and
+finally delete all unsolvable kernels from the list of possible
+candidates for solving. The list obtained in this way is the list of
+all solvable kernels in |exprn|.
+
+Again we use |simp!*| to simplify |exprn|, because |exprn| hasn't been
+simplified before and we want a full simplification including a call
+of |subs2|.
+
+@u
+lisp procedure solvable_kernels(exprn,k_oplist,c_oplist);
+begin scalar form,kernel_list,forbidden_kernels;
+ form:=numr simp!* exprn;
+ k_oplist:=make_oplist(k_oplist);
+ c_oplist:=make_oplist(c_oplist);
+ kernel_list:=mk_kernel_list(form,k_oplist,c_oplist,nil,nil . nil);
+ forbidden_kernels:=cdr kernel_list;
+ kernel_list:=car kernel_list;
+ for each kernel in forbidden_kernels do kernel_list:=delete(kernel,kernel_list);
+ return 'list . kernel_list;
+end$
+
+@ The end of a REDUCE input file must be marked with |end|.
+
+@u end;
+
+@* Index. This section contains the cross reference index of all
+identifiers, together with the numbers of the modules in which they
+are used. Underlined entries correspond to module numbers where the
+identifier was declared.
diff --git a/web/reduce/rweb/make b/web/reduce/rweb/make
new file mode 100644
index 0000000000..b94655243d
--- /dev/null
+++ b/web/reduce/rweb/make
@@ -0,0 +1,3 @@
+#!/bin/csh -f
+/bin/make -f ../reduce/Makefile CPUTYPE=`cputype`\
+ THETANGLE=rtangle THEWEAVE=rweave SPIDER=reduce.spider $*
diff --git a/web/reduce/rweb/make3.3 b/web/reduce/rweb/make3.3
new file mode 100644
index 0000000000..11df067bf5
--- /dev/null
+++ b/web/reduce/rweb/make3.3
@@ -0,0 +1,3 @@
+#!/bin/csh -f
+/bin/make -f ../reduce/Makefile3.3 CPUTYPE=`cputype`\
+ THETANGLE=rtangle.exe THEWEAVE=rweave3.3 SPIDER=reduce33.spider $*
diff --git a/web/reduce/rweb/reduce.spider b/web/reduce/rweb/reduce.spider
new file mode 100644
index 0000000000..a4304aaf65
--- /dev/null
+++ b/web/reduce/rweb/reduce.spider
@@ -0,0 +1,302 @@
+# Copyright (c) 1991: Marcel Roelofs and Peter Gragert
+# University of Twente, Enschede, The Netherlands
+#
+# @(#) reduce.spider (91/03/11)
+
+language REDUCE extension red
+
+at_sign @
+
+comment begin <"%"> end <"%">
+
+default translation <*> mathness no
+
+line begin <"%line"> end <>
+
+token identifier category simp
+token number category simp
+token newline category newline translation <>
+token pseudo_semi category terminator translation <"\\rx">
+
+module definition stmt use module_scrap
+
+default translation <"\\ro"-*> mathness no
+
+token * category binop translation <"\\eo*">
+token / category binop translation <"\\eo/">
+token < category binop
+token > category binop
+token = category binop
+token . category binop tangleto <space-"."-space>
+
+token .^ category binop translation <"\\ro{.\\^}"> tangleto <space-".^"-space>
+token .* category binop translation <"\\ro{.*}"> tangleto <space-".*"-space>
+token .+ category binop translation <"\\ro{.+}"> tangleto <space-".+"-space>
+token ./ category binop translation <"\\ro{./}"> tangleto <space-"./"-space>
+token ^ category binop translation <"\\eo\\^">
+token ** category binop translation <"\\eo\\^">
+token := category binop translation <"\\ro{:=}">
+token != category binop translation <"\\ro\\NEQ"> tangleto <space-"neq"-space>
+token <> category binop translation <"\\ro\\NEQ"> tangleto <space-"neq"-space>
+token <= category binop translation <"\\ro\\leq">
+token >= category binop translation <"\\ro\\geq">
+
+default translation <*> mathness no
+
+token + category unorbinop
+token - category unorbinop
+token ' category quote tangleto <space-"'">
+token '( category listopen translation <"'("> tangleto <space-"'(">
+token '[ category listopen translation <"'["> tangleto <space-"'[">
+token ( category open
+token ) category close
+token [ category simpopen
+token ] category close
+token { category simpopen translation <"$\\{$">
+token } category close translation <"$\\}$">
+token , category comma translation <"\\comma"-opt-1>
+token ; category terminator translation <";"-break_space>
+token $ category terminator translation <"\\$"-break_space>
+token : category colon
+token << category progn_begin translation <"\\LL"> tangleto <space-"<<">
+token >> category end translation <"\\RR"> tangleto <">>"-space>
+
+ilk bool_like category simp
+ilk goto_like category simp
+ilk function_like category simp
+
+default translation <*-space>
+
+ilk begin_like category begin
+ilk if_like category if
+ilk then_like category then
+ilk else_like category else
+ilk for_like category for
+ilk do_like category do
+ilk step_like category step
+ilk repeat_like category repeat
+ilk until_like category until
+ilk on_like category switch
+ilk return_like category return
+ilk modedef_like category mode
+ilk procmode_like category procmode
+ilk proc_like category proc
+ilk where_like category where
+ilk decl_like category decl
+ilk clear_like category clear
+ilk lambda_like category lambda
+ilk end_like category end translation <*>
+
+ilk not_like category unop translation <"\\R">
+ilk neq_like category binop translation <"\\ro\\NEQ">
+ilk and_like category binop translation <"\\ro\\W">
+ilk or_like category binop translation <"\\ro\\V">
+ilk leq_like category binop translation <"\\ro\\leq">
+ilk geq_like category binop translation <"\\ro\\geq">
+
+reserved not ilk not_like
+reserved neq ilk neq_like
+reserved and ilk and_like
+reserved or ilk or_like
+reserved leq ilk leq_like
+reserved geq ilk geq_like
+
+reserved begin ilk begin_like
+reserved end ilk end_like
+
+reserved if ilk if_like
+reserved then ilk then_like
+reserved else ilk else_like
+
+reserved for ilk for_like
+reserved each ilk for_like
+reserved foreach ilk for_like
+reserved all ilk for_like
+reserved forall ilk for_like
+
+reserved do ilk do_like
+reserved sum ilk do_like
+reserved product ilk do_like
+reserved collect ilk do_like
+reserved conc ilk do_like
+reserved let ilk do_like
+reserved join ilk do_like
+
+reserved in ilk step_like
+reserved step ilk step_like
+reserved such ilk step_like
+reserved that ilk step_like
+
+reserved repeat ilk repeat_like
+reserved until ilk until_like
+
+reserved on ilk on_like
+reserved off ilk on_like
+
+reserved go ilk goto_like
+reserved to ilk goto_like
+reserved goto ilk goto_like
+
+reserved return ilk return_like
+reserved while ilk for_like
+
+reserved algebraic ilk modedef_like
+reserved symbolic ilk modedef_like
+reserved lisp ilk modedef_like
+
+reserved expr ilk procmode_like
+reserved fexpr ilk procmode_like
+reserved macro ilk procmode_like
+reserved smacro ilk procmode_like
+
+reserved procedure ilk proc_like
+
+reserved where ilk where_like
+
+reserved scalar ilk decl_like
+reserved integer ilk decl_like
+reserved real ilk decl_like
+reserved operator ilk decl_like
+reserved array ilk decl_like
+reserved matrix ilk decl_like
+reserved linear ilk decl_like
+reserved symmetric ilk decl_like
+reserved antisymmetric ilk decl_like
+reserved clear ilk clear_like
+
+reserved nil ilk bool_like
+reserved t ilk bool_like
+
+reserved function ilk function_like
+reserved lambda ilk lambda_like
+
+##################################
+# The production rules
+##################################
+
+# Emergency rules, WEAVE commands & comments
+newline ? --> #2
+<cancel-"\\rx"> ignore_scrap ? --> #2
+<cancel> ignore_scrap --> terminator
+terminator --> stmt
+end --> simp
+
+# Simple expressions
+simp <"\\Rs"-opt-3> simp --> simp
+simp binop simp --> simp
+simp <"\\bo"> unorbinop simp --> simp
+<"\\uo"> (unop|unorbinop) simp --> simp
+
+simp <"\\Rs"-indent-cancel> stmt <outdent> --> stmt
+simp binop <indent-cancel> stmt <outdent> --> stmt
+simp <"\\bo"> unorbinop <indent-cancel> stmt <outdent> --> stmt
+<"\\uo"> (unop|unorbinop) <indent-cancel> stmt <outdent> --> stmt
+
+quote <cancel> ? <cancel> --> simp
+simp comma simp --> simp
+simp terminator --> stmt
+stmt stmt --> stmt
+
+# Lists and vectors
+open <cancel> simp <cancel> close --> simp
+
+listopen simp [ open ] --> listopen simp simpopen
+listopen [ open ] --> listopen simpopen
+listopen <"$\\,$"> close --> simp
+listopen simp close --> simp
+
+simpopen <"$\\,$"> close --> simp
+simpopen <"\\Ri"-cancel> simp <cancel-"\\Ro"> close --> simp
+
+# Function calls
+simp open <"$\\,$"> close --> simp
+simp open <"\\Ri"-cancel> simp <cancel-"\\Ro"> close --> simp
+
+# Procedure definitions
+(mode|procmode) proc --> proc
+proc stmt* <force-indent> stmt <outdent-force> --> stmt
+(simp|stmt) <force> proc --> proc
+
+# Declarations
+mode <cancel> (terminator|open) --> #2
+mode stmt --> stmt
+proc stmt begin [ decl stmt* <force> ] --> proc stmt begin stmt
+(decl|clear|switch|do) stmt* <force> --> stmt
+
+# Blocks
+[ simp <break_space> ] end --> stmt end
+<force> begin <force> end --> simp
+<force> begin <opt-7> stmt <force> end terminator <force> --> stmt
+[ <force> begin <opt-7> stmt <force> end ] !terminator --> simp !terminator
+progn_begin end --> simp
+<force> progn_begin <indent-cancel> stmt <cancel-outdent> end terminator <force> --> stmt
+[ <force> progn_begin <indent-cancel> stmt <cancel-outdent> end ] !terminator --> simp !terminator
+
+# For statements in all flavours
+for for --> for
+for [ simp colon <opt-3> simp ] --> for simp
+for [ simp <"\\Rs"> (step|until|switch) <opt-3> simp ] --> for simp
+[ <force> for simp <"\\Rs"> do <opt-1-indent> simp <outdent> ] (comma|close|else|end) --> simp (comma|close|else|end)
+<force> for simp <"\\Rs"> do <opt-1-indent> simp terminator <outdent-force> --> stmt
+<force> for simp <"\\Rs"> do <opt-1-indent> stmt <outdent> --> stmt
+
+# If statements
+if simp <"\\Rs"> then <opt-1> --> ifthen
+ifthen <indent> simp <"\\Rs"-outdent-force> else <opt-1> --> ifelse
+ifelse [ ifelse <indent> simp <outdent> ] (comma|close|else|end) --> ifelse simp (comma|close|else|end)
+ifelse [ (if|ifthen) <indent> simp <outdent> ] (comma|close|end) --> ifelse simp (comma|close|end)
+[ <force> ifelse <indent> simp <outdent> ] (comma|close|else|end) --> simp (comma|close|else|end)
+[ <force> (if|ifthen) <indent> simp <outdent> ] (comma|close|end) --> simp (comma|close|end)
+<force> (ifthen|ifelse) <indent> simp terminator <outdent-force> --> stmt
+<force> (ifthen|ifelse) <indent> stmt <outdent> --> stmt
+ifelse [ (ifthen|ifelse) <indent> simp terminator <outdent-force> ] --> ifelse stmt
+ifelse [ (ifthen|ifelse) <indent> stmt <outdent> ] --> ifelse stmt
+
+# Where
+[ simp <"\\Rs"-opt-1> where simp ] (close|else|end) --> simp (close|else|end)
+simp <"\\Rs"-opt-1> where stmt <force> --> stmt
+
+# Return statement
+[ <force> return <indent> simp <outdent> ] (close|else|end) --> simp (close|else|end)
+<force> return <indent> simp terminator <outdent-force> --> stmt
+<force> return <indent> stmt <outdent> --> stmt
+
+# Repeat statements
+[ <force> repeat <"\\Rs"-opt-7-indent> simp <outdent-force> until <indent> simp <outdent> ] (comma|close|else|end) --> simp (comma|close|else|end)
+<force> repeat <"\\Rs"-opt-7-indent> simp <outdent-force> until <indent> simp terminator <outdent-force> --> stmt
+
+# Labels
+!for [ <force-backup> simp colon <"\\Rs"-cancel> (simp|stmt|end) ] --> !for #4
+
+# Module use
+stmt <force> module_scrap terminator <force> --> stmt
+module_scrap --> simp
+
+# Lambda calculus (far from complete and probably incorrect)
+lambda simp --> lambda
+lambda terminator --> lambda
+open lambda close --> simp
+
+macros begin
+\def\commentbegin{\{}
+\def\commentend{\}}
+\def\comma{$,{}$}
+\def\uo#1{$#1$}
+\def\ro#1{${}\mathrel{#1}{}$}
+\def\bo#1{${}\mathbin{#1}{}$}
+\def\eo#1{$#1$}
+\def\NEQ{\hbox{$\ne$}}
+\def\LL{$\ll\,$}
+\def\RR{$\,\gg$}
+\def\PS{\joinrel{+\equiv}}
+\let\rx\relax
+\newcount\extraindent
+\def\Ri{\global\advance\extraindent by1}
+\def\Ro{\global\advance\extraindent by-1}
+\def\Rs{{ }}
+\def\startline{\noindent\count255=\ind
+ \ifnum\extraindent=0\advance\count255by-2\fi
+ \hskip\count255 em}
+\def\3#1{\hfil\ifnum#1=0\penalty-100\else\penalty#10\fi\hfilneg}
+macros end
+
diff --git a/web/reduce/rweb/reduce33.spider b/web/reduce/rweb/reduce33.spider
new file mode 100644
index 0000000000..e416d656f3
--- /dev/null
+++ b/web/reduce/rweb/reduce33.spider
@@ -0,0 +1,298 @@
+# Copyright (c) 1991: Marcel Roelofs and Peter Gragert
+# University of Twente, Enschede, The Netherlands
+#
+# @(#) reduce.spider (91/03/11)
+
+language REDUCE extension r
+
+at_sign @
+
+comment begin <"%"> end <"%">
+
+default translation <*> mathness no
+
+line begin <"%line"> end <>
+
+token identifier category simp
+token number category simp
+token newline category newline translation <>
+token pseudo_semi category terminator translation <"\\rx">
+
+module definition stmt use module_scrap
+
+default translation <"\\ro"-*> mathness no
+
+token * category binop translation <"\\eo*">
+token / category binop translation <"\\eo/">
+token < category binop
+token > category binop
+token = category binop
+token . category binop tangleto <space-"."-space>
+
+token .^ category binop translation <"\\ro{.\\^}"> tangleto <space-".^"-space>
+token .* category binop translation <"\\ro{.*}"> tangleto <space-".*"-space>
+token .+ category binop translation <"\\ro{.+}"> tangleto <space-".+"-space>
+token ./ category binop translation <"\\ro{./}"> tangleto <space-"./"-space>
+token ^ category binop translation <"\\eo\\^">
+token ** category binop translation <"\\eo\\^">
+token := category binop translation <"\\ro\\leftarrow">
+token != category binop translation <"\\ro\\NEQ"> tangleto <space-"neq"-space>
+token <> category binop translation <"\\ro\\NEQ"> tangleto <space-"neq"-space>
+token <= category binop translation <"\\ro\\leq">
+token >= category binop translation <"\\ro\\geq">
+
+default translation <*> mathness no
+
+token + category unorbinop
+token - category unorbinop
+token ' category quote tangleto <space-"'">
+token '( category listopen translation <"'("> tangleto <space-"'(">
+token '[ category listopen translation <"'["> tangleto <space-"'[">
+token ( category open
+token ) category close
+token [ category simpopen
+token ] category close
+token { category simpopen translation <"$\\{$">
+token } category close translation <"$\\}$">
+token , category comma translation <"\\comma"-opt-1>
+token ; category terminator translation <";"-break_space>
+token $ category terminator translation <"\\$"-break_space>
+token : category colon
+token << category progn_begin translation <"\\LL"> tangleto <space-"<<">
+token >> category end translation <"\\RR"> tangleto <">>"-space>
+
+ilk bool_like category simp
+ilk goto_like category simp
+ilk function_like category function
+
+default translation <*-space>
+
+ilk begin_like category begin
+ilk if_like category if
+ilk then_like category then
+ilk else_like category else
+ilk for_like category for
+ilk do_like category do
+ilk step_like category step
+ilk repeat_like category repeat
+ilk until_like category until
+ilk on_like category switch
+ilk return_like category return
+ilk modedef_like category mode
+ilk procmode_like category procmode
+ilk proc_like category proc
+ilk where_like category where
+ilk decl_like category decl
+ilk clear_like category clear
+ilk lambda_like category lambda
+ilk end_like category end translation <*>
+
+ilk not_like category unop translation <"\\R">
+ilk neq_like category binop translation <"\\ro\\NEQ">
+ilk and_like category binop translation <"\\ro\\W">
+ilk or_like category binop translation <"\\ro\\V">
+ilk leq_like category binop translation <"\\ro\\leq">
+ilk geq_like category binop translation <"\\ro\\geq">
+
+reserved not ilk not_like
+reserved neq ilk neq_like
+reserved and ilk and_like
+reserved or ilk or_like
+reserved leq ilk leq_like
+reserved geq ilk geq_like
+
+reserved begin ilk begin_like
+reserved end ilk end_like
+
+reserved if ilk if_like
+reserved then ilk then_like
+reserved else ilk else_like
+
+reserved for ilk for_like
+reserved each ilk for_like
+reserved foreach ilk for_like
+reserved all ilk for_like
+reserved forall ilk for_like
+
+reserved do ilk do_like
+reserved sum ilk do_like
+reserved product ilk do_like
+reserved collect ilk do_like
+reserved conc ilk do_like
+reserved let ilk do_like
+reserved join ilk do_like
+
+reserved in ilk step_like
+reserved step ilk step_like
+reserved such ilk step_like
+reserved that ilk step_like
+
+reserved repeat ilk repeat_like
+reserved until ilk until_like
+
+reserved on ilk on_like
+reserved off ilk on_like
+
+reserved go ilk goto_like
+reserved to ilk goto_like
+reserved goto ilk goto_like
+
+reserved return ilk return_like
+reserved while ilk for_like
+
+reserved algebraic ilk modedef_like
+reserved symbolic ilk modedef_like
+reserved lisp ilk modedef_like
+
+reserved expr ilk procmode_like
+reserved fexpr ilk procmode_like
+reserved macro ilk procmode_like
+reserved smacro ilk procmode_like
+
+reserved procedure ilk proc_like
+
+reserved where ilk where_like
+
+reserved scalar ilk decl_like
+reserved integer ilk decl_like
+reserved real ilk decl_like
+reserved operator ilk decl_like
+reserved array ilk decl_like
+reserved matrix ilk decl_like
+reserved linear ilk decl_like
+reserved symmetric ilk decl_like
+reserved antisymmetric ilk decl_like
+reserved clear ilk clear_like
+
+reserved nil ilk bool_like
+reserved t ilk bool_like
+
+reserved function ilk function_like
+reserved lambda ilk lambda_like
+
+##################################
+# The production rules
+##################################
+
+# Emergency rules, WEAVE commands & comments
+newline ? --> #2
+<cancel-"\\rx"> ignore_scrap ? --> #2
+<cancel> ignore_scrap --> terminator
+terminator --> stmt
+end --> simp
+
+# Simple expressions
+simp <"\\Rs"-opt-3> simp --> simp
+simp binop simp --> simp
+simp <"\\bo"> unorbinop simp --> simp
+<"\\uo"> (unop|unorbinop) simp --> simp
+
+simp <"\\Rs"-indent-cancel> stmt <outdent> --> stmt
+simp binop <indent-cancel> stmt <outdent> --> stmt
+simp <"\\bo"> unorbinop <indent-cancel> stmt <outdent> --> stmt
+<"\\uo"> (unop|unorbinop) <indent-cancel> stmt <outdent> --> stmt
+
+quote <cancel> ? <cancel> --> simp
+simp comma simp --> simp
+simp terminator --> stmt
+stmt stmt --> stmt
+
+# Lists and vectors
+open <cancel> simp <cancel> close --> simp
+
+listopen simp [ open ] --> listopen simp simpopen
+listopen [ open ] --> listopen simpopen
+listopen <"$\\,$"> close --> simp
+listopen simp close --> simp
+
+simpopen <"$\\,$"> close --> simp
+simpopen <"\\Ri"-cancel> simp <cancel-"\\Ro"> close --> simp
+
+# Function calls
+simp open <"$\\,$"> close --> simp
+simp open <"\\Ri"-cancel> simp <cancel-"\\Ro"> close --> simp
+
+# Procedure definitions
+(mode|procmode) proc --> proc
+proc stmt* <force-indent> stmt <outdent-force> --> stmt
+(simp|stmt) <force> proc --> proc
+
+# Declarations
+mode <cancel> (terminator|open) --> #2
+mode stmt --> stmt
+proc stmt begin [ decl stmt* <force> ] --> proc stmt begin stmt
+(decl|clear|switch|do) stmt* <force> --> stmt
+
+# Blocks
+[ simp <break_space> ] end --> stmt end
+<force> begin <force> end --> simp
+<force> begin <opt-7> stmt <force> end terminator <force> --> stmt
+[ <force> begin <opt-7> stmt <force> end ] !terminator --> simp !terminator
+progn_begin end --> simp
+<force> progn_begin <indent-cancel> stmt <cancel-outdent> end terminator <force> --> stmt
+[ <force> progn_begin <indent-cancel> stmt <cancel-outdent> end ] !terminator --> simp !terminator
+
+# For statements in all flavours
+for for --> for
+for [ simp colon <opt-3> simp ] --> for simp
+for [ simp <"\\Rs"> (step|until|switch) <opt-3> simp ] --> for simp
+[ <force> for simp <"\\Rs"> do <opt-1-indent> simp <outdent> ] (comma|close|else|end) --> simp (comma|close|else|end)
+<force> for simp <"\\Rs"> do <opt-1-indent> simp terminator <outdent-force> --> stmt
+<force> for simp <"\\Rs"> do <opt-1-indent> stmt <outdent> --> stmt
+
+# If statements
+if simp <"\\Rs"> then <opt-1> --> ifthen
+ifthen <indent> simp <"\\Rs"-outdent-force> else <opt-1> --> ifelse
+[ <force> ifelse <indent> simp <outdent> ] (comma|close|else|end) --> simp (comma|close|else|end)
+[ <force> (if|ifthen) <indent> simp <outdent> ] (comma|close|end) --> simp (comma|close|end)
+<force> (ifthen|ifelse) <indent> simp terminator <outdent-force> --> stmt
+<force> (ifthen|ifelse) <indent> stmt <outdent> --> stmt
+
+# Where
+[ simp <"\\Rs"-opt-1> where simp ] (close|else|end) --> simp (close|else|end)
+simp <"\\Rs"-opt-1> where simp terminator <force> --> stmt
+
+# Return statement
+[ <force> return <indent> simp <outdent> ] (close|else|end) --> simp (close|else|end)
+<force> return <indent> simp terminator <outdent-force> --> stmt
+<force> return <indent> stmt <outdent> --> stmt
+
+# Repeat statements
+[ <force> repeat <"\\Rs"-opt-7-indent> simp <outdent-force> until <indent> simp <outdent> ] (comma|close|else|end) --> simp (comma|close|else|end)
+<force> repeat <"\\Rs"-opt-7-indent> simp <outdent-force> until <indent> simp terminator <outdent-force> --> stmt
+
+# Labels
+!for [ <force-backup> simp colon <"\\Rs"-cancel> (simp|end) ] --> !for #4
+
+# Module use
+stmt <force> module_scrap terminator <force> --> stmt
+module_scrap --> simp
+
+# Lambda calculus (far from complete and probably incorrect)
+lambda simp --> simp
+function [ open simp terminator ] --> function open
+function open simp close --> simp
+
+macros begin
+\def\commentbegin{\{}
+\def\commentend{\}}
+\def\comma{$,{}$}
+\def\uo#1{$#1$}
+\def\ro#1{${}\mathrel{#1}{}$}
+\def\bo#1{${}\mathbin{#1}{}$}
+\def\eo#1{$#1$}
+\def\NEQ{\hbox{$\ne$}}
+\def\LL{$\ll\,$}
+\def\RR{$\,\gg$}
+\def\PS{\joinrel{+\equiv}}
+\let\rx\relax
+\newcount\extraindent
+\def\Ri{\global\advance\extraindent by1}
+\def\Ro{\global\advance\extraindent by-1}
+\def\Rs{{ }}
+\def\startline{\noindent\count255=\ind
+ \ifnum\extraindent=0\advance\count255by-2\fi
+ \hskip\count255 em}
+\def\3#1{\hfil\ifnum#1=0\penalty-100\else\penalty#10\fi\hfilneg}
+macros end
+
diff --git a/web/reduce/rweb/rtangle b/web/reduce/rweb/rtangle
new file mode 100644
index 0000000000..3f5f713c73
--- /dev/null
+++ b/web/reduce/rweb/rtangle
@@ -0,0 +1,10 @@
+#!/bin/ksh
+# Copyright (c) 1991: Marcel Roelofs and Peter Gragert
+# University of Twente, Enschede, The Netherlands
+#
+# @(#) rtangle (91/03/11)
+
+webfile=$1
+shift
+rtangle.exe ${webfile} $*
+underscore <${webfile}.r > ${webfile}.red
diff --git a/web/reduce/rweb/rtangle.ch b/web/reduce/rweb/rtangle.ch
new file mode 100644
index 0000000000..57de6458a6
--- /dev/null
+++ b/web/reduce/rweb/rtangle.ch
@@ -0,0 +1,135 @@
+% Copyright (c) 1991: Marcel Roelofs and Peter Gragert
+% University of Twente, Enschede, The Netherlands
+% @@(#) rtangle.ch (91/03/11)
+
+@x
+@u
+@<Include files@>@;
+@<Common code for \.{WEAVE} and \.{TANGLE}@>@;
+@<Typedef declarations@>@;
+@<Global variables@>@;
+@y
+@u
+#define NEWLINES_IN_MACROS
+@<Include files@>@;
+@<Common code for \.{WEAVE} and \.{TANGLE}@>@;
+@<Typedef declarations@>@;
+@<Global variables@>@;
+@z
+
+@x
+ if (isdigit(c) || c=='\\' || c=='.') @<Get a constant@>@;/*spider*/
+ else if (isalpha(c) || c=='_' || c=='$') @<Get an identifier@>@;/*spider*/
+ else if (c=='\'' || c=='\"') @<Get a string@>@;/*spider*/
+@y
+ if (isdigit(c)) @<Get a constant@>@;/*spider*/
+ else if (isalpha(c) || c=='_' || c=='!') @<Get an identifier@>@;/*spider*/
+ else if (c=='\"') @<Get a string@>@;/*spider*/
+@z
+
+@x
+@ @<Get an identifier@>= {/*spider*/
+ id_first=--loc;
+ while (isalpha(*++loc) || isdigit(*loc) || *loc=='_');
+ if (*loc=='$') while (isdigit(*++loc)||*loc=='$');
+ /* make room for \$\$ and \$nnn suffixes */
+ id_loc=loc; return(identifier);
+}
+@y
+@ @<Get an identifier@>= {/*spider*/
+ id_first=--loc;
+ if (c=='!') ++loc;
+ while (isalpha(*++loc) || isdigit(*loc) || *loc=='_' || *loc=='!')
+ if (*loc=='!') ++loc;
+ id_loc=loc; return(identifier);
+}
+@z
+
+@x
+@ \cee\ strings and character constants, delimited by double and single
+quotes, respectively, can contain newlines or instances of their own
+delimiters if they are protected by a backslash. We follow this
+convention, but do not allow the string to be longer than |longest_name|.
+
+@<Get a string@>= {/*spider*/
+ ASCII delim = c; /* what started the string */
+@#
+/* if it's not a single-character literal, it's a tick mark or an |at_sign| */
+ if (delim=='\'' && (loc+1>=limit ||
+ (*loc != '\\' && *loc!=at_sign && loc[1]!='\'') ||
+ (*loc=='\\' && (loc+2>=limit||loc[2]!='\'')) ||
+ (*loc==at_sign &&
+ (loc+2>=limit||loc[1]!=at_sign||loc[2]!='\''))
+ )) goto mistake;
+ id_first = mod_text+1;
+ id_loc = mod_text; *++id_loc=delim;
+ while (1) {
+ if (loc>=limit) {
+ if(*(limit-1)!='\\') {
+ err_print("! String didn't end"); loc=limit; break;
+@.String didn't end@>
+ }
+ if(get_line()==0) {
+ err_print("! Input ended in middle of string"); loc=buffer; break;
+@.Input ended in middle of string@>
+ }
+ else if (++id_loc<=mod_text_end) *id_loc=@`\n'; /* will print as
+ \.{"\\\\\\n"} */
+ }
+ if ((c=*loc++)==delim) {
+ if (++id_loc<=mod_text_end) *id_loc=c;
+ break;
+ }
+ if (c=='\\') {
+ if (loc>=limit) continue;
+ if (++id_loc<=mod_text_end) *id_loc = '\\';
+ c=*loc++;
+ }
+ if (++id_loc<=mod_text_end) *id_loc=c;
+ }
+ if (id_loc>=mod_text_end) {
+ printf("\n! String too long: ");
+@.String too long@>
+ ASCII_write(mod_text+1,25);
+ printf("..."); mark_error;
+ }
+ id_loc++;
+ return(string);
+}
+@y
+@ \cee\ strings are delimited by double quotes and must be restricted
+to one line. Double quotes in strings must be doubled and we allow no
+string to be longer than |longest_name|.
+
+@<Get a string@>= {/*spider*/
+ ASCII delim = c; /* what started the string */
+@#
+ id_first = mod_text+1;
+ id_loc = mod_text; *++id_loc=delim;
+ while (1) {
+ if (loc>=limit) {
+ err_print("! String didn't end"); loc=limit;
+@.String didn't end@>
+ if (get_line()==0) {
+ err_print("! Input ended in middle of string"); loc=buffer;
+@.Input ended in middle of string@>
+ }
+ break;
+ }
+ if ((c=*loc++)==delim) {
+ if (++id_loc<=mod_text_end) *id_loc=c;
+ if (*loc==delim) loc++;
+ else break;
+ }
+ if (++id_loc<=mod_text_end) *id_loc=c;
+ }
+ if (id_loc>=mod_text_end) {
+ printf("\n! String too long: ");
+@.String too long@>
+ ASCII_write(mod_text+1,25);
+ printf("..."); mark_error;
+ }
+ id_loc++;
+ return(string);
+}
+@z
diff --git a/web/reduce/rweb/rweave.ch b/web/reduce/rweb/rweave.ch
new file mode 100644
index 0000000000..7c0c1346b1
--- /dev/null
+++ b/web/reduce/rweb/rweave.ch
@@ -0,0 +1,209 @@
+% Copyright (c) 1991: Marcel Roelofs and Peter Gragert
+% University of Twente, Enschede, The Netherlands
+% @@(#) rweave.ch (91/03/11)
+
+@x
+ if (isdigit(c)) @<Get a constant@>@; /*spider*/
+ else if (isalpha(c) || c=='_') @<Get an identifier@>@;/*spider*/
+ else if (c=='\'' || c=='"') @<Get a string@>@;/*spider*/
+@y
+ if (isdigit(c)) @<Get a constant@>@;/*spider*/
+ else if (isalpha(c) || c=='_' || c=='!') @<Get an identifier@>@;/*spider*/
+ else if (c=='\"') @<Get a string@>@;/*spider*/
+@z
+
+@x
+@ @<Get an identifier@>= {/*spider*/
+ id_first=--loc;
+ while (isalpha(*++loc) || isdigit(*loc) || *loc=='_');
+ id_loc=loc; return(identifier);
+}
+@y
+@ @<Get an identifier@>= {/*spider*/
+ id_first=--loc;
+ if (c=='!') ++loc;
+ while (isalpha(*++loc) || isdigit(*loc) || *loc=='_' || *loc=='!')
+ if (*loc=='!') ++loc;
+ id_loc=loc; return(identifier);
+}
+@z
+
+@x
+@ \cee\ strings and character constants, delimited by double and single
+quotes, respectively, can contain newlines or instances of their own
+delimiters if they are protected by a backslash. We follow this
+convention, but do not allow the string to be longer than |longest_name|.
+
+@<Get a string@>= {/*spider*/
+ ASCII delim = c; /* what started the string */
+ id_first = mod_text+1;
+ id_loc = mod_text;
+ if (delim=='`' && *(loc-2)==at_sign) {
+ /* make string begin with |"@@`"| */
+ *++id_loc=at_sign;
+ *++id_loc=at_sign;
+ }
+ /* this is hack for ascii constant */
+@#
+/* if it's not a single-character literal, it's a tick mark or an |at_sign| */
+ if ((delim=='\'' || delim == '`') &&
+ (loc+1>=limit ||
+ (*loc != '\\' && *loc!=at_sign && loc[1]!='\'') ||
+ (*loc=='\\' && (loc+2>=limit||loc[2]!='\'')) ||
+ (*loc==at_sign &&
+ (loc+2>=limit||loc[1]!=at_sign||loc[2]!='\''))
+ )
+ ) goto mistake;
+ *++id_loc=delim;
+ if (delim=='`') delim='\''; /* for |ascii_constant|s */
+ while (1) {
+ if (loc>=limit) {
+ if(*(limit-1)!='\\') {
+ err_print("! String didn't end"); loc=limit; break;
+@.String didn't end@>
+ }
+ if(get_line()==0) {
+ err_print("! Input ended in middle of string"); loc=buffer; break;
+@.Input ended in middle of string@>
+ }
+ }
+ if ((c=*loc++)==delim) {
+ if (++id_loc<=mod_text_end) *id_loc=c;
+ break;
+ }
+ if (c=='\\') if (loc>=limit) continue;
+ else if (++id_loc<=mod_text_end) {
+ *id_loc = '\\'; c=*loc++;
+ }
+ if (++id_loc<=mod_text_end) *id_loc=c;
+ }
+ if (id_loc>=mod_text_end) {
+ printf("\n! String too long: ");
+@.String too long@>
+ ASCII_write(mod_text+1,25);
+ printf("..."); mark_error;
+ }
+ id_loc++;
+ return(string);
+}
+@y
+@ \cee\ strings are delimited by double quotes and must be restricted
+to one line. Double quotes in strings must be doubled and we allow no
+string to be longer than |longest_name|.
+
+@<Get a string@>= {/*spider*/
+ ASCII delim = c; /* what started the string */
+@#
+ id_first = mod_text+1;
+ id_loc = mod_text; *++id_loc=delim;
+ while (1) {
+ if (loc>=limit) {
+ err_print("! String didn't end"); loc=limit;
+@.String didn't end@>
+ if (get_line()==0) {
+ err_print("! Input ended in middle of string"); loc=buffer;
+@.Input ended in middle of string@>
+ }
+ break;
+ }
+ if ((c=*loc++)==delim) {
+ if (++id_loc<=mod_text_end) *id_loc=c;
+ if (*loc==delim) loc++;
+ else break;
+ }
+ if (++id_loc<=mod_text_end) *id_loc=c;
+ }
+ if (id_loc>=mod_text_end) {
+ printf("\n! String too long: ");
+@.String too long@>
+ ASCII_write(mod_text+1,25);
+ printf("..."); mark_error;
+ }
+ id_loc++;
+ return(string);
+}
+@z
+
+@x
+ case 1: printf("\\{"); print_id((name_dir+r)); printf("}"); break;
+ /* |id_flag| */
+ case 2: printf("\&{"); print_id((name_dir+r)); printf("}"); break;
+@y
+ case 1: printf("\\\\{"); print_id((name_dir+r)); printf("}"); break;
+ /* |id_flag| */
+ case 2: printf("\\&{"); print_id((name_dir+r)); printf("}"); break;
+@z
+
+@x
+@ @<Start a format...@>= {
+ app_str("\\F"); app_scrap(SP_ignore_scrap,no_math);
+ /* this will produce `\&{format}' */
+@.\\F@>
+@<Set |next_control| to the first non-newline token@>@;
+/* claim at this point |scrap_ptr==scrap_info+1| */
+ if (scrap_ptr!=scrap_info+1) {
+ err_print("! This can't happen -- bad scrap_ptr in format definition");
+ printf("\n\tscrap_ptr-scrap_info==%d\n",scrap_ptr-scrap_info);
+ }
+ if (next_control==identifier) {
+ small_app(id_flag+id_lookup(id_first, id_loc,normal)-name_dir);
+ app_str(" ");
+ app_scrap(SP_ignore_scrap,no_math); /*spider*/
+ /* this is syntactically separate from what follows */
+ @<Set |next_control| to the first non-newline token@>@;
+ if (next_control==identifier) {
+ small_app(id_flag+id_lookup(id_first, id_loc,normal)-name_dir);
+ small_app(@`\n');
+ app_scrap(SP_ignore_scrap,no_math);
+ @<Set |next_control| to the first non-newline token@>@;
+ }
+ }
+ /* if everything went well, we appended two scraps */
+ if (scrap_ptr!=scrap_info+3) err_print("! Improper format definition");
+@.Improper format definition@>
+}
+@y
+@ @<Start a format...@>= {
+ small_app(backup); app_str("\\F"); app_scrap(SP_ignore_scrap,no_math);
+ /* this will produce `\&{format}' */
+@.\\F@>
+@<Set |next_control| to the first non-newline token@>@;
+/* claim at this point |scrap_ptr==scrap_info+1| */
+ if (scrap_ptr!=scrap_info+1) {
+ err_print("! This can't happen -- bad scrap_ptr in format definition");
+ printf("\n\tscrap_ptr-scrap_info==%d\n",scrap_ptr-scrap_info);
+ }
+ if (next_control==identifier) {
+ small_app(id_flag+id_lookup(id_first, id_loc,normal)-name_dir);
+ app_str(" ");
+ app_scrap(SP_ignore_scrap,no_math); /*spider*/
+ /* this is syntactically separate from what follows */
+ @<Set |next_control| to the first non-newline token@>@;
+ if (next_control==identifier) {
+ small_app(id_flag+id_lookup(id_first, id_loc,normal)-name_dir);
+ small_app(@`\n');
+ app_scrap(SP_ignore_scrap,no_math);
+ @<Set |next_control| to the first non-newline token@>@;
+ }
+ }
+ /* if everything went well, we appended two scraps */
+ if (scrap_ptr!=scrap_info+2) err_print("! Improper format definition");
+@.Improper format definition@>
+}
+@z
+
+@x
+if (cur_xref->num%def_flag!=module_count) {
+ app_str("+"); /*module name is multiply defined*/
+ this_module=name_dir; /*so we won't give cross-reference info here*/
+}
+app_str("\\S"); /* output an equivalence sign */
+@y
+if (cur_xref->num%def_flag!=module_count) {
+ app_str("\\PS"); /*module name is multiply defined*/
+ this_module=name_dir; /*so we won't give cross-reference info here*/
+}
+else app_str("\\S"); /* output an equivalence sign */
+@z
+
+
diff --git a/web/reduce/rweb/texinputs/specification.tex b/web/reduce/rweb/texinputs/specification.tex
new file mode 100644
index 0000000000..92368bb625
--- /dev/null
+++ b/web/reduce/rweb/texinputs/specification.tex
@@ -0,0 +1,10 @@
+\def\nl{\unskip\hfill\penalty-10000\relax}
+\def\spec#1.{{\bf Specification of the procedure} #1.\smallskip}
+\def\specs#1.{{\bf Specification of the procedures} #1.\smallskip}
+\def\descr#1:{\smallskip\hangindent5em\noindent\hskip5em
+ \llap{{\bf #1}:\enspace}\ignorespaces}
+\def\descno#1.{\hbox to 1.25em{#1.\hss}\ignorespaces}
+\def\descrr#1{\par\hangindent5em\noindent\hskip5em
+ \llap{#1\enspace}\ignorespaces}
+\def\arg#1:{\descrr{#1:}}
+
diff --git a/web/reduce/rweb/underscore.web b/web/reduce/rweb/underscore.web
new file mode 100644
index 0000000000..b04b90c5e6
--- /dev/null
+++ b/web/reduce/rweb/underscore.web
@@ -0,0 +1,32 @@
+% Copyright (c) 1991: Marcel Roelofs and Peter Gragert
+% University of Twente, Enschede, The Netherlands
+% @@(#) underscore.web (91/03/11)
+
+@* Filter to remove underscores from REDUCE source. REDUCE does not
+allow sole underscores in identifiers. However, underscores preceded
+by an exclamation mark are allowed. Also REDUCE strings may contain
+underscores. The following C program is a filter that removes the
+forbidden underscores.
+
+@u
+#include <stdio.h>
+
+main (ac, av)
+char **av;
+{
+char c;
+while ((c=getc(stdin)) != EOF)
+ if (c=='!') {
+ putc(c,stdout);
+ c=getc(stdin);
+ putc(c,stdout);
+ }
+ else
+ if (c=='\"') {
+ while (putc(c,stdout), (c=getc(stdin)) != '\"') ;
+ putc(c,stdout);
+ }
+ else
+ if (c != '_') putc(c,stdout);
+}
+