#
#--> GRADIENT(f,[xi,..,xk]) -- compute [ D[i](f), .. , D[k](f) ]
#--> GRADIENT(f,p) -- compute [ D[1](f), .. , D[p](f) ] 
#                     equivalent  to GRADIENT(f,[x1,..,xp])
#--> GRADIENT(f) -- compute [ D[1](f), .. , D[n](f)]
#                   equivalent to GRADIENT(f,[x1,..xn])
#
# Given a Maple procedure f, a function of n arguments X where
#
#       X = x1, x2, ..., xn
#
# GRADIENT(f,[xi, .. , xk]) computes the gradient of f wrt {xi, .. , xk}
# where  1 <= i,k <= n , i.e. returns a Maple procedure g, which computes
#
#       grad( f(xi, .. , xk)) = [ diff(f,xi), .. , diff(f,xk)]
#
# The global boolean variable include_funcval (default false) specifies
# whether the value of f and its gradient are to be returned or not.
# If include_funcval is false, the procedure g returned computes 
# only the gradient of f wrt the specified variables!
# If include_funcval is true, the procedure g computes the value of f
# and the gradient of f wrt the specified variables!
# For example, GRADIENT(f,[xi,xj]) returns a procedure which computes
#
#  	f(X), diff(f(X),xi), diff(f(X),xj)
#
# and GRADIENT(f,3) returns a procedure which computes 
#
# 	f(X), D[1](f)(X), D[2](f)(X), D[3](f)(X)
#
# The global boolean variable generate_array (default false) specifies
# whether the procedure g returns an array instead of a sequence for
# the gradient.
# Returning the gradient as an array is very useful if you want to
# redifferentiate the returned procedure g. The representation of the
# gradient of a function f as an array is more close to mathematics.
#
# The algorithm for differentiating a procedure is trivially as follows.
# For computing the derivative of the derivative of f wrt x, for
# each assignment statement  t := f(x);  we precede it by the assignment
# statement  tx := f'(x);  where note local variables appearing
# in f(x) are treated as functions of x.  
#
# The hard part is simplification (optimizaton) of the resulting code.
# The GRADIENT routine will do several optimizations of computation sequences.
# It will try to identify statically which local variables are constants,
# and hence differentiate to zero.  It will do constant folding, i.e.
# an assignment to a temporary t of a numerical constant or variable
# will be substituted for in the procedure.
# The global variable constant_folding (default true) specifies whether
# constant folding is done or not.
# Note, constant folding is not done for procedures containing for loops
# or if statements because this is more difficult to do.
# The GRADIENT routine does not attempt to do common subexpression optimization.
# It is planned that Maple's optimize routine will do this.
#
# Author: Walter Neuenschwander Mar/92
#
# Comments about manipulation of procedure bodies
#
# 1: Make ERROR, RETURN, next and break statements to reduce errors
# 2: Need type/math that returns false for seq, `if`, degree etc.
# 3: For map, type, convert still have double evaluation of arguments
# 4: It would be nice if op(5,proc) returned the procedure body
# 5: It would be nice if indets worked on statements
# 6: Bug? indets(a[i],string) ==> {} instead of {a,i}
#

macro(
        INTNEG = 1,
        INTPOS = 2,
        RATIONAL = 3,
        FLOAT = 4,
        NAME = 5,
        TABLEREF = 6,
        CATENATE = 7,
        POWER = 8,
        PROD = 9,
        SERIES = 10,
        SUM = 11,
        FUNCTION = 12,
        UNEVAL = 13,
        EQUATION = 14,
        INEQUAT = 15,
        LESSEQ = 16,
        LESSTHAN = 17,
        AND = 18,
        NOT = 19,
        OR = 20,
        EXPSEQ = 21,
        LIST = 22,
        LOCAL = 23,
        PARAM = 24,
        PROC = 25,
        RANGE = 26,
        SET = 27,
        TABLE = 28,
        ASSIGN = 29,
        FOR = 30,
        IF = 31,
        READ = 32,
        SAVE = 33,
        STATSEQ = 34,
        STOP = 35,
        HASH = 36,
        HASHTAB = 37 );

macro( A=addressof, P=pointto );

# Utility routines for type testing of statements, locals and parameters
# Note: the functions op, nops, subsop work for statements
`type/break` := proc(x) evalb( x = 'break' ) end:
`type/ERROR` := proc(x) type(x,function) and op(0,x)=`ERROR` end:
`type/if` := proc(x) evalb( disassemble( A(x) )[1] = IF ) end:
`type/:=` := proc(x) evalb( disassemble( A(x) )[1] = ASSIGN ) end:
`type/for` := proc(x) evalb( disassemble( A(x) )[1] = FOR ) end:
`type/local` := proc(x) evalb( disassemble( A(x) )[1] = LOCAL ) end:
`type/lprint` := proc(x) type(x,function) and op(0,x)=lprint end:
`type/next` := proc(x) evalb( x = 'next' ) end:
`type/param` := proc(x) evalb( disassemble( A(x) )[1] = PARAM ) end:
`type/print` := proc(x) type(x,function) and op(0,x)=print end:
`type/RETURN` := proc(x) type(x,function) and op(0,x)='RETURN' end:
`type/statseq` := proc(x) evalb( disassemble( A(x) )[1] = STATSEQ ) end:
`type/quote` := proc(x) local `"""quotes`;
	type(x,string) and (x = substring(`"""quotes`,1..1) or
			    x = substring(`"""quotes`,1..2) or
			    x = substring(`"""quotes`,1..3))
end:

`convert/if` := proc(x) local t;
	P( assemble( IF, seq(A(t),t=x) ) ) end:
`convert/function` := proc(f,a)
	if not type(a,list) then ERROR(`internal error: list expected`) fi;
	P( assemble( FUNCTION, A(f), disassemble(A(a))[2] ) ) end:
`convert/indexed` := proc(f,a) 
	if not type(a,list) then ERROR(`internal error: list expected`) fi;
	P( assemble( TABLEREF, A(f), disassemble(A(a))[2] ) ) end:
`convert/statseq` := proc(x) local s,t;
	s := [seq( `if`( `type/statseq`(t), op(t), t ), t=x )];
	P( assemble( STATSEQ, seq( A(t), t=s ) ) ) end:

# Correct bug in library definition of diff/sqrt
`diff/sqrt` := proc(a,x) diff(a,x)/2/sqrt(a) end:

# Define utility routines to teach diff about miscellaneous functions
proc() local f;
    for f in '[trunc,ceil,floor,round,signum]' do
	`diff/`.f := proc(a,x) 0 end
    od:
end():
proc() local f;
    for f in '[collect,evalf,expand,factor,normal,simplify]' do
        `diff/`.f := subs(F=f,
    proc(a) local x; x := args[nargs]; 'F'(diff(a,x),args[2..nargs-1]) end);
    od:
end():

constant_folding := true: # flag for constant folding
include_funcval  := false:# flag for generating the grad. and func. value
generate_array   := false:# flag for generating `JACOBIAN/params`
taylor_hess      := false:# flag for generating taylor-coefficients or hessian
return_taylor    := false:# flag for generating an array of taylor-coeffs.
return_hess      := false:# flag for generating an matrix for hessian of f
for_jacobian     := false:

GRADIENT := proc(p) 
      local indeps,params,locals,body,deltavar,vars,oldvars,gvars,t,grd,jac,
            glocvr,gprovr,temps,funcs,j,k,l,lf,depends,derivs,AllVars,
            NrOfIndeps,OrigArr,LocProc,ArrVars, arrvar;
      global include_funcval, generate_array, `GRADIENT/Taylor`,
	    `GRADIENT/CFOLD`, `GRADIENT/LOCALS`, `GRADIENT/GNAME`,
	    `GRADIENT/RetType`, `GRADIENT/ArrRang`, `GRADIENT/RetVal`,
            `GRADIENT/NrOfFuncs`, array_flag, `LocalProcs/Vars`,
            `GRADIENT/lofuvar`, `GRADIENT/GrdVar`, `GRADIENT/JacoVars`,
            `GRADIENT/JacobiName`, `GRADIENT/SUBSTS`, `GRADIENT/Substs`,
            `GRADIENT/ArrVars`;

    if nargs = 0 then
       ERROR(`procedure 'GRADIENT' needs at least one argument`); fi;
    if (nargs = 1 or nargs = 2) and not type(args[1],procedure) then 
       ERROR(`1st argument (function) must be a procedure`,args[1]); fi;
    if nargs = 2  and not (type(args[2],integer) or type(args[2],list) or 
                           type(args[2],string)) then
       ERROR(`2nd argument must be a list of vars or a var alone`,args[2]);
    fi;
    if nargs = 2 and type(args[2],string) then 
       RETURN(procname(args[1],[args[2]]));      fi;
    if nargs =1 and type(args[1],name) then 
       RETURN( procname(eval(args[1])));         fi;
    if nargs =2 and type(args[1],name) then 
       RETURN( procname(eval(args[1]),args[2])); fi;
    # if no variable-list is given to the procedure, diff with respect to all
    if nargs = 1 then indeps := [op(1,args[1])]; fi;
    if nargs = 2 and type(args[2],integer) then
       if nops([op(1,args[1])]) < args[2] then
          ERROR(`the procedure must have at least`,args[2],` parameters`); 
       else indeps :=[op(1..args[2],[op(1,args[1])])];  fi; 
    elif nargs = 2 then indeps := args[2];
    fi;               
    # taylor-series and hessian matrices are always calculated 
    # for all variables
    if taylor_hess then indeps := args[2]; fi;

    params := [op(1,args[1])];
    locals := [op(2,args[1])];
    if ({op(indeps)} intersect {op(params)}) <> {op(indeps)} then
        ERROR(`the list of the independent variables must be a subset of`, 
              `the list of parameters passed to the procedure`,args[2]);    
    fi;

    if taylor_hess and nargs<>3 then
ERROR(`if you'd like to compute taylor-coefficients, 3 parameters are needed`);
    fi;
    if taylor_hess then 
       include_funcval := false; 
       generate_array := false; `GRADIENT/Taylor` := args[3];  fi;
    if generate_array and include_funcval then
