#
#--> DIFF(f,i,n) -- compute D[i$n](f)
#--> DIFF(f,i) -- compute D[i](f), equivalent to DIFF(f,i,1)
#
# Given a Maple procedure f, a function of m arguments X where
#
#	X = x1, x2, ..., xm
#
# compute D[i$n](f) i.e. the n'th partial the derivative of f wrt xi.
# I.e. returns a Maple procedure g, a function of X, which computes
#
#	diff( f(X), xi )
#
# The global boolean variable all_derivatives (default false) specifies
# whether all the derivatives are to be returned.
# If all_derivatives is false, the procedure g returned computes only the
# one derivative specified, i.e. D[i$n](f).
# If all_derivatives is true, the procedure g returns a sequence of all
# the derivatives (including the 0'th derivative f) i.e. DIFF(f,i) returns
# a procedure which computes
#
# 	f(X), D[i](f)(X)
#
# and DIFF(f,i,n) returns a procedure which computes 
#
#	f(X), D[i](f)(X), (D[i]@@2)(f)(X), ..., (D[i]@@n)(f)(X)
#
# 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 DIFF 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 DIFF routine does not attempt to do common subexpression optimization.
# It is planned that Maple's optimize routine will do this.
#
# Author: MBM Oct/91
#
# Comments about manipulation of procedure bodies
# 1: Make ERROR, RETURN, next and break statements to reduce errors
# 2: Need a better way to know what functions can be differentiated
# 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:
`convert/series` := proc(p,x) local i,s,t;
        s := [seq( [A(x[2*i-1]),x[2*i]], i=1..nops(x)/2 )];
        P( assemble( SERIES, A(p), seq(op(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
all_derivatives := false: # flag for generating all the derivatives

macro( GENSYM = readlib(`tools/gensym`) );
DIFF := proc(p,i,n)
local j,k,l,m,t,x,params,locals,body,depends,derivs,temps,diffs,funcs,vars;
global `DIFF/CFOLD`, `DIFF/LOCALS`, `DIFF/SUBSTS`;

    if nargs = 1 then RETURN( DIFF(p,1,1) ) fi;
    if nargs = 2 then RETURN( DIFF(p,i,1) ) fi;

    if not type(p,procedure) then
	ERROR(`1st argument (function) must be a procedure`,p) fi;
    if not type(i,integer) then
	ERROR(`2nd argument must be a positive integer`,i) fi;
    if not type(n,nonnegint) then
	ERROR(`3rd argument must be a non-negative integer`,n) fi;

    if type(p,name) then RETURN( procname(eval(p),i,n) ) fi;

    params := map(GENSYM,[op(1,p)]);
    locals := map(GENSYM,[op(2,p)]);

    if i < 1 or i > nops(params) then
	ERROR(`partial derivative subscript out of range`,i) fi;
    x := op(i,params);

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

    `DIFF/CFOLD` := constant_folding;
    `DIFF/LOCALS` := table(); # table of all non-constant temporaries

    body := `convert/compseq`(body,x,params,locals);

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

    body := `DIFF/check`(body);
    body := `DIFF/optimize`(body); # pre optimize it
    vars := `DIFF/variables`(body) union {op(1,p),op(2,p)};

    diffs := `DIFF/DNAMES`( temps, x, n, vars );
    funcs := [seq( convert(l,function,[x]), l=temps )];
    depends := [seq( temps[k] = funcs[k], k=1..m ),
        seq( seq( diffs[k][j] = diff(funcs[k],x$j), j=1..n ), k=1..m )];
    derivs := [seq( funcs[k]=temps[k], k=1..m ),
        seq( seq( diff(funcs[k],x$j) = diffs[k][j], j=1..n ), k=1..m )];
    `DIFF/SUBSTS` := {};

    body := `DIFF/compseq`(body,x,n,depends,derivs); # differentiate it
    body := `DIFF/optimize`(body); # post optimize it

    locals := `DIFF/variables`(body) intersect
	{op(locals),seq(op(t),t=diffs)};

    locals := op(locals); params := op(params);
    # P( assemble( PROC, A(params), A(locals), A(op(3,p)), A(), A(body) ) )
    subs( ['BODY'=body,'LOCALS'=locals,'OPTIONS'=op(3,p),'PARAMS'=params],
             proc(PARAMS) local LOCALS; options OPTIONS; BODY end )

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

`DIFF/optimize` := proc(b) local a,d,i,n,t;
    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 := `DIFF/variables`(t[n]);
	for i from n-1 by -1 to 1 do
	    if type(t[i],`:=`) then
	        if not member(op(1,t[i]),d) 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}) 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 := indets(t[i],string);
	        else d := d minus {op(1,t[i])} union indets(op(2,t[i]),string)
	        fi
	    else
		if `DIFF/assigned`(t[i]) intersect d = {} and
		    not has(t[i],'RETURN') then t := subsop(i=NULL,t)
		else d := d union `DIFF/variables`(t[i])
		fi
	    fi
	od;
	P( assemble( STATSEQ, seq( A(i), i=t ) ) )
    else b
    fi
end:

`DIFF/compseq` := proc(c,x,n,depends,derivs) local t;
    if `type/:=`(c) then `DIFF/:=`(c,x,n,depends,derivs)
    elif `type/statseq`(c) then `DIFF/statseq`(c,x,n,depends,derivs)
    elif `type/if`(c) then `DIFF/if`(c,x,n,depends,derivs)
    elif `type/for`(c) then `DIFF/for`(c,x,n,depends,derivs)
    elif `type/RETURN`(c) then `DIFF/RETURN`(c,x,n,depends,derivs)
    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 := `DIFF/expr`(c,x,n,depends,derivs);
	 if nops([t]) <> 1 then 'RETURN'(t) else t fi
    fi
end:

`DIFF/RETURN` := proc(c,x,n,depends,derivs) local t;
    t := seq( `DIFF/expr`(t,x,n,depends,derivs), t=c );
    'RETURN'(t)
end:

`DIFF/expr` := proc(c,x,n,depends,derivs) local i,r,t;
    t := c;
    if `DIFF/CFOLD` then t := subs( `DIFF/SUBSTS`, t ) fi;
    r := t;
    for i to n do
	t := `DIFF/diff`(t,x,depends,derivs);
	r := r,t
    od;
    if all_derivatives = true then r else t fi
end:

`DIFF/diff` := proc(c,x,depends,derivs) local t;
    t := subs(depends,c);
    t := diff(t,x);
    t := subs(derivs,t);
    if has(t,{diff,D}) then ERROR(`cannot differentiate`,c) fi;
    if `DIFF/CFOLD` then t := subs(eval(`DIFF/SUBSTS`,1),t) fi;
    t
end:
 
`DIFF/statseq` := proc(c,x,n,depends,derivs) local s,t;
    s := [seq( `DIFF/compseq`(t,x,n,depends,derivs), 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:

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

`DIFF/for` := proc(c,x,n,depends,derivs) local t;
    if nops(c) = 4 then ERROR(`cannot differentiate a for in loop`) fi;
    t := `DIFF/compseq`(op(nops(c),c),x,n,depends,derivs);
    subsop( nops(c)=t, c );
end:

`DIFF/:=` := proc(a,x,n,depends,derivs) local c,i,j,l,r,lx,rx,s,t;
global `DIFF/SUBSTS`;
    l := op(1,a);
    r := op(2,a);
    if `DIFF/CFOLD` then
        c := eval(`DIFF/SUBSTS`,1);
        r := subs(c,r);
        for i to nops(c) do
            if op(1,c[i]) = l then c := subsop(i=NULL,c); break fi od;
        if type(r,numeric) then c := c union {l = r} fi;
    fi;
    t := P( assemble( ASSIGN, A(l), A(r) ) );
    if `DIFF/CFOLD` then `DIFF/SUBSTS` := c fi;
    if not member(l,eval(`DIFF/LOCALS`,1)) then RETURN( t ) fi;
    # Need all n derivatives of r
    rx := r;
    s := NULL;
    for j to n do
        lx := eval(`DIFF/DNAME`[l],1)[j];
        rx := `DIFF/diff`(rx,x,depends,derivs);
	if `DIFF/CFOLD` then
            for i to nops(c) do
                if op(1,c[i]) = lx then c := subsop(i=NULL,c); break fi od;
            if type(rx,numeric)
	    then c := c union {lx = rx}
	    else s := s, P( assemble( ASSIGN, A(lx), A(rx) ) );
	    fi;
	else s := P( assemble( ASSIGN, A(lx), A(rx) ) ), s;
	fi
    od;
    if `DIFF/CFOLD` then `DIFF/SUBSTS` := c fi;
    P( assemble( STATSEQ, seq( A(i), i=[s,t] ) ) );
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

`convert/compseq` := proc(s,x,params,locals) local i,l,n,p,r,t;
global `DIFF/LOCALS`, `DIFF/CFOLD`;

    if nargs = 3 then ERROR(`unable to differentiate an empty sequence`)
    elif nargs > 4 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), t=[op(s)] )], `+` )

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

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

    elif type(s,function) then
        p := procname(op(0,s),x,params,locals);
        if `type/local`(op(0,s)) then
	    ERROR(`cannot differentiate local functions`,p) fi;
	if `type/param`(op(0,s)) then
	    ERROR(`cannot differentiate functional parameters`,p) fi;
        r := [seq( procname(t,x,params,locals), t=s )];
        # Dissallow functions which Maple does not know how to differentiate
        `DIFF/CHECK_IF_CAN_DIFFERENTIATE`(p,r,x,locals);
        r := `convert/function`(p,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`(l) then
ERROR(`can only differentiate assignments to local variables`) fi;
        l := procname(l,x,params,locals);
        r := procname(r,x,params,locals);
	t := indets(r,name) minus {constants};
	t := t minus {l} minus ({op(params)} minus {x});
	if t <> {} then `DIFF/LOCALS`[l] := l fi;
        P( assemble( ASSIGN, A(l), A(r) ) )

    elif type(s,logical) then `DIFF/map`(procname,s,x,params,locals)
    elif type(s,relation) then `DIFF/map`(procname,s,x,params,locals)
    elif type(s,range) then
	# do not call DIFF/map in this case because it uses seq
	procname(op(1,s),x,params,locals) .. procname(op(2,s),x,params,locals)

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

    # elif type(s,`for`) then -- does not work
    elif `type/for`(s) then
	`DIFF/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 := `DIFF/map`(procname,t,x,params,locals);
	if l <> NULL then
	    r := indets([op(2..4,t)],name) minus {constants};
	    r := r minus ({op(params)} minus {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); does not work
        t := [seq( procname(i,x,params,locals), i=[op(s)] )];
        if t = [] then ERROR(`empty statement sequence`) fi;
        convert(t,statseq)

    elif type(s,indexed) then
	p := op(0,s);
	if `type/local`(p) then
	    ERROR(`cannot differentiate local subscripts`,
		   procname(p,x,params,locals)); fi;
	p := procname(p,x,params,locals);
	if p = x then ERROR(`subscript of derivative variable`,p) fi;
	if not type(p,string) then ERROR(`invalid subscript`,p) fi;
        r := [seq( procname(t,x,params,locals), t=s )];
        r := convert( p, indexed, r );

    elif type(s,series) then
        p := procname(op(0,s),x,params,locals);
        t := [seq( procname(i,x,params,locals), i=[op(s)] )];
        `convert/series`(p,t)

    else ERROR(`cannot differentiate`,s)
    fi

end:

# can't use map because of sequences e.g. a NULL value
`DIFF/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
`DIFF/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
`DIFF/DNAMES` := proc(temps,x,k,vars) local i,j,l,n,r,t;
global `DIFF/DNAME`;
    for l in temps do
	r := NULL;
	for i to k do
            n := cat(l,x$i);
            for j while member(n,vars) or assigned(t[n]) do
		n := cat(l,j,x$i)
	    od;
	    t[n] := n;
	    r := r,n
	od;
	t[l] := [r]
    od;
    `DIFF/DNAME` := op(t);
    [seq( t[l], l=temps )]
end:

# check if Maple knows how to differentiate f by looking for diff/f
`DIFF/CHECK_IF_CAN_DIFFERENTIATE` := proc(f,a,x,l) local n,t;

    # Cases which must be delt with specially
    if member(f,'{RETURN,ERROR,lprint,print}') then RETURN() fi;
    # Cases which cannot be handled
    if member(f,'{array,table,series}') then ERROR(
`unable to differentiate procedures which create arrays, tables or series`);
                fi;
    if not type(f,name) then # Cases not handled
	ERROR(`unable to differentiate function`,f); fi;
    # Cases where the arguments are constants wrt x (note locals)
    if not has(a,x) and not has(a,l) then RETURN() fi;
    if not type(f,string) then
	ERROR(`unable to differentiate function`,f); fi;
    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 variables (strings) in a statement
`DIFF/variables` := proc(b) local i,s;
    if type(b,algebraic) then `DIFF/indets/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 then s := s union procname(i) fi od;
        s
    else `DIFF/indets/fix`(b)
    fi
end:

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

# compute all variables that are assigned in a statement
`DIFF/assigned` := proc(f) local s,t;
    if nargs = 0 or nargs > 1 or type(f,algebraic) then {}
    elif type(f,`:=`) then {op(1,f)}
    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:
    
`help/text/DIFF` := TEXT(
`FUNCTION: DIFF - procedure differentiation (algorithmic differentiation)`,
`   `,
`CALLING SEQUENCE:`,
`   `,
`   DIFF(f,i,n) -- compute D[i$n](f)`,
`   DIFF(f,i) -- compute D[i](f), equivalent to DIFF(f,i,1)`,
`   `,
`PARAMETERS:`,
`   f - a procedure`,
`   i - a positive integer (derivative index)`,
`   n - a non-negative integer`,
`   `,
`GLOBALS:   `,
`   all_derivatives - boolean`,
`   constant_folding - boolean`,
`   `,
`SYNOPSIS:   `,
`   `,
`- Given a Maple procedure f, a function of m complex arguments`,
`   `,
`	X = x1, x2, ..., xm`,
`   `,
`  DIFF(f,i,n) computes D[i$n](f) i.e. the n'th partial the derivative of f`,
`  wrt xi i.e. returns a Maple procedure g, which computes`,
`   `,
`	diff( f(x1, x2, ...,xm), xi )`,
`   `,
`- The Maple procedure f may contain assignments to temporary (local)`,
`  variables.  For example, consider`,
`    `,
`   f := proc(x) local t;`,
`            t := cos(x);`,
`            x*t+t^2`,
`        end`,
`    `,
`  which uses t as a temporary variable to compute cos(x)+sin(x)*cos(x).`,
`  The output of DIFF(f,1) is the procedure`,
`    `,
`        proc(x) local t,tx;`,
` 	    tx := -sin(x);`,
`            t := cos(x);`,
`            t+x*tx+2*t*tx`,
`        end`,
`    `,
`  Note: you can check that the procedure returned is correct in this case`,
`  by comparing with diff, i.e. that diff(f(x),x) = DIFF(f,1)(x)`,
`   `,
`- The global boolean variable all_derivatives (default false) specifies`,
`  whether all the derivatives are to be returned.`,
`  If all_derivatives is false, the procedure g returned computes the`,
`  one derivative specified, i.e. D[i$n](f).`,
`  If all_derivatives is true, the procedure g returns a sequence of all`,
`  the derivatives (including the 0'th derivative f).`,
`  For example, DIFF(f,i) returns a procedure which computes`,
`    `,
`  	f(X), D[i](f)(X)`,
`    `,
`  and DIFF(f,i,n) returns a procedure which computes `,
`    `,
` 	f(X), D[i](f)(X), (D[i]@@2)(f)(X), ..., (D[i]@@n)(f)(X)`,
`    `,
`  Returning the function value and the derivative(s) is useful if you`,
`  want to compute a Newton iteration or a Taylor series.`,
`  For example, if all_derivatives = true, the output of DIFF(f,1) is`,
`    `,
` 	proc(x) local t, tx;`,
` 	    tx := -sin(x);`,
`            t := cos(x);`,
`            RETURN(x*t+t^2,t+x*tx+2*t*tx)`,
`        end`,
`    `,
`- 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 DIFF routine can differentiate procedures containing`,
`  assignment statements - of a local variable to an expression`,
`  for loops (for from by to while do od),`,
`  if statments (if then elif elif ... else fi)`,
`  RETURN and ERROR statements, and 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 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 DIFF routine is not able to differentiate arbitrary procedures.`,
`  Here is a list of the limitations`,
`   `,
`  1: It does not allow the use of any data structures in the procedure`,
`     i.e. sequences, lists, sets, arrays, tables etc.`,
`  2: In particular, it does not allow local arrays, or any local subscripts`,
`  3: It does not allow assignment to global variables or parameters`,
`  4: Global variables that appear in expressions are assumed to be constants`,
`  5: In an expression, only function calls for which Maple knows`,
`     how to differentiate using diff are allowed -- recursive`,
`     calls and subroutine calls are disallowed.`,
`  6: for loop indices must be local variables`,
`  7: for loop bounds must be constants -- not functions of x`,
`  8: It cannot differentiate f(x) if f is a local variable or parameter`,
`  9: procedures cannot use args or nargs or quotes`,
`   `,
`- The DIFF routine cannot differentiate functions which are not known to Maple.`,
`  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 DIFF code looks to see if there is a definition for`,
`  ``diff/f`` in the Maple session, or, if ``diff/f`` is defined in Maple library.`,
`  The user can teach Maple hence DIFF 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).`,
`    `,
`- The DIFF 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 t1,t2;`,
`>      t1 := x^2;`,
`>      t2 := sin(x);`,
`>      3*t1*t2+2*t1*x*y-y*t2-2*t2*y^2`,
`> end:   `,
`>   `,
`> DIFF(f,1);   `,
`                proc(x,y) local t2,t1,t2x,t1x;`,
`                    t1x := 2*x;`,
`                    t1 := x^2;`,
`                    t2x := cos(x);`,
`                    t2 := sin(x);`,
`                    3*t1x*t2+3*t1*t2x+2*t1x*x*y+2*y*t1-y*t2x-2*t2x*y^2`,
`                end`,
`   `,
`> diff(f(x,y),x) - DIFF(f,1)(x,y);`,
`   `,
`                                       0`,
`   `,
`> DIFF(f,2);   `,
`                proc(x,y) local t2,t1;`,
`                    t1 := x^2;`,
`                    t2 := sin(x);`,
`                    2*x*t1-t2-4*y*t2`,
`                end`,
`   `,
`> diff(f(x,y),y) - DIFF(f,2)(x,y);`,
`   `,
`                                       0`,
`   `,
`> DIFF(f,2,2);`,
`   `,
`                proc(x,y) local t2; t2 := sin(x); -4*t2 end`,
`   `,
`> f := proc(x)`,
`>      if x < 0 then 0`,
`>      elif x < 1 then 1/2*x^2`,
`>      elif x < 2 then -1/2+x-(x-1)^2`,
`>      elif x < 3 then 5/2-x+1/2*(x-2)^2`,
`>      else 0`,
`>      fi   `,
`> end:   `,
`>   `,
`> DIFF(f,1);   `,
`                proc(x)`,
`                    if x < 0 then 0`,
`                    elif x < 1 then x`,
`                    elif x < 2 then 3-2*x`,
`                    elif x < 3 then -3+x`,
`                    else 0`,
`                    fi`,
`                end`,
`   `,
`> f := proc(x,n) local i,t;`,
`>      t := x;`,
`>      for i to n do t := ln(t) od;`,
`>      t   `,
`> end:   `,
`>   `,
`> DIFF(f,1);   `,
`                proc(x,n) local i,t,tx;`,
`                    tx := 1; t := x;`,
`                    for i to n do tx := tx/t; t := ln(t) od;`,
`                    tx`,
`                end`,
`   `,
`> # compute diff( (ln@@n)(x), x$3 )`,
`> DIFF(f,1,3);`,
`                proc(x,n) local i,t,txxx,tx,txx;`,
`                    txxx := 0;`,
`                    txx := 0;`,
`                    tx := 1;`,
`                    t := x;`,
`                    for i to n do`,
`                        txxx := txxx/t-3*txx/t^2*tx+2*tx^3/t^3;`,
`                        txx := txx/t-tx^2/t^2;`,
`                        tx := tx/t;`,
`                        t := ln(t)`,
`                    od;`,
`                    txxx`,
`                end`,
`   `,
`> all_derivatives := true:`,
`> DIFF(f,1);   `,
`                proc(x,n) local i,t,tx;`,
`                    tx := 1; t := x;`,
`                    for i to n do  tx := tx/t; t := ln(t) od;`,
`                    RETURN(t,tx)`,
`                end`,
`       `,
`# compute the functional value and derviative of a polynomial which`,
`# is evaluated by Horners rule given an array b of its coefficients`,
`# and it's degree n i.e. b(x) = sum( b[i]*x^i, i=0..n ) and a[i] = b[i]`,
`> f := proc(x,b,n) local i,s;`,
`>     s := 0;`,
`>     for i from n by -1 to 0 do s := s*x+b[i] od;`,
`>     s   `,
`> end:   `,
`> DIFF(f,1);   `,
`                proc(x,b,n)`,
`                local i,s,sx;`,
`                    sx := 0;`,
`                    s := 0;`,
`                    for i from n by -1 to 0 do sx := sx*x+s; s := s*x+b[i] od;`,
`                    RETURN(s,sx)`,
`                end`,
`   `,
`SEE ALSO: D`
):

macro(A = A, P = P);

#save `DIFF.m`;
#quit