ERROR(`it's not possible to include the function-value and generate an array`);
    fi;

    # body := op(5,p);
    body := P( disassemble(A(p))[6] );

    `GRADIENT/CFOLD`  := constant_folding;
    `GRADIENT/LOCALS` := table(); # table of all non-constant temporaries
    `GRADIENT/GNAME`  := table(); # table of all local gradients
    `GRADIENT/RetType`:= table(); # table of returned types by the loc procs
    `GRADIENT/ArrRang`:= table(); # table of arrayindex-ranges
    `GRADIENT/RetVal` := NULL;
    `GRADIENT/NrOfFuncs`:= 0;
    NrOfIndeps := nops(indeps);
    LocProc:= {};                # set of the names of local procedures
    OrigArr:= {};                # set of the names of original arrays

    array_flag := false;         # used to detect an array in recursive calls

    body := `GRADIENT/convert/compseq`(body,indeps,params,locals,
                                              'LocProc','OrigArr');
    array_flag := 'array_flag';  # reset it

    body := `GRADIENT/optimize`(body); # pre optimize it

    temps := [seq(op(t), t=[entries(`GRADIENT/LOCALS`)])]; 
    `GRADIENT/LOCALS` := temps;

    AllVars := `GRADIENT/strings`(body) union {op(locals),op(params)};
    `LocalProcs/Vars`    := {};  
    `GRADIENT/lofuvar` := NULL;  # name of temp. var. that holds the value of
                                 # a local procedure
    if LocProc <> {} then 
       body := `LocalProcs/compseq`(body,'AllVars',LocProc);
       deltavar := (`GRADIENT/strings`(body)  union {op(locals),op(params)}) 
                    minus AllVars;
       temps := [op(temps),op(deltavar)]; 
       body := `GRADIENT/optimize`(body); # re optimize it
       `GRADIENT/lofuvar`:= `GRADIENT/NewVariable`(`lf`,'AllVars');
    fi;


    body := `GRADIENT/check`(body);
    vars := `GRADIENT/strings`(body) union {op(locals),op(params)};

    glocvr := `GRADIENT/GNAMES`( subs({seq(t=NULL,t=LocProc)},
              [op({op(temps)} intersect vars)]), vars ); 
    gprovr := `GRADIENT/GNAMES`( LocProc, vars );       # new names of procs
    gvars := [op(glocvr),op(gprovr)];
    locals := [op({op(locals)} union {op(temps)})];

   # some initializations of global variables 
    AllVars  := vars union {op(gvars)};
    `GRADIENT/GrdVar`   := NULL;  # the name of the gradient variable if needed
    `GRADIENT/JacoVars` := {};    # the name of the jacobian variable if needed
    if generate_array then 
       `GRADIENT/GrdVar` := `GRADIENT/AppendGrad`(`grd`,'AllVars');
       `GRADIENT/JacobiName`   := `GRADIENT/AppendJaco`(`jac`,'AllVars');
    fi;
    `GRADIENT/SUBSTS` := {};      # set of substitutions for constant-folding
    `GRADIENT/Substs` := {};      # set of substitutions for constant-folding of
                                  # numerical gradient-components

     temps := (`GRADIENT/variables`(body) minus LocProc 
              minus {op(params)}) intersect {op(temps)};
    `GRADIENT/ArrVars` := (`GRADIENT/strings`(body) minus OrigArr minus LocProc 
                           minus {op(params)}) intersect {op(temps)};
    for arrvar in `GRADIENT/ArrVars` do 
        `GRADIENT/ArrRang`[`GRADIENT/ComposeName`(arrvar,1,false,NrOfIndeps)] := 
        [1..NrOfIndeps]; od;
    funcs := [seq( convert(l,function,indeps), l=temps )];

    depends := [seq( temps[k] = funcs[k], k=1..nops(temps) ),
                seq( seq( `GRADIENT/ComposeName`(temps[k],j,true,NrOfIndeps)
                =diff(funcs[k],indeps[j]),j=1..NrOfIndeps),k=1..nops(temps))];
                                  # change all local variables into functions
                                  # depending on the global independent variables
    derivs := [seq( funcs[k]=temps[k], k=1..nops(temps) ),
               seq( seq( diff(funcs[k],indeps[j]) = 
               `GRADIENT/ComposeName`(temps[k],j,true,NrOfIndeps),
                                          j=1..NrOfIndeps),k=1..nops(temps))];
                                  # set of substitutions for their derivatives
    body := `GRADIENT/compseq`(body,indeps,gvars,depends,derivs,
                                'AllVars',LocProc,OrigArr); 
                                  # differentiate the procedure-body
    body := P( assemble( STATSEQ, seq(A(t),
                                t=[`GRADIENT/GradInit`(NrOfIndeps),body]) ));
                                  # prepend array-initializations if needed
    body := `GRADIENT/optimize`(body); # post optimize the procedure-body

    vars := `GRADIENT/strings`(body) union {op(locals),op(params)};

    locals := `GRADIENT/strings`(body) intersect ({op(locals),op(gvars)} 
              union {`GRADIENT/GrdVar`} union `GRADIENT/JacoVars` 
              union `LocalProcs/Vars`);

    locals := op(sort([op(locals)],lexorder)); 

    params := op(params);
    # P( assemble( PROC, A(params), A(locals), A(op(3,p)), A(), A(body) ) )
    subs( ['BODY'=body,'LOCALS'=locals,'PARAMS'=params],
	     proc(PARAMS) local LOCALS; BODY end )
    # transform the whole differentiated sequence into a correct maple-procedure
end:

# Do the following optimizations
# 1: remove redundant RETURN statements from the end of a procedure
# 2: remove redundant temporary assignments - arising from constant folding
# 3: remove redundant statements - arising from repeated differentiation
# 4: a := f(x); b := f(x); ==> a := f(x); b := a

`GRADIENT/optimize` := proc(b) local a,d,i,n,t,ds;
    if nargs > 1 then ERROR(`internal error: should be no sequences`)
    elif nargs = 0 then RETURN()
    elif `type/:=`(b) then op(2,b)
    elif `type/RETURN`(b) and nops(b) = 1 then op(b)
    elif `type/if`(b) then
	n := nops(b);
	t := NULL;
	for i from 2 by 2 to n do t := t, op(i-1,b), procname(op(i,b)) od;
        if n mod 2 = 1 and n > 1 then t := t, procname(op(nops(b),b)) fi;
	P( assemble( IF, seq( A(i), i=t ) ) )
    elif `type/statseq`(b) then
	n := nops(b); 
	if n = 0 then RETURN( b ) fi;
	t := [seq( op(i,b), i=1..n-1 ), procname(op(n,b)) ];
        # Start from last statement going backwards through t
	d := `GRADIENT/variables`(t[n]);
        ds:= `GRADIENT/strings`(d);
	for i from n-1 by -1 to 1 do
	    if type(t[i],`:=`) then

	          if type(op(1,t[i]),indexed) and not (member(op(1,t[i]),d) or 
                               member(`GRADIENT/GetName`(op(1,t[i])),d)) then
		    t := subsop(i=NULL,t);
                  elif type(op(1,t[i]),string) and not member(op(1,t[i]),ds) then 
		    t := subsop(i=NULL,t);
	          elif t[i] = t[i+1] and not has(op(2,t[i]),op(1,t[i])) then
		    t := subsop(i=NULL,t);
	          elif type(t[i+1],`:=`) and op(2,t[i]) = op(2,t[i+1]) and
		    	   not has(op(2,t[i]),op(1,t[i])) and
		           not type(op(2,t[i]),{numeric,string}) and
                           not (type(op(2,t[i]),function) and op(0,op(2,t[i]))='array')
                       then
		    a := P( assemble(ASSIGN, A(op(1,t[i+1])), A(op(1,t[i]))));
		    t := subsop(i+1=a,t);
                
               
	        elif op(1,t[i]) = t[i+1] then
		    t := subsop(i=op(2,t[i]),i+1=NULL,t);
		    d := `GRADIENT/variables`(t[i]);
                    ds:= `GRADIENT/strings`(d);
                elif type(t[i+1],`:=`) and type(op(2,t[i]),function) and
                     has(indets(op(2,t[i+1]),function),op(2,t[i])) and
                     op(0,op(2,t[i]))<>'array' then
                    a := P( assemble(ASSIGN,A(op(1,t[i+1])), 
                                A(subs(op(2,t[i])=op(1,t[i]),op(2,t[i+1])))));
		    t := subsop(i+1=a,t);
	        else d := d minus {op(1,t[i])} 
                            union `GRADIENT/variables`(op(2,t[i]));
                     ds := ds minus {op(1,t[i])} union `GRADIENT/strings`(op(2,t[i]));
	        fi                       
	    else
		if `GRADIENT/assigned`(t[i]) intersect ds = {} and
		    not has(t[i],'RETURN') then 
                     t := subsop(i=NULL,t)
		else d := d union `GRADIENT/variables`(t[i]);
                     ds := `GRADIENT/strings`(d);
		fi;
	    fi
	od;
	P( assemble( STATSEQ, seq( A(i), i=t ) ) )
    else b
    fi;
end:

# save the return-type of a local procedure in the variable `GRADIENT/RetVal`
`GRADIENT/SetRetVal` := proc(a)
global `GRADIENT/RetVal`;
    if `GRADIENT/RetVal` = NULL then `GRADIENT/RetVal` := a;
    elif `GRADIENT/RetVal` <> a then 
         ERROR(`The Type of the returned value isn't always the same`);
    fi;
end:

`GRADIENT/compseq` := proc(c,indeps,gvars,depends,derivs,
                           AllVars,LocProc,OrigArr)        local t,v;
    if `type/:=`(c) then        
       `GRADIENT/:=`(c,indeps,depends,derivs,'AllVars',LocProc,OrigArr)
    elif `type/statseq`(c) then 
       `GRADIENT/statseq`(c,indeps,gvars,depends,derivs,
                          'AllVars',LocProc,OrigArr)
    elif `type/if`(c) then      
       `GRADIENT/if`(c,indeps,gvars,depends,derivs,'AllVars',LocProc,OrigArr)
    elif `type/for`(c) then     
       `GRADIENT/for`(c,indeps,gvars,depends,derivs,'AllVars',LocProc,OrigArr)
    elif `type/RETURN`(c) then  
       `GRADIENT/RETURN`(c,indeps,depends,derivs,'AllVars',LocProc,OrigArr)
    elif `type/ERROR`(c) then   c
    elif `type/print`(c) then   c
    elif `type/lprint`(c) then  c
    elif `type/break`(c) then   c
    elif `type/next`(c) then    c
    else t := `GRADIENT/expr`(c,indeps,depends,derivs,
                              'AllVars',LocProc,OrigArr);
         if generate_array then
	    if has(OrigArr,c) then 
	       `GRADIENT/SetRetVal`([`GRADIENT/ArrRang`[c]]);
            else `GRADIENT/SetRetVal`([1]);
            fi;
            P( assemble( STATSEQ, seq( A(v) , v =[t] ))) 
         elif nops([t]) <> 1 then
	    `GRADIENT/SetRetVal`([nops([t])]);
            if type(c,function) and has(LocProc,op(0,c)) then t; 
            elif return_taylor then t;
            else 'RETURN'(t) fi;
         else if has(OrigArr,c) then
	         `GRADIENT/SetRetVal`([`GRADIENT/ArrRang`[c]]);
              else `GRADIENT/SetRetVal`([1]);
              fi;
            t 
         fi;
    fi
end:

`GRADIENT/RETURN` := proc(c,indeps,depends,derivs,AllVars,LocProc,OrigArr) 
               local r,s,t,u,v,i,j,sequ,t2,t3,w;
global `GRADIENT/NrOfFuncs`;
    sequ := NULL;
    if generate_array then    # if this flag is true, then return an array
       t := [seq(t , t=c)];   # instead of sequence
       `GRADIENT/SetRetVal`([nops(t)]);
       for i to nops(t) do
           r := [`GRADIENT/expr`(t[i],indeps,depends,derivs,
                                 'AllVars',LocProc,OrigArr)];
           s := `GRADIENT/JacobiName`;
           if `GRADIENT/NrOfFuncs` = 0 then `GRADIENT/NrOfFuncs` := nops(t);
           elif `GRADIENT/NrOfFuncs` <> nops(t) then
ERROR(`the number of RETURNed-values must be the same for the whole program`);
           fi;
           t3 := NULL;
           if nops(indeps)=1 or nops(r)=1 then 
              t3 := P( assemble( ASSIGN, A(s[i,1]),A(op(2,op(1,r)) ) ));
           else
               for j to nops(indeps) do
                   t3 := t3, P( assemble( ASSIGN, A(s[i,j]), 
                                                  A(op(2,op(j,r)))  ));
               od;
           fi;
           sequ := sequ , t3;
       od;
       t2 := P( assemble( ASSIGN, A(op(`GRADIENT/JacoVars`)) , 
                A('array'(1..`GRADIENT/NrOfFuncs`,1..nops(indeps)) ))); 
       RETURN(P( assemble( STATSEQ, seq( A(v) , v= [t2,sequ, s]))) );
    else if taylor_hess then  # GRADIENT-function is called from TAYLOR or HESSIAN
            for i to nops(indeps) do w[i] := NULL; od;
            t := [seq(t , t=c)];
            for j to nops(t) do
                sequ := [`GRADIENT/expr`(t[j],indeps,depends,derivs,
                                         'AllVars',LocProc,OrigArr)] ;
                for i to nops(indeps) do w[i] := w[i],op(i,sequ);  od;
            od;
            sequ := NULL;
            for i to nops(indeps) do sequ := sequ,w[i]; od;
            if not return_hess then 
               t :=op(subsop(seq(v=NULL,v=`GRADIENT/Taylor`),[op(c),sequ]));
            fi;
            if return_taylor then  # return an array of arrays 
               RETURN(`GRADIENT/TaylorReturn`([t],nops(indeps),'AllVars'));
            elif return_hess then  # return the hessian-matrix of f
               RETURN(`GRADIENT/HessianReturn`([sequ],nops(indeps),'AllVars'))
            fi;
         else t := seq(`GRADIENT/expr`(t,indeps,depends,derivs,
                                       'AllVars',LocProc,OrigArr), t=c); 
         fi;
         if nops([t]) <> 1 then `GRADIENT/SetRetVal`([nops([t])]);
         elif has(OrigArr,c) then `GRADIENT/SetRetVal`([`GRADIENT/ArrRang`[c]]);
         fi;
         'RETURN'(t);
    fi;
end:

`GRADIENT/expr` := proc(c,indeps,depends,derivs,AllVars,LocProc,OrigArr) 
             local r,tmp,i,left,gleft,t,v,NrOfIndeps;
global `GRADIENT/GNAME`, `GRADIENT/ArrVars`, `GRADIENT/ArrRang`;
    tmp := c;
    NrOfIndeps := nops(indeps);
    if `GRADIENT/CFOLD` then tmp := subs( `GRADIENT/SUBSTS`, tmp ) fi;
    if type(tmp,string) and has(OrigArr,tmp) then
          r := `GRADIENT/GNAME`[tmp];      # if the mathematical expression is only a
          r := subs(`GRADIENT/Substs`,r);  # name, then return its "gradient-name"
    elif type(tmp,function) and has(LocProc,op(0,tmp)) then
       left := `GRADIENT/NewVariable`(`t`,'AllVars');
       gleft:= `GRADIENT/NewVariable`(`t`,'AllVars');
       `GRADIENT/GNAME`[left] := gleft;
       r := `GRADIENT/DiffaLocalFunc`(left,tmp,indeps,depends,derivs,
                                           'AllVars',LocProc,OrigArr);
       if generate_array or NrOfIndeps > 1 then
          `GRADIENT/ArrVars` := `GRADIENT/ArrVars` union {left}; 
          `GRADIENT/ArrRang`[left] := [1..NrOfIndeps]; fi;
       if generate_array or NrOfIndeps=1 or
          nops(`GRADIENT/ArrRang`[gleft]) > 1 then r := r, gleft;
       else r := r, 'RETURN'(seq(gleft[i],i=1..NrOfIndeps)); 
       fi;
    else 
       r := `GRADIENT/gradientcalc`(tmp,indeps,depends,derivs);
       r := subs(`GRADIENT/Substs`,r);
       if generate_array then 
          `GRADIENT/ArrRang`[`GRADIENT/GrdVar`] := [1..nops(r)];
          r := seq(P(assemble(ASSIGN,A(`GRADIENT/GrdVar`[i]),
                                       A(r[i]))),i=1..nops(r)),`GRADIENT/GrdVar`;
       elif return_taylor and not taylor_hess then 
          RETURN(`GRADIENT/TaylorReturn`([tmp,op(r)],NrOfIndeps,'AllVars'))
       else r := op(r);
       fi;
    fi;
    if include_funcval and not taylor_hess then RETURN(tmp,r) else RETURN(r) fi;
end:

# generate the necessary statments to return the correct array of 
# "derivative"-arrays without redundant derivatives!
`GRADIENT/TaylorReturn` := proc(s,NrOfIndeps,AllVars) 
                     local k,top,t1,init,r,a,t2,i,t;
    k := 1;
    top := NrOfIndeps;
    t1 := `GRADIENT/NewVariable`(`t`,'AllVars');
    init := 'array'(1..`TAYLOR/Degree`+1);
    r := P(assemble(ASSIGN,A(t1),A(init))),
         P(assemble(ASSIGN,A(t1[1]),A(s[1])));
    a := 1;
    while k <= `TAYLOR/Degree` do
       t2 := `GRADIENT/NewVariable`(`t`,'AllVars');
       init := 'array'(1..top);
       r := r , P(assemble(ASSIGN,A(t2),A(init))) ,
                seq(P(assemble(ASSIGN,A(t2[i]),A(s[a+i]))),i=1..top),
                P(assemble(ASSIGN,A(t1[k+1]),A(t2)));
       a := a + top;
       top := top*(NrOfIndeps+k)/(k+1);
       k := k+1;
   od;
   RETURN(r,t1);
end:

# generate the necessary statments to return the correct matrix of 
# the computed derivatives. Compute only the upper triangular matrix!
`GRADIENT/HessianReturn` := proc(s,NrOfIndeps,AllVars) 
                      local i,j,t1,init,r,t;
    t1 := `GRADIENT/NewVariable`(`t`,'AllVars');
    init := 'array'(1..NrOfIndeps,1..NrOfIndeps);
    r := P(assemble(ASSIGN,A(t1),A(init)));
    for i to NrOfIndeps do
        for j from i to NrOfIndeps do
            r := r , P(assemble(ASSIGN, A(t1[i,j]),A(s[(i-1)*NrOfIndeps+j])));
            if i<>j then  r := r , P(assemble(ASSIGN, A(t1[j,i]),A(t1[i,j])));
            fi;
        od;
    od;
   RETURN(r,t1);
end:

# differentiate a statement-sequence
`GRADIENT/statseq` := proc(c,indeps,gvars,depends,derivs,
                           AllVars,LocProc,OrigArr) local s,t;
    s := [seq( `GRADIENT/compseq`(t,indeps,gvars,depends,derivs,
                                  'AllVars',LocProc,OrigArr), t=c )];
    # flatten statement sequences -- Maple should do this automatically
    s := map( proc(x) if `type/statseq`(x) then op(x) else x fi end, s );
    P( assemble( STATSEQ, seq( A(t), t=s ) ) )
end:

# differentiate an if-statement
`GRADIENT/if` := proc(c,indeps,gvars,depends,derivs,AllVars,LocProc,OrigArr) 
           local i,t,Substsave,v;
global `GRADIENT/Substs`;
    t := NULL;
    Substsave := copy(`GRADIENT/Substs`);     # save the substitutions 
    for i from 2 by 2 to nops(c) do
	t := t, op(i-1,c),  
             `GRADIENT/compseq`(op(i,c),indeps,gvars,depends,
                                                 derivs,'AllVars',LocProc,OrigArr);
        `GRADIENT/Substs` := copy(Substsave); # reinit the substitutions
    od;
    if nops(c) mod 2 = 1 and nops(c) > 1 then
       t := t, 
            `GRADIENT/compseq`(op(nops(c),c),indeps,gvars,depends,derivs,
                                  'AllVars',LocProc,OrigArr);
    fi;
    `GRADIENT/Substs` := {};
    P( assemble( IF, seq( A(i), i=t ) ) )
end:

# differentiate a for-statement
`GRADIENT/for` := proc(c,indeps,gvars,depends,derivs,AllVars,LocProc,OrigArr) 
                  local t;
global `GRADIENT/Substs`;
    `GRADIENT/Substs` := {};   # clear all substitutions !!!
    if nops(c) = 4 then ERROR(`cannot differentiate a for in loop`) fi;
    t := `GRADIENT/compseq`(op(nops(c),c),indeps,gvars,depends,derivs,
                            'AllVars',LocProc,OrigArr);
    subsop( nops(c)=t, c );
end:

# the most important part of the whole program:
# the use of Maple's "diff" makes it much easier 
`GRADIENT/diff` := proc(c,x,depends,derivs) local t;
    t := subs(depends,c);   # replace all local variables with their functions
    t := diff(t,x);         # differentiate the expression with respect to "x"
    t := subs(derivs,t);    # substitute the generated formal derivatives
    if has(t,{diff,D}) then ERROR(`cannot differentiate`,c) fi;
    if `GRADIENT/CFOLD` then t := subs(eval(`GRADIENT/SUBSTS`,1),t) fi;
    t
end:

# compute the gradient component-wise
`GRADIENT/gradientcalc` := proc(right,indeps,depends,derivs) local gxi,dep,s;
       gxi := [];
       # calculate each component of the gradient
       for dep in indeps do
          s := `GRADIENT/diff`(right,dep,depends,derivs);
          gxi := [op(gxi), s];
       od; 
    gxi;
end:

# compute the gradient of an assigment-statement
`GRADIENT/:=` := proc(a,indeps,depends,derivs,AllVars,LocProc,OrigArr) 
           local left,right,c,i,j,t1,t2,gxi,NrOfIndeps;
global `GRADIENT/RetType`, `GRADIENT/RetVal`, `GRADIENT/SUBSTS`;
    left := op(1,a);
    right := op(2,a); 
    NrOfIndeps := nops(indeps);
    if type(right,function) and op(0,right)='array' then
       t2 := P( assemble( ASSIGN, 
                          A(`GRADIENT/ComposeName`(left,1,false,NrOfIndeps)),
                          A(`GRADIENT/DiffanArray`(right,NrOfIndeps))));
    elif type(right,function) and has(LocProc,op(0,right)) then
       t2 := `GRADIENT/DiffaLocalFunc`(left,right,indeps,depends,derivs,
                                       'AllVars',LocProc,OrigArr);
    else
       if type(op(2,a),procedure)  then 
          gxi := `GRADIENT/DiffaProcedure`(op(2,a));
	  `GRADIENT/RetType`[left] := `GRADIENT/RetVal`; 
          `GRADIENT/RetVal` := NULL;
          t2 := P(assemble(ASSIGN,
                   A(`GRADIENT/ComposeName`(left,1,false,NrOfIndeps)),
                   A(op(gxi)) ));
       else
          if `GRADIENT/CFOLD` then
             c := eval(`GRADIENT/SUBSTS`,1);
             right := subs(c,right);
             for i to nops(c) do
                 if op(1,c[i]) = left then c := subsop(i=NULL,c); break fi od;
             if type(right,numeric) then c := c union {left = right} fi;
             if has(right,indeps) and type(right,function) then 
                c := c union {right = left} fi;
         fi;
         if `GRADIENT/CFOLD` then `GRADIENT/SUBSTS` := c fi;
         if not member(left,eval(`GRADIENT/LOCALS`,1)) then RETURN( a ) fi;
         gxi := `GRADIENT/gradientcalc`(right,indeps,depends,derivs);
         gxi := subs(`GRADIENT/Substs`,gxi);
         gxi := subs(`GRADIENT/SUBSTS`,gxi);
         `GRADIENT/SearchConsts`(gxi,left,NrOfIndeps);
      
         t2 := seq( P( assemble( ASSIGN, 
                            A(`GRADIENT/ComposeName`(left,j,true,NrOfIndeps)),
                            A(gxi[j]) )), j=1..NrOfIndeps);
      fi;
    fi;
    t1 := P( assemble( ASSIGN, A(left), A(op(2,a)) ) );
    P( assemble( STATSEQ, seq( A(i), i=[t2,t1] ) ) );
end:

# if an indexed variable is to differentiate, one has to define a new
# variable with a additional index
`GRADIENT/ComposeName` := proc(nam,comp,yesno,NrOfIndeps)
                          local gname,name4,index2; 
global `GRADIENT/splitindexes`;
    `GRADIENT/splitindexes` := proc(name1) local name2,name3,index1;
        if type(name1,indexed) then
           name2 := op(0,name1); 
           index1 := op(name1);
           # index1 := op(1..nops(name1),name1);
           name3 := `GRADIENT/splitindexes`(name2);
           name3[index1];
        else `GRADIENT/GNAME`[name1];
        fi;
    end:

    gname := `GRADIENT/splitindexes`(nam); index2 := NULL;
    if type(gname,indexed) then 
       name4 := op(0,gname); 
       index2 := op(gname);
       # index2 := op(1..nops(gname),gname); 
    else name4 := gname; fi;
    index2 := index2,comp;
    if (generate_array or NrOfIndeps > 1) and yesno then
      `convert/indexed`(name4,[index2]);     # name4[index2];
    else gname; fi; 
end:

# search the gradient-components, that are numerical values and
# store them in the substitution-set `GRADIENT/Substs`
`GRADIENT/SearchConsts` := proc(gxi,left,NrOfIndeps) local comp,wert,i,nam;
global `GRADIENT/splitindexes`, `GRADIENT/Substs`;
    for comp to NrOfIndeps do
        wert := op(comp,gxi);
        nam := `GRADIENT/ComposeName`(left,comp,true,NrOfIndeps);
        for i to nops(`GRADIENT/Substs`) do
            if op(1,op(i,`GRADIENT/Substs`))=nam then
               `GRADIENT/Substs` := subsop(i=NULL,`GRADIENT/Substs`); break;
            fi;
        od;
        if type(wert,numeric) then
           `GRADIENT/Substs`:=`GRADIENT/Substs` union {nam=wert};
        fi;
    od;
end:

# differentiate an array-definition by adding an new index-range, such
# that the dimension of the array grows by 1
`GRADIENT/DiffanArray` := proc(ArrTyp,NrOfIndeps) local IndexRange,IndexTyp;
    if disassemble( A(ArrTyp))[1] = 12 then  # disassemble was necessary,cause
       IndexTyp := P( disassemble( A(ArrTyp))[2]); # Maple always tried to 
    else                    # evaluate the arraybounds. This leads to an error
       IndexTyp := 'array'; # if they aren't numerical values !!
    fi;
    IndexRange := P( disassemble( A(ArrTyp))[3]);
    if generate_array or NrOfIndeps > 1 then 
       IndexRange := IndexRange,1..NrOfIndeps; fi;
    `convert/function`(IndexTyp,[IndexRange]);
end:

# differentiate a functioncall of a local defined procedure
# handle this specially in order to compute the total derivative correctly
`GRADIENT/DiffaLocalFunc` := proc(left,right,indeps,depends,derivs,AllVars) 
                    local sequ,j,params,t,i,res,t1,t2,t3,gxi,nam,ind,range,r,
                          botran,topran,loopvars,s,NrOfIndeps,typ,constsubs;
global `GRADIENT/ArrRang`, `GRADIENT/SUBSTS`;
    NrOfIndeps := nops(indeps);
    params := [op(right)];
    gxi := [];
    typ := `GRADIENT/RetType`[op(0,right)];

#    if not type(op(`GRADIENT/RetType`[op(0,right)]),{integer,string}) then

#    if params=indeps then
#       # if the parameters passed to the local function are the same as the
#       # independent variables (include same order), then do nothing special !
#       RETURN( P( assemble( ASSIGN, 
#                A(`GRADIENT/ComposeName`(left,1,false,NrOfIndeps)),
#                A(convert(`GRADIENT/ComposeName`(op(0,right),1,false,NrOfIndeps),
#                   function,params)))));
     if nops(typ) <> 1 or not type(op(typ),{integer,string}) then
       # if the local procedure returns a sequence of values, then compute
       # the total derivative of this "vector" !
       range := typ;
       loopvars := [];
       for j to nops(range) do 
           loopvars := [op(loopvars) , `GRADIENT/NewVariable`(`i`,'AllVars')]; 
           botran[j] := op(1,range[j]); topran[j] := op(2,range[j]);
       od;
       t1 := P( assemble( ASSIGN, A(`GRADIENT/lofuvar`),
              A(convert(`GRADIENT/ComposeName`(op(0,right),1,false,NrOfIndeps),
                        function,params))));
       # define an array with correct dimensions, to store the "gradient"
       # this array-definition will be deleted by the optimization if not needed!
       if generate_array or NrOfIndeps > 1 then
# keep attention !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

          t2 := P( assemble( ASSIGN,
                   A(`GRADIENT/ComposeName`(left,1,false,NrOfIndeps)),
                   A('array'(op(typ),1..NrOfIndeps))));
          `GRADIENT/ArrRang`[`GRADIENT/ComposeName`(left,1,false,NrOfIndeps)] :=
                   [op(typ),1..NrOfIndeps];
       else
          t2 := P( assemble( ASSIGN,
                   A(`GRADIENT/ComposeName`(left,1,false,NrOfIndeps)),
                   A('array'(op(typ)))));
          `GRADIENT/ArrRang`[`GRADIENT/ComposeName`(left,1,false,NrOfIndeps)] :=
                   [op(typ)];
       fi;
t2 := NULL;
       # differentiate each parameter passed to the local function wrt "indeps"
       for i to nops(params) do   
           res[i] := `GRADIENT/gradientcalc`(params[i],indeps,depends,derivs);od;
       t3 := NULL;
       for j to nops(indeps) do 
           s := 0;
           for i to nops(params) do 
               s := s + (`GRADIENT/lofuvar`[op(loopvars),i])*res[i][j]; 
           od;
           if type(s,numeric) then `GRADIENT/SUBSTS` := `GRADIENT/SUBSTS` union
              {`GRADIENT/ComposeName`(left[op(loopvars)],j,true,NrOfIndeps) = s};
           fi;
           t3 := t3, P(assemble(ASSIGN,A(`GRADIENT/ComposeName`(
                       left[op(loopvars)],j,true,NrOfIndeps)),A(s)));
       od;
       t3 := P( assemble( STATSEQ, seq(A(i),i=[t3])));
       # generate a "for"-loop in order to compute the total derivative
       for j from nops(range) by -1 to 1 do
           t3 := P( assemble( FOR, A(loopvars[j]),A(botran[j]),A(1),
                                   A(topran[j]),A(true),A(t3)));
       od;
       RETURN(t1,t2,t3);
    else
       # the local procedure returns an array or a value in this case !!
       # keep attention in using the correct indices !!!
       for i to nops(params) do
             nam := `GRADIENT/ComposeName`(op(0,right),i,true,NrOfIndeps);
             if NrOfIndeps > 1 then ind := [op(nam)]
             else ind := [i]; fi;
             gxi := [op(gxi) , `convert/indexed`(`GRADIENT/lofuvar`,ind) ];
       od;
       sequ := array(1..nops(indeps),[seq(0,t=1..nops(indeps))]);
       t1 := P( assemble( ASSIGN, A(`GRADIENT/lofuvar`),
                 A(convert(`GRADIENT/ComposeName`(op(0,right),1,false,NrOfIndeps),
                   function,params))));
       for i to nops(params) do 
              res := `GRADIENT/gradientcalc`(params[i],indeps,depends,derivs); 
              for j to nops(indeps) do
                  sequ[j] := sequ[j] +gxi[i]*res[j];
              od;
       od;
 
       for j to NrOfIndeps do
           if type(sequ[j],numeric) then `GRADIENT/SUBSTS` := `GRADIENT/SUBSTS` union
              {`GRADIENT/ComposeName`(left,j,true,NrOfIndeps) = sequ[j]};
           fi;
       od;
       t3 := seq( P( assemble( ASSIGN, 
                     A(`GRADIENT/ComposeName`(left,j,true,NrOfIndeps)), 
                     A(sequ[j]) )), j=1..NrOfIndeps);
       RETURN(t1,t2,t3);
    fi;
end:

# if one has to differentiate a local procedure, then one has to store all global 
# variables, such that they can be reinstalled after the recursive call !
`GRADIENT/DiffaProcedure` := proc(p) local stack,q;
global constant_folding, include_funcval, generate_array, taylor_hess ,
       return_taylor, return_hess, for_jacobian, `GRADIENT/NrOfFuncs`,
       `GRADIENT/CFOLD`, `GRADIENT/lofuvar`, `GRADIENT/GrdVar`,
       `GRADIENT/SUBSTS`, `GRADIENT/Substs`, `GRADIENT/LOCALS`,
       `GRADIENT/GNAME`, `GRADIENT/RetType`, `GRADIENT/ArrRang`,
       `LocalProcs/Vars`, `GRADIENT/ArrVars`;
  
     # constant_folding;       # Flag for constant folding
     # expression_split;       # Flag for searching common subexpressions
     # generate_array;         # Flag for generating arrays 
     # `GRADIENT/NrOfIndeps`;  # Number of independent variables
     # `GRADIENT/NrOfFuncs`;   # Number of computed functions
     # `GRADIENT/CFOLD`;       # Global variable for constant folding
     # copy(`GRADIENT/LOCALS`);# List of local variables
     # LocProc;                # Set of the names of the local procedures
     # AllVars;                # Set of all variables occuring in the program
     # copy(`GRADIENT/GNAME`); # List of the gradient names of the local variables
     # `GRADIENT/GrdVar` ;     # Set of the variables wich are arrays
     # `GRADIENT/JacoVars`;    # Set of the Jacobian variables
     # OrigArr;             # Set of the variables which are arrays in orig. prog.
     # `GRADIENT/SUBSTS`;      # Set of substitutions
     # `GRADIENT/Substs`;      # Set of numeric substitutions
     # `LocalProcs/Vars`;      # Set of vars. needed to seperate local func.-calls
     # `GRADIENT/derivs`;      # List of substitution needed to diff correctly
     # `GRADIENT/depends`;     # List of resubstitutions after the differentiation
     # copy(`GRADIENT/ArrRang`);  # Indexranges of original array-variables
     # `GRADIENT/lofuvar`;     # Name of the var. needed for a gradient func.-call
     # copy(`GRADIENT/RetType`);  # Table of names of procs. and their returntypes
     # `GRADIENT/RetVal`;      # Type of the return-value of a local procedure
    stack[1] := constant_folding;
    stack[2] := include_funcval ;
    stack[3] := generate_array  ;
    stack[4] := taylor_hess     ;    
    stack[5] := return_taylor   ;
    stack[6] := return_hess     ;
    stack[7] := for_jacobian    ;
    stack[8] := `GRADIENT/NrOfFuncs`  ;
    stack[9] := `GRADIENT/CFOLD`      ;    
    stack[10] := `GRADIENT/lofuvar`    ;
    stack[11] := `GRADIENT/GrdVar`     ;
    stack[12] := `GRADIENT/SUBSTS`     ;    
    stack[13] := `GRADIENT/Substs`     ;
    stack[14] := copy(`GRADIENT/LOCALS`);
    stack[15] := copy(`GRADIENT/GNAME`);
    stack[16] := copy(`GRADIENT/RetType`);
    stack[17] := copy(`GRADIENT/ArrRang`);
    stack[18] := `LocalProcs/Vars`;
    stack[19] := `GRADIENT/ArrVars`;

    constant_folding := true;    # always true for local procedures !
    include_funcval  := false;   # always false !
    generate_array   := true;    # always true in order to fix the return-typ
    taylor_hess      := false;   # compute just the gradient of the
    return_taylor    := false;   # local procedure
    return_hess      := false;   # don't use them to compute hessian-matrices or
    for_jacobian     := false;   # taylor-coefficients
    q := GRADIENT(p);
    constant_folding := stack[1];
    include_funcval  := stack[2];
    generate_array   := stack[3];
    taylor_hess      := stack[4];    
    return_taylor    := stack[5];
    return_hess      := stack[6];
    for_jacobian     := stack[7];
    `GRADIENT/NrOfFuncs`   := stack[8];
    `GRADIENT/CFOLD`       := stack[9];    
    `GRADIENT/lofuvar`     := stack[10];
    `GRADIENT/GrdVar`      := stack[11];
    `GRADIENT/SUBSTS`      := stack[12];    
    `GRADIENT/Substs`      := stack[13];
    `GRADIENT/LOCALS`      := copy(stack[14]);
    `GRADIENT/GNAME`       := copy(stack[15]);
    `GRADIENT/RetType`     := copy(stack[16]);
    `GRADIENT/ArrRang`     := copy(stack[17]);
    `LocalProcs/Vars`      := stack[18];
    `GRADIENT/ArrVars`     := stack[19];

    RETURN(op(q));
end:

# Given the statement/expression s, part of the body of a procedure
# replace the internal representation of local and parameter references
# with their symbolic representation, i.e. make the transformation
# LOC[i] ==> locals[i], PARAM[i] ==> params[i]
# This routine will also issue an error for cases which cannot
# be differentiated -- this includes procedures which use
# non-arithmetic data, non-formulae, indexed variable references

`GRADIENT/convert/compseq` := proc(s,x,params,locals,LocProc,OrigArr) 
    local i,l,n,p,r,t,id,fc,w,nr;
    global array_flag, `GRADIENT/NrOfFuncs`, for_jacobian,
	   `GRADIENT/LOCALS`, `GRADIENT/ArrRang`, `GRADIENT/CFOLD`;

    if nargs = 5 then ERROR(`unable to differentiate an empty sequence`)
    elif nargs > 6 then ERROR(`unable to differentiate sequences`)
    elif type(s,numeric) then s

    elif type(s,string) then
	# elif type(s,quote) then -- does not work
	if `type/quote`(s) then
	    ERROR(`unable to differentiate procedures containing quotes`) fi;
	s

    # elif type(s,{`+`,`*`,`^`}) then map(procname,args) -- does not work
    elif type(s,`+`) then
        convert( [seq( procname(t,x,params,locals,'LocProc','OrigArr'), 
                  t=[op(s)] )], `+` )

    elif type(s,`*`) then 
        convert( [seq( procname(t,x,params,locals,'LocProc','OrigArr'), 
                  t=[op(s)] )], `*` )

    elif type(s,`^`) then
        procname(op(1,s),x,params,locals,'LocProc','OrigArr')^
        procname(op(2,s),x,params,locals,'LocProc','OrigArr')

    elif type(s,function) then
        
	p := op(0,s);
	if `type/param`(p) then
	    ERROR(`cannot differentiate functional parameters`,
		   procname(p,x,params,locals,'LocProc','OrigArr')); fi;
        p := procname(p,x,params,locals,'LocProc','OrigArr');
	# if not type(p,mathfunc) then error ...
	if not type(p,{string,indexed}) then
ERROR(`bad function`,procname(p,x,params,locals,'LocProc','OrigArr')) fi;
	if p = 'table' then # or p = 'array' then
ERROR(`cannot differentiate procedures which create tables yet`) fi;
        if p = 'array' then array_flag := true; fi;
	# Dissallow functions which Maple does not know how to differentiate
	if not member(p,'{RETURN,ERROR,lprint,print,array}' 
           union eval(LocProc)) then `GRADIENT/KNOWN`(p) 
        fi;
        if p = 'RETURN' then
           if `GRADIENT/NrOfFuncs` = 0 then `GRADIENT/NrOfFuncs` := nops(s);
           elif `GRADIENT/NrOfFuncs` <> nops(s) then
ERROR(`the number of RETURNed-values must be the same for the whole program`,s);
           fi;
        fi;
        if for_jacobian and p='RETURN' and nops(s) > 1 then
           for_jacobian := false;
ERROR(`if you call the 'JACOBIAN' program, then the function mustn't return`,
  `more than one value ! In this case you can use the 'GRADIENT' program itself`);
        fi;
        if p = 'array' and has(op(1,s),x) then
ERROR(`the subscript range mustn't consist of independent variables`); fi;
        r := [seq( procname(t,x,params,locals,'LocProc','OrigArr'), t=[op(s)] )];
        r := convert( p, function, r );

    # elif type(s,`param`) then -- does not work
    elif `type/param`(s) then
        t := disassemble(A(s))[2];
        if t = 0 or t = -1 then
ERROR(`cannot differentiate procedures which use args or nargs`) fi;
        if t < 0 or t > nops(params) then
	    ERROR(`parameter subscript out of range`) fi;
        p := params[t];

    # elif type(s,`local`) then -- does not work
    elif `type/local`(s) then
        t := disassemble(A(s))[2];
        if t < 1 or t > nops(locals) then
	    ERROR(`local subscript out of range`) fi;
        l := locals[t];

    # elif type(s,`:=`) then -- does not work
    elif `type/:=`(s) then # type(s,`:=`) does not work
        # (l,r) := op(s);
        l := op(1,s); r := op(2,s);
        if not `type/local`(`GRADIENT/GetName`(l)) then
ERROR(`can only differentiate assignments to local variables`,l) fi;
        l := procname(op(1,s),x,params,locals,'LocProc','OrigArr');
    # keep attention in checking first if 'indexed'-typed? !!!!!!!
        if type(op(2,s),indexed) and type(op(0,op(2,s)),function) then
ERROR(`very bad maple code! Please try to rewrite your procedure and use a new`,
      ` variable which becomes the value of the local procedure!`);
        # don not allow function-calls that are post-indexed !
        # i.e.    a := g(x,y)[1]*g(x,y)[2];   has to be replaced by the user
        # in the following sequence:
        #         b := g(x,y);  a := b[1]*b[2];
        # this second statement-sequ. needs only one evaluation of g instead of 2
        elif type(op(2,s),procedure) then 
           LocProc := eval(LocProc) union {l};
           `GRADIENT/LOCALS`[l] := l;
           `GRADIENT/LOCALS`[`GRADIENT/GetName`(l)] := `GRADIENT/GetName`(l);
           RETURN(subsop(1=l,s));
        else
           r := procname(op(2,s),x,params,locals,'LocProc','OrigArr');
           if type(r,function) and has(eval(LocProc),op(0,r)) then 
              `GRADIENT/LOCALS`[l] := l; fi;
           if array_flag=true then 
              OrigArr := eval(OrigArr) union {l}; 
              `GRADIENT/ArrRang`[l] := op(r); array_flag := false; fi;
	   t := indets(r,name) minus {constants};
	   t :=t minus {`GRADIENT/GetName`(l)} minus ({op(params)} minus {op(x)});
	   if t <> {} or (type(r,numeric) and type(l,indexed)) then 
              if {`GRADIENT/GetName`(l)} minus {op(params)} <> {} then
                 `GRADIENT/LOCALS`[l] := l; 
                 `GRADIENT/LOCALS`[`GRADIENT/GetName`(l)] :=`GRADIENT/GetName`(l);
              fi; 
           fi;
           RETURN(P( assemble( ASSIGN, A(l), A(r) ) ));
        fi;
   
    elif type(s,logical) then 
         `GRADIENT/map`(procname,s,x,params,locals,'LocProc','OrigArr')
    elif type(s,relation) then 
         `GRADIENT/map`(procname,s,x,params,locals,'LocProc','OrigArr')
    elif type(s,range) then
	# do not call GRADIENT/map in this case because it uses seq
	procname(op(1,s),x,params,locals,'LocProc','OrigArr') .. 
        procname(op(2,s),x,params,locals,'LocProc','OrigArr')

    # elif type(s,`if`) then -- does not work
    elif `type/if`(s) then
	`GRADIENT/CFOLD` := false;
	`GRADIENT/map`(procname,s,x,params,locals,'LocProc','OrigArr')

    # elif type(s,`for`) then -- does not work
    elif `type/for`(s) then
	`GRADIENT/CFOLD` := false;
	l := op(1,s);
	if l <> NULL and not `type/local`(l) then
ERROR(`for loop index must be a local variable`,l) fi;
	t := s;
	if op(1,t) = NULL then t := subsop(1=infinity,t) fi;
	if op(4,t) = NULL then t := subsop(4=infinity,t) fi;
	t := `GRADIENT/map`(procname,t,x,params,locals,'LocProc','OrigArr');
	if l <> NULL then
	    r := indets([op(2..4,t)],name) minus {constants};
	    r := r minus ({op(params)} minus {op(x)});
	    if r <> {} then
ERROR(`for loop from, by, and to values must be constants`) fi;
	fi;
	if op(4,s) = NULL then t := subsop(4=NULL,t) fi;
	if op(1,s) = NULL then t := subsop(1=NULL,t) fi;
	t

    # elif type(s,`statseq`) then -- does not work
    elif `type/statseq`(s) then
# t := map(procname,[op(s)],x,params,locals,'LocProc','OrigArr'); does not work
        t := [seq( procname(i,x,params,locals,'LocProc','OrigArr'), i=[op(s)] )];
        if t = [] then ERROR(`empty statement sequence`) fi;
        convert(t,statseq)

    elif type(s,indexed) then
	p := op(0,s);
	p := procname(p,x,params,locals,'LocProc','OrigArr');
	if has(x,p) then ERROR(`subscript of derivative variable`,p) fi;
	if not type(p,string) then ERROR(`invalid subscript`,p) fi;
        w := [seq( procname(t,x,params,locals,'LocProc','OrigArr'), t=s )];
#        w := [];
#        for nr to nops(s) do 
#            w := [op(w) , procname(op(nr,s),x,params,locals,'LocProc','OrigArr')];
#        od;
        w := convert( p, indexed, w );
        if {`GRADIENT/GetName`(w)} minus {op(params)} <> {} then 
           `GRADIENT/LOCALS`[w] := w; 
        fi;
        w;

    else ERROR(`cannot differentiate`,s)
    fi

end:

# can't use map because of sequences e.g. a NULL value
`GRADIENT/map` := proc(f,x) local a,i,t;
    a := [seq( f(t,args[3..nargs]), t=x )];
    i := disassemble(A(x))[1];
    t := P(assemble(i,seq(A(t),t=a)));
    i := disassemble(A(t))[1];
    t
end:

# These procedure forms are disallowed as they rely on quotes
#    proc(x) local t; t := x; if x < 0 then t := t*x fi end;
#    proc(x,n) local t; t := x; to n do t := t*x od; end;
# We insert an ERROR(`no return value`) statement where appropriate
`GRADIENT/check` := proc(b) local i,n,t;
    if `type/if`(b) then
	n := nops(b);
	t := NULL;
	for i from 2 by 2 to n do t := t, op(i-1,b), procname(op(i,b)) od;
        if n mod 2 = 1 and n > 1 then t := t, procname(op(nops(b),b)) fi;
	if n mod 2 = 0 and n > 1 then t := t, 'ERROR(`no value returned`)' fi;
	P( assemble( IF, seq( A(i), i=t ) ) )
    elif `type/statseq`(b) then
	n := nops(b);
	if n = 0 then RETURN( b ) fi;
	t := [seq( op(i,b), i=1..n-1 ), procname(op(n,b)) ];
	P( assemble( STATSEQ, seq( A(i), i=t ) ) )
    elif `type/for`(b) then
	t := 'ERROR(`no value returned`)';
	P( assemble( STATSEQ, A(b), A(t) ) )
    else b
    fi
end:

# generate unique names for the local derivative variables
`GRADIENT/GNAMES` := proc(temps,vars) local i,l,n,t,d;
global `GRADIENT/GNAME`;
    for l in temps do
        n := cat(`d`,l);
        for i while member(n,vars) or assigned(t[n]) do
	    n := cat(`d`,l,i)
        od;
        t[l] := n;
        `GRADIENT/GNAME`[l] := n;
    od;
    [seq( t[l], l=temps )]
end:

# generate a new gradient array-variable if the flag generate_array is true
`GRADIENT/AppendGrad` := proc(n,AllVars) local m,i;
    m := n;
    for i while member(m,eval(AllVars)) do m := cat(n,i); od;
    AllVars := eval(AllVars) union {m};
    RETURN(m);
end:

# generate a new jacobi array-variable if the flag generate_array is true 
# and there are more than one RETURN-value
`GRADIENT/AppendJaco` := proc(n,AllVars) local m,i;
global `GRADIENT/JacoVars`;
    m := n;
    for i while member(m,eval(AllVars)) do m := cat(n,i); od;
    AllVars := eval(AllVars) union {m};
    `GRADIENT/JacoVars`:= `GRADIENT/JacoVars` union {m};
    RETURN(m);
end:

#  get the name of a local indexed variable
`GRADIENT/GetName` := proc(x) local y; 
   y := x;
   while type(y,indexed) do y := op(0,y); od;
   RETURN(y);
end:

# generate gradient-array initialization sequence
`GRADIENT/GradInit` := proc(NrOfIndeps) local x,sequ,right,i;
    sequ := NULL;
       for x in `GRADIENT/GrdVar` while 
           not has(`GRADIENT/ArrRang`[x],`GRADIENT/ArrRang`) do
           right := convert('array',function,`GRADIENT/ArrRang`[x]);
           sequ := sequ , P( assemble( ASSIGN, A(x) , A(right)));
       od;
    if generate_array or NrOfIndeps > 1 then 
       for x in `GRADIENT/ArrVars` do
           right := convert('array',function,
                    `GRADIENT/ArrRang`[`GRADIENT/ComposeName`(x,1,false,NrOfIndeps)]);
           sequ := sequ , P( assemble( ASSIGN, 
                          A(`GRADIENT/ComposeName`(x,1,false,NrOfIndeps)) , A(right)));
       od;
    fi;
    RETURN(sequ);
end:

# check if Maple knows how to differentiate f by looking for diff/f
`GRADIENT/KNOWN` := proc(f) local n,t;
    n := `diff/`.f;
    if eval(n,2) <> n then RETURN() fi;
    t := traperror(readlib(n));
    if t <> lasterror then RETURN() fi;
    ERROR( `not known how to differentiate function `.f.
           ` i.e. there is no definition for `.n)
end:

# compute all strings in a statement
`GRADIENT/strings` := proc(b) local i,s;
    if type(b,algebraic) then `GRADIENT/strings/fix`(b)
    elif `type/:=`(b) or `type/if`(b) or `type/statseq`(b) or `type/for`(b) then
	s := {};
	for i in b do 
            if i <> NULL and not (`type/:=`(b) and type(op(2,b),procedure)) then 
                  s := s union procname(i) fi;
        od;
        s
    else `GRADIENT/strings/fix`(b)
    fi
end:

`GRADIENT/strings/fix` := proc(f)
    indets(f,string) union 
    map(proc(f) local s,t;
	if type(f,{function,indexed}) then
	    s := `GRADIENT/strings/fix`(op(0,f));
	    for t in f do s := s union `GRADIENT/strings/fix`(t) od;
	    op(s)
        else f
	fi;
    end, indets(f,indexed) union indets(f,function))
end:

# compute all variables (strings,indexed,functions) but not their names !
`GRADIENT/variables` := proc(b) local i,s;
    if type(b,algebraic) then `GRADIENT/variables/fix`(b)
    elif `type/:=`(b) or `type/if`(b) or `type/statseq`(b) or `type/for`(b) then
	s := {};
	for i in b do 
            if i <> NULL and not (`type/:=`(b) and type(op(2,b),procedure)) then
                  s := s union procname(i) fi;
        od;
        s
    else `GRADIENT/variables/fix`(b)
    fi
end:

`GRADIENT/variables/fix` := proc(f)
    indets(f,string) union 
    map(proc(f) local s,t;
	op(`GRADIENT/variables/fix`(op(0,f)));
    end, indets(f,function)) union
    map(proc(f) local s,t;
#	s := `GRADIENT/variables/fix`(op(0,f)) union {f};
        s := {f}; 
	for t in f do s := s union `GRADIENT/variables/fix`(t) od;
	op(s)
    end, indets(f,indexed) )
end:

# compute all variables that are assigned in a statement
`GRADIENT/assigned` := proc(f) local s,t;
    if nargs = 0 or nargs > 1 or type(f,algebraic) then {}
    elif type(f,`:=`) then {`GRADIENT/GetName`(op(1,f))}  
                           # replaced by `GRADIENT/GetName`(..)
    elif type(f,`for`) then {op(1,f)} union procname(op(6,f))
    else
	s := {};
	for t in f do s := s union procname(t) od;
	s
    fi
end:

# generate a new variable to store the value of a local procedure
`GRADIENT/NewVariable` := proc(m,AllVars) local n,i;
global `LocalProcs/Vars`;
   n := cat(m,1);
   for i while member(n,eval(AllVars) union `LocalProcs/Vars`) do 
       n := cat(m,i); od;
   `LocalProcs/Vars` := `LocalProcs/Vars` union {n};
   RETURN(n);
end:
    
# The aim of this `LocalProcs/..` procedures is to separate function-calls
# to local defined functions, because Maple doesn't know how to
# differentiate them !
`LocalProcs/compseq` := proc(c,AllVars,LocProc) local t,sequ,i;
global `LocalProcs/Vars`;
    if `type/:=`(c) then        `LocalProcs/:=`(c,'AllVars',LocProc)
    elif `type/statseq`(c) then `LocalProcs/statseq`(c,'AllVars',LocProc)
    elif `type/if`(c) then      `LocalProcs/if`(c,'AllVars',LocProc)
    elif `type/for`(c) then     `LocalProcs/for`(c,'AllVars',LocProc)
    elif `type/RETURN`(c) then  `LocalProcs/RETURN`(c,'AllVars',LocProc)
    elif `type/ERROR`(c) then   c
    elif `type/print`(c) then   c
    elif `type/lprint`(c) then  c
    elif `type/break`(c) then   c
    elif `type/next`(c) then    c
    else t := `LocalProcs/expr`(c,'AllVars',LocProc);
         sequ := NULL;
         if nops(t)>1 then sequ := sequ, seq(t[i],i=2..nops(t)); fi;
         t :=  op(1,t);
         if nops([t]) <> 1 then t:= 'RETURN'(t) fi;
         `LocalProcs/Vars` := {};
         P( assemble( STATSEQ, seq( A(i), i=[sequ,t] ) ) );
    fi
end:

`LocalProcs/statseq` := proc(c,AllVars,LocProc) local s,t;
    s := [seq( `LocalProcs/compseq`(t,'AllVars',LocProc), t=c )];
    # flatten statement sequences -- Maple should do this automatically
    s := map( proc(x) if `type/statseq`(x) then op(x) else x fi end, s );
    P( assemble( STATSEQ, seq( A(t), t=s ) ) )
end:

`LocalProcs/RETURN` := proc(c,AllVars,LocProc) local right,t,i,sequ1,sequ2;
global `LocalProcs/Vars`;
    sequ1 := NULL;  sequ2 := NULL;
    t := [seq(t , t=c)];
    for i to nops(t) do
        right := `LocalProcs/expr`(t[i],'AllVars',LocProc);
        if nops(right)>1 then sequ1 := sequ1,seq(right[i],i=2..nops(right)) fi;
        sequ2 := sequ2, op(1,right);
    od;
    `LocalProcs/Vars` := {};
    P( assemble( STATSEQ, seq( A(i), i=[sequ1,'RETURN'(sequ2)] ) ) );
end:

`LocalProcs/expr` := proc(c,AllVars,LocProc) local r;
    if not type(c,`string`) then 
       r := `LocalProcs/MathExpr`(c,'AllVars',LocProc);
    else 
       r := [c];
    fi;
    RETURN(r);
end:

`LocalProcs/if` := proc(c,AllVars,LocProc) local i,t;
    t := NULL;
    for i from 2 by 2 to nops(c) do
	t := t, op(i-1,c), `LocalProcs/compseq`(op(i,c),'AllVars',LocProc);
    od;
    if nops(c) mod 2 = 1 and nops(c) > 1 then
	t := t, `LocalProcs/compseq`(op(nops(c),c),'AllVars',LocProc);
    fi;
    P( assemble( IF, seq( A(i), i=t ) ) )
end:

`LocalProcs/for` := proc(c,AllVars,LocProc) local t;
    if nops(c) = 4 then ERROR(`cannot differentiate a for in loop`) fi;
    t := `LocalProcs/compseq`(op(nops(c),c),'AllVars',LocProc);
    subsop( nops(c)=t, c );
end:


`LocalProcs/MathExpr` := proc(right,AllVars,LocProc) 
                     local depends,sequ,r,i,j,params,deplist,tmp,res,p,t;

    r := right;
    sequ := NULL;
    deplist := {};
    # search for the local defined functions of the right side
    depends := indets(r,function);
    if member(r,depends,'p') then depends := subsop(p=NULL,depends); fi;
    i:=1;
    while i <= nops(depends) do
      if (type(depends[i],function) and not has(LocProc,op(0,depends[i])))
         or type(depends[i],string) then 
         depends := subsop(i=NULL,depends);
      else 
         tmp := `GRADIENT/NewVariable`(`t`,'AllVars');
         r := subs(depends[i]=tmp,r);
         deplist := deplist union {depends[i]=tmp};
         res := `LocalProcs/MathExpr`(depends[i],'AllVars',LocProc);
         if nops(res)>1 then 
            sequ := sequ, op(2..nops(res),res),
                          P(assemble(ASSIGN,A(tmp),A(res[1])));
            depends := subs(res[1]=tmp,depends);
            depends := subs([seq(op(2,op(j,res))=op(1,op(j,res)),
                            j=2..nops(res))],depends);
         else 
            sequ := sequ, P(assemble(ASSIGN,A(tmp),A(depends[i]))); 
         fi;
         depends := subs(depends[i]=tmp,depends);
      fi;
    od;
    RETURN([r,sequ]);
end:

`LocalProcs/:=` := proc(a,AllVars,LocProc) local left,right,i,t1,t2,typ;
global `LocalProcs/Vars`;
    left := op(1,a);
    right := op(2,a);
    typ := whattype(right);
    
       if evalb(typ<>'indexed') and evalb(typ<>'procedure') and 
          evalb(typ<>'string') and not (evalb(typ='function') and 
          has(LocProc,op(0,right)) ) and not (evalb(typ='function') and 
          op(0,right)='array') then
           right := `LocalProcs/MathExpr`(op(2,a),'AllVars',LocProc);
           if nops(right)=1 then 
             `LocalProcs/Vars` := {};
             P( assemble( ASSIGN, A(left), A(op(1,right)) ) );
           else 
             t2 := seq(right[i],i=2..nops(right));
             t1 := P( assemble( ASSIGN, A(left), A(op(1,right)) ) );
             `LocalProcs/Vars` := {};
             P( assemble( STATSEQ, seq( A(i), i=[t2,t1] ) ) );
           fi;
      else RETURN(a); fi;
end:

`help/text/GRADIENT` := TEXT(
`FUNCTION: GRADIENT - procedure differentiation (algorithmic differentiation)`,
`    `,`CALLING SEQUENCE:`,`    `,
`   GRADIENT(f,X) -- compute the gradient of f with respect to X`,
`   GRADIENT(f,p) -- compute the gradient of f with respect to the first`,
`                    p variables appearing in the parameterlist of f`,
`   GRADIENT(f) -- compute the gradient of f with respect to all`,
`                  variables in the parameterlist of f`,`    `,`PARAMETERS:`,
`   f - a procedure`,`   X - a name or a list of names`,
`   p - a positive integer`,`    `,`GLOBALS:   `,
`   include_funcval  - boolean`,`   generate_array   - boolean`,
`   constant_folding - boolean`,`    `,`SYNOPSIS   `,`    `,
`- Given a Maple procedure f, a function of n complex arguments`,`    `,
`       X = x1, x2, x3, .. , xn`,`    `,
`  GRADIENT(f,[xi, .. , xk]) computes the gradient of f wrt {xi, .. , xk}`,
`  where  1 <= i,k <= n , i.e. returns a Maple procedure g, which computes`,
`    `,`       grad( f(xi, .. , xk)) = [ diff(f,xi), .. , diff(f,xk)]`,`    `,
`- The Maple procedure f may contain assigments to temporary (local)`,
`  variables or local defined fucntions (subroutines). For example, consider`,
`    `,`       f := proc(x,y) local t; t := cos(x)*sin(y); t*x*y end`,`    `,
`  which uses t as a local variable to compute cos(x)*sin(y)*x*y.`,
`  The output of GRADIENT(f,[x,y]) is the procedure`,`    `,
`       proc(x,y) local t,dt;`,`           dt := array(1 .. 2);`,
`           dt[1] := -sin(x)*sin(y);`,`           dt[2] := cos(x)*cos(y);`,
`           t := cos(x)*sin(y);`,
`           RETURN(dt[1]*x*y+t*y,dt[2]*x*y+t*x)`,`       end   `,`      `,
`  Note: GRADIENT(f) and GRADIENT(f,2) gives the same output in this case!`,
`      `,`- Suppose the Maple procedure f returns a sequence of values`,
`      `,`            n         m                ( v1(X) )`,
`       f : R   --->  R     ,    f(X) = (   :   )`,
`                                       ( vm(X) )`,`      `,
`  Let g := GRADIENT(f,[x1, .. , xn]) `,
`  The computed result of the procedure g looks as follows:`,`      `,
`            n         m    n            ( diff(v1,x1), .. , diff(v1,xn) )`,
`       g : R  --->   R  x R   ,  g(X) = (      ..      ..      ..       )`,
`                                        ( diff(vm,x1), .. , diff(vm,xn) )`,
`      `,`  In this case the procedure g returns an array of arrays.`,`      `,
`       g(X) = [[diff(v1,x1), . ,diff(v1,xn)], . ,[diff(vm,x1), . ,diff(vm,xn)\
]]`,`      `,
`- The global boolean variable include_funcval (default false) specifies`,
`  whether the value of f and its gradient are to be returned or not.`,
`  If include_funcval is false, the procedure g returned computes `,
`  only the gradient of f wrt the specified variables!`,
`  If include_funcval is true, the procedure g computes the value of f`,
`  and the gradient of f wrt the specified variables!`,
`  For example, GRADIENT(f,[xi,xj]) returns a procedure which computes`,
`       `,`  	f(X), diff(f(X),xi), diff(f(X),xj)`,`       `,
`  and GRADIENT(f,3) returns a procedure which computes `,`       `,
` 	f(X), D[1](f)(X), D[2](f)(X), D[3](f)(X)`,`       `,
`  Returning the function value and the gradient is useful if you`,
`  want to compute a Newton iteration or a Taylor series.`,
`  For example, if include_funcval = true, the output of GRADIENT(f) is`,
`       `,`        proc(x,y)`,`        local dt,t;`,
`            dt := array(1 .. 2);`,`            dt[1] := -sin(x)*sin(y);`,
`            dt[2] := cos(x)*cos(y);`,`            t := cos(x)*sin(y);`,
`            RETURN(t*x*y,dt[1]*x*y+t*y,dt[2]*x*y+t*x)`,`        end`,`       `
,`- The global boolean variable generate_array (default false) specifies`,
`  whether the procedure g returns an array instead of a sequence for`,
`  the gradient.`,
`  Returning the gradient as an array is very useful if you want to`,
`  redifferentiate the returned procedure g. The representation of the`,
`  gradient of a function f as an array is more close to mathematics.`,`      `
,`- The global boolean variable constant_folding (default true) specifies`,
`  whether all variables containing just numerical values, are `,
`  substituted in all further algebraic expressions or not.`,
`  This subtitution is very useful because it shorts the length of`,
`  the generated program. Especially the list of local variables`,
`  won't be too large.`,`     `,
`- Differentiating programs is known as Algorithmic Differentiation.`,
`  The theoretical advantage is that formulae can often be represented more`,
`  compactly when represented as procedures rather than as expressions.`,
`  They can then be numerically evaluated more efficiently.`,
`  It is also possible to differentiate programs which contain control`,
`  flow statements, if statements, for and while loops, etc.`,
`  This is useful for example for piecewise defined functions e.g. splines.`,
`       `,`- The GRADIENT routine can differentiate procedures containing`,
`  assignment statements - of a local variable to an expression or procedure`,
`  for loops (for from by to while do od),`,
`  if statements (if then elif elif ... else fi)`,
`  RETURN and ERROR statements, and array, break and next statements.`,
`       `,`- The expressions appearing in a RETURN statement and on the right`,
`  hand side of an assignment statement must be functions of the parameters,`,
`  local variables, global variables, local procedures and constants which may`
,`  contain the arithmetic operators +, -, *, /, ^, sqrt, the elementary `,
`  functions exp, ln, sin, cos, tan, etc. and special functions Ei, erf, `,
`  GAMMA, etc. I.e. anything Maple knows how to differentiate.`,`      `,
`- The GRADIENT routine is able to differentiate local procedures.`,
`  Note: A local procedure is always differentiated wrt all`,
`        of its parameters!`,
`        The parameters in the function call don't have to be only`,
`        single variables. They can also be arbitrary functions of several`,
`        variables. In this case it's nessecary to compute the`,
`        so called ``total derivative`` of that local function.`,`    `,
`  GRADIENT allows the use of the array data structure in the procedure.`,
`  Here is a list of the limitations`,`      `,
`  1: It does not allow the use of the following data structures `,
`     in the procedure: sequences, lists, sets, tables.`,
`  2: It does not allow assignment to global variables or parameters`,
`  3: Global variables that appear in expressions are assumed to be constants`,
`  4: In an expression, only function calls for which Maple knows`,
`     how to differentiate using diff or local functions are allowed`,
`     -- recursive calls are disallowed.`,
`  5: for loop indices must be local variables`,
`  6: for loop bounds must be constants -- not functions of X`,
`  7: procedures cannot use args or nargs or quotes`,
`  8: procedures mustn't have options`,`      `,
`- The GRADIENT routine cannot differentiate functions which are not known`,
`  to Maple or not defined locally.`,
`  For example, the procedure  proc(x) f(x)+sin(x) end  contains a call to`,
`  the function f which Maple does not initially know how to differentiate.`,
`  More precisely, the GRADIENT code looks to see if there is a definition for`
,`  ``diff/f`` in the Maple session, or, if ``diff/f`` is defined in Maple lib\
rary.`,
`  The user can teach Maple hence GRADIENT how to differentiate f by defining`,
`  ``diff/f`` appropriately -- see ?diff for details.  For example, it would`,
`  be sufficient to define ``diff/f`` := proc(a,x) diff(a,x)*fp(a) end;`,
`  i.e. just give fp as the name for D(f).`,
`  In the case of local defined procedures (functions) GRADIENT seperates`,
`  the function calls and replaces them in the expression through a`,
`  new local variable. To differentiate local procedures, the GRADIENT`,
`  routine will be called recursively. The differentiation of these local`,
`  procedures is always done wrt all parameters of the corresponding function.`
,`       `,`  For example:`,`      f := proc(x,y) local s,g;`,
`             g := proc(u,v,w) local a,b; a := u^2*w; b := u*v^3*w^2; a*b end;`
,`             s := g(3*x^2,x*y,y^3);`,`             s*x*y`,`           end`,
`    `,
`  The output from GRADIENT(f) (same as GRADIENT(f,2) and GRADIENT(f,[x,y]))`,
`  looks as follows:`,`    `,`       proc(x,y) local dg,ds,g,lf1,s;`,
`           ds := array(1 .. 2);`,
`           dg := proc(u,v,w) local a,b,da,db,grd;`,
`                     grd := array(1 .. 3);`,
`                     da := array(1 .. 3);`,
`                     db := array(1 .. 3);`,
`                     da[1] := 2*u*w;`,`                     da[3] := u^2;`,
`                     a := u^2*w;`,`                     db[1] := v^3*w^2;`,
`                     db[2] := 3*u*v^2*w^2;`,
`                     db[3] := 2*u*v^3*w;`,
`                     b := u*v^3*w^2;`,
`                     grd[1] := da[1]*b+a*db[1];`,
`                     grd[2] := a*db[2];`,
`                     grd[3] := da[3]*b+a*db[3];`,`                     grd`,
`                 end                           ;`,
`           g := proc(u,v,w) local a,b; a := u^2*w; b := u*v^3*w^2; a*b end;`,
`           lf1 := dg(3*x^2,x*y,y^3);`,
`           ds[1] := 6*lf1[1]*x+lf1[2]*y;`,
`           ds[2] := lf1[2]*x+3*lf1[3]*y^2;`,
`           s := g(3*x^2,x*y,y^3);`,
`           RETURN(ds[1]*x*y+s*y,ds[2]*x*y+s*x)`,`       end   `,`   `,
`- The GRADIENT program does some optimizations of the resulting code.`,
`  This is the most complicated part of the actual program.`,
`  It will try to identify statically which local variables are constants,`,
`  and hence differentiate to zero.  It will do constant folding, i.e.`,
`  an assignment to a temporary t of a numerical constant will be substituted`,
`  for in the procedure.  The global variable constant_folding (default true)`,
`  specifies whether constant folding is to be done or not.`,
`  Note, common subexpression optimization is not done as it is planned`,
`  that Maple's optimize routine will do this.`,`       `,`EXAMPLES:   `,
`       `,
`> f := proc(x,y) local u,v; u := 3*x^2*y; v := 5*x*y^2; RETURN(u*x,v*y) end: `
,`> f(x,y);   `,`      `,`                                    3         3`,
`                                 3 x  y, 5 x y`,`       `,
`> df := GRADIENT(f);`,`df := proc(x,y)`,`      local du,dv,u,v;`,
`          du := array(1 .. 2);`,`          dv := array(1 .. 2);`,
`          du[1] := 6*x*y;`,`          du[2] := 3*x^2;`,
`          u := 3*x^2*y;`,`          dv[1] := 5*y^2;`,
`          dv[2] := 10*x*y;`,`          v := 5*x*y^2;`,
`          RETURN(du[1]*x+u,du[2]*x,dv[1]*y,dv[2]*y+v)`,`      end   `,`   `,
`> df(x,y);   `,`       `,
`                             2       3     3        2`,
`                          9 x  y, 3 x , 5 y , 15 x y `,
`> generate_array := true: `,`> df := GRADIENT(f):`,`> eval(df(x,y));`,
`                         [    2         3  ]`,
`                         [ 9 x  y    3 x   ]`,
`                         [                 ]`,
`                         [     3         2 ]`,
`                         [  5 y    15 x y  ]`,`   `,
`> generate_array := false;`,`> f := proc(x)`,`     if x <= -2 then (x+2)^2+1`,
`     elif (-2 <= x) and (x <= -1) then -(x+2)^2+1`,
`     elif (-1 <= x) and (x <= 0) then -2*x-2`,
`     elif (0 <= x) and (x <= 1) then 2*x-2`,
`     elif (1 <= x) and (x <= 2) then -(x-2)^2+1`,`     else (x-2)^2+1`,
`     fi   `,`  end:   `,`> df := GRADIENT(f);`,`        `,`df := proc(x)`,
`          if x <= -2 then 2*x+4`,
`          elif (-2 <= x) and (x <= -1) then -2*x-4`,
`          elif (-1 <= x) and (x <= 0) then -2`,
`          elif (0 <= x) and (x <= 1) then 2`,
`          elif (1 <= x) and (x <= 2) then -2*x+4`,`          else 2*x-4`,
`          fi`,`      end:   `,`      `,`> f := proc(x,y,n) local s,t,u;`,
`     s := array(1 .. n+1); `,
`     for t to n+1 do  s[t] := x^(n-t+1)*y^(t-1) od; s`,`  end:   `,
`> eval(f(x,y,3));`,`       `,
`                                3   2       2   3`,
`                             [ x , x  y, x y , y  ]`,
`> df:=GRADIENT(f,[x,y]):`,`> eval(df(x,y,3));`,`      `,
`                                [     2        ]`,
`                                [  3 x     0   ]`,
`                                [              ]`,
`                                [           2  ]`,
`                                [ 2 x y    x   ]`,
`                                [              ]`,
`                                [    2         ]`,
`                                [   y    2 x y ]`,
`                                [              ]`,
`                                [            2 ]`,
`                                [   0     3 y  ]`,`      `,
`> f := proc(x) local s,d;`,`     d := proc(u) local t; t := u^2+u; t*u end; `,
`     s := d(x); `,`     s*x   `,`  end:   `,`> df := GRADIENT(f):`,
`> diff(expand(f(x)),x) - expand(df(x));`,`       `,
`                                       0 `,`       `,
`> f := proc(x,y) local a,b,c,d;`,
`     d := proc(u,v) local a,b; a := u*v^2; b := u^3*v; a*b end;`,
`     a := d(x^2,3*y);`,`     b := d(x*y,x);`,`     b*a   `,`  end:   `,
`> df := GRADIENT(f):`,`> diff(f(x,y),x),diff(f(x,y),y);`,`       `,
`                                  14  7       15  6`,
`                             405 x   y , 189 x   y`,`       `,`> df(x,y);   `,
`       `,`                                  14  7       15  6`,
`                             405 x   y , 189 x   y`,`      `,
`SEE ALSO: D, diff, JACOBIAN, TAYLOR, HESSIAN`):

macro(A = A, P = P);

#save `GRADIENT.m`;
#quit
