Check-ins Using Download Hex

Artifact dbb408e971daa9bb6062f78d516cadf66fafa5ab7975dd504deeb15ca1d4c69f:

module qsum; % summation of q-hypergeometric terms

% Authors: Wolfram Koepf, Harald Boeing
% Version 1.0, May 1997.

algebraic;

% ----------------------------------------------------------------------

share !*qsumrecursion!@sub;
lisp setq(!*qsumrecursion!@sub, list(!*redefmsg, !*echo, !*output));
lisp setq(!*redefmsg, nil);
off echo;
off output;

% ------------------------------ SWITCHES ------------------------------

switch qsum_nullspace;
switch qsum_trace;
switch qgosper_down;
switch qgosper_specialsol;

switch qsumrecursion_down;
switch qsumrecursion_exp;
switch qsumrecursion_certificate;

switch qsumrecursion_profile;
lisp setq(!*qsumrecursion_profile, nil);

lisp setq(!*qsum_nullspace, nil);
lisp setq(!*qsum_trace, nil);
lisp setq(!*qgosper_down, t);
lisp setq(!*qgosper_specialsol, t);

lisp setq(!*qsumrecursion_down, t);
lisp setq(!*qsumrecursion_exp, nil);
lisp setq(!*qsumrecursion_certificate, nil);

% ------------------------ GLOBAL VARIABLES ----------------------------

clear summ;
operator summ;
clear arbcomplex;
operator arbcomplex;

share qsumrecursion_recrange!*;
qsumrecursion_recrange!*:= {1,5};


% ======================================================================

for all x,n such that fixp(n/2) and not(lisp !*complex) let 
	abs(x)^n=x^n;

% ======================================================================
% ----------------------------------------------------------------------

% BESCHREIBUNG:
%
%      new_simpexpt ist gedacht um das Fakorisieren von Exponenten
%      (bei on factor) zu verhindern.
%
%      Die alte Prozedure simpexpt wird vorher mittels
%           copyd('original_simpexpt, 'simpexpt) 
%      gesichert. Anschlie"sen kann die neue Prozedur
%      mittels 
%           copyd('simpexpt, 'new_simpexpt)
%      als neuer Standard gesetzt werden. Will man dies wieder 
%      r"uckg"angig machen, so mu"s man die alte Prozedur mittels
%           copyd('simpexpt, 'original_simpexpt)
%      wieder als Standard defininieren.
%
%
%
%        

lisp;
if null(getd 'original_simpexpt) then 
	copyd('original_simpexpt, 'simpexpt);
algebraic;

% ----------------------------------------------------------------------

symbolic procedure new_simpexpt(u);
begin
	scalar !*PRECISE, !*FACTOR, !*EXP, !*MCD, !*ALLFAC, redefmode;

	% Schalte exp ein, damit die Exponenten expandiert werden.
	% Ausschalten von PRECISE um Vereinfachungen wie
	%  (x*y)^k => x^k*y^k zu erreichen.
	on EXP, MCD;  off PRECISE, ALLFAC;  % switch-setting

	if eqcar(car u, 'minus) then
		return multsq(original_simpexpt({{'minus,1},cadr(u)}),
			new_simpexpt({cadar(u),cadr(u)}));

	% Rufe zun"achst die Original-Prozedur auf...
	% Da diese rekursive programmiert ist, kann sie sich selber wieder
	% aufrufen, so da"s sie zun"achst wieder als Standard
	% wiederherzustellen ist.
	% Zudem ist zu verhindern, da"s Warning-messages 
	% Function has been redefined erscheinen...
	redefmode:= !*redefmsg;
	!*redefmsg:= nil;
	copyd('simpexpt, 'original_simpexpt);

	u:= simpexpt u;

	copyd('simpexpt, 'new_simpexpt);

	!*redefmsg:= redefmode;

	return u;
end;

% ----------------------------------------------------------------------
%  ----------------------------------------------------------------------

% some compatibility functions for Maple sources.
% by Winfried Neun

put('PolynomQQ,'psopfn,'polynomQQQ);

algebraic procedure polynomq4(expr1,k);
begin scalar !*exp;
on exp;
return polynomqq(expr1,k);
end;


% checks if expr is rational in var
algebraic procedure type_ratpoly(expr1,var);
begin 
scalar deno, nume;
deno:=den expr1;
nume:=num expr1;
  if (PolynomQQ (deno,var) and PolynomQQ (nume,var))
    then return t else return nil;
end;
flag ('(type_ratpoly),'boolean);

symbolic procedure tttype_ratpoly(u,xx);
  ( if fixp xx then t else
        if not eqcar (xx , '!*sq) then  nil
          else and(polynomQQQ(list(mk!*sq (numr cadr xx ./ 1),
                                  reval cadr u))
                 ,polynomQQQ(list(mk!*sq (denr cadr xx ./ 1),
                                  reval cadr u)))
 ) where xx = aeval(car u);

flag ('(tttype_ratpoly),'boolean);

%checks if x is polynomial in var
symbolic procedure PolynomQ (x,var);

 if not fixp denr simp x then NIL else
 begin scalar kerns,kern,aa;

 kerns:=kernels !*q2f simp x;

 aa: if null kerns then return T;
     kern:=first kerns;
     kerns:=cdr kerns;
     if not(eq (kern, var)) and depends(kern,var)
                then return NIL else go aa;
end;

flag('(PolynomQ),'opfn);

flag ('(PolynomQ type_ratpoly),'boolean);


symbolic procedure PolynomQQQ (x);

(if fixp xx then t else
 if not onep denr (xx:=cadr xx) then NIL
 else begin scalar kerns,kern,aa,var,fform,mvv,degg;

 fform:=sfp  mvar  numr xx;
 var:=reval cadr x;
 if fform then << xx:=numr xx;
    while (xx neq 1) do
     << mvv:=mvar  xx;
        degg:=ldeg  xx;
        xx:=lc  xx;
        if domainp mvv then <<if not freeof(mvv,var) then
		<< xx:=1 ; kerns:=list list('sin,var) >> >> else
        kerns:=append ( append (kernels mvv,kernels degg),kerns) >> >>
   else kerns:=kernels !*q2f xx;

 aa: if null kerns then return T;
     kern:=first kerns;
     kerns:=cdr kerns;
     if not(eq (kern, var)) and depends(kern,var)
                then return NIL else go aa;
end) where xx = aeval(car x);

put('PolynomQQ,'psopfn,'polynomQQQ);

symbolic procedure ttttype_ratpoly(u);
  ( if fixp xx then t else
	if not eqcar (xx , '!*sq) then nil
          else and(polynomQQQ(list(mk!*sq (numr cadr xx ./ 1), reval cadr u))
                  ,polynomQQQ(list(mk!*sq (denr cadr xx ./ 1), reval cadr u)))
 ) where xx = aeval(car u);
		
flag ('(type_ratpoly),'boolean);

put('type_ratpoly,'psopfn,'ttttype_ratpoly);


% ----------------------------------------------------------------------
% ----------------------------------------------------------------------

symbolic procedure start;
begin
	return (profile_time!*:= {'list, time(), gctime()});
end$

symbolic operator start;

% ----------------------------------------------------------------------

symbolic procedure stop;
begin
	scalar gct, cput;
	gct:= gctime() - caddr(profile_time!*);
	cput:= time() - cadr(profile_time!*) - gct;
	return {'list, cput, gct};
end$
	
symbolic operator stop;

% ----------------------------------------------------------------------

symbolic procedure showprofile;
begin
	scalar tim;
	prin2 "CPU: ";
	tim:= time() - cadr(profile_time!*);
	prin2 tim;
	tim:= gctime() - caddr(profile_time!*);
	if (tim=0) then return terpri();
	prin2 " ,  GC: ";
	prin2 tim;
	terpri();
end$

symbolic operator showprofile;

% ----------------------------------------------------------------------

operator timing!-cpu!+gc!*, timing!-gc!*;

algebraic procedure timing(n);
begin
	if (n=start) then return <<clear timing!-cpu!+gc!*, timing!-gc!*;
		operator timing!-cpu!+gc!*, timing!-gc!*;>>;
	if numberp(timing!-cpu!+gc!*(n)) then <<
		timing!-gc!*(n):= (lisp gctime()) - timing!-gc!*(n);
		timing!-cpu!+gc!*(n):= (lisp time()) - timing!-cpu!+gc!*(n);
	>> else <<
		timing!-gc!*(n):= (lisp gctime());
		timing!-cpu!+gc!*(n):= (lisp time());
	>>;
	return {timing!-cpu!+gc!*(n)-timing!-gc!*(n), timing!-gc!*(n)};
end$

% ----------------------------------------------------------------------

algebraic procedure showtiming(n);
	{timing!-cpu!+gc!*(n)-timing!-gc!*(n), timing!-gc!*(n)};

% ----------------------------------------------------------------------

algebraic procedure showcputiming(n);
	timing!-cpu!+gc!*(n) - timing!-gc!*(n);

% ----------------------------------------------------------------------

algebraic procedure showgctiming(n);
	timing!-gc!*(n);

% ----------------------------------------------------------------------
% ======================================================================

symbolic procedure product2list(term);
begin
	scalar !*FACTOR, !*EXP, !*LIMITEDFACTORS, !*MCD, l, z;
	on FACTOR, MCD;  off LIMITEDFACTORS;  % switch-setting
	term:= simp aeval(term);
	z:= numr term;
	l:= {};
	while pairp(z) and (red(z) eq nil) do begin
		l:= mk!*sq(((((mvar(z) . ldeg(z)) . 1) . nil)) . 1) . l;
		z:= lc(z);
	end;
	if not(z eq 1) then l:= mk!*sq(z.1) . l;
	z:= denr term;
	while pairp(z) and (red(z) eq nil) do begin
		l:= mk!*sq(((((mvar(z) . -ldeg(z)) . 1) . red(z))) . 1) . l;
		z:= lc(z);
	end;
	if not(z eq 1) then l:= mk!*sq(1.z) . l;
	return 'list . l;
end$

symbolic operator product2list;

# ----------------------------------------------------------------------

symbolic procedure sum2list(z);
begin
	scalar !*FACTOR, !*EXP, !*MCD, !*ALLFAC, l, denom;
	on EXP, MCD; off ALLFAC;  % switch-setting
	z:= simp aeval(z);
	denom:= denr z;
	z:= numr z;
	if atom(z) or not(numberp(denom)) then 
		return 'list . {mk!*sq(z . denom)};
	l:= {};
	repeat <<
		l:= mk!*sq(((((mvar(z) . ldeg(z)) . lc(z)) . nil)) . denom) . l;
		z:= red(z);
	>> until atom(z) or null(z);
	if not(null(z)) then l:= mk!*sq(z . 1) . l;
	return 'list . l;
end$

symbolic operator sum2list;
	
# ----------------------------------------------------------------------
% ======================================================================
% ----------------------------------------------------------------------

algebraic procedure laurentcoeff(p, x);
begin
	scalar !*EXP, !*FACTOR, !*MCD, !*DIV, np, dp;
	on EXP, MCD;  off DIV;  % switch-setting
	np:= coeff(num(p),x);
	dp:= sub(x=1, den(p));
	return (for each j in np collect (j/dp));
end$

% ----------------------------------------------------------------------

algebraic procedure laurentcoeffn(p, x, n);
begin
	scalar !*EXP, !*FACTOR, !*MCD, !*RATIONAL, DMODE!*, !*DIV, np, dp, d;
	on EXP, MCD; off RATIONAL;  % switch-setting
	dp:= den(p);
	d:= deg(dp, x);
	np:= num(p) / sub(x=1,dp);
	n:= n + d;
	if (n < 0) then return 0;
	return coeffn(np,x,n);
end;

% ----------------------------------------------------------------------

algebraic procedure laurentdegree(p, x);
begin
	scalar !*EXP, !*FACTOR, !*MCD, !*DIV, !*RATIONAL, DMODE!*;
	on EXP, MCD;  off DIV, RATIONAL;  % switch-setting
	return (deg(num(p),x) - deg(den(p),x));
end$

% ----------------------------------------------------------------------

algebraic procedure laurentldegree(p, x);
begin
	scalar !*EXP, !*FACTOR, !*MCD, !*DIV, !*RATIONAL, DMODE!*;
	on EXP, MCD;  off DIV, RATIONAL;  % switch-setting
	p:= sub(x=1/x, p);
	return (deg(den(p),x) - deg(num(p),x));
end$

% ----------------------------------------------------------------------
% ----------------------------------------------------------------------
% ----------------------------------------------------------------------

symbolic procedure nullspace_size(x);
begin
	if atom(x) then
		return 1
	else
		return (nullspace_size(car x) + nullspace_size(cdr x));
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_equations2sqmatrix(gls, var, m, n);
begin
	scalar a, gl;
	timing('nullspace_equations2sqmatrix);
	a:= mkvect(m);
	for j:=0:m do putv(a, j, mkvect(n+1));
	for row:=0:m do begin
		gl:= car(gls);
		if pairp(gl) and (car(gl) = 'equal) then
			gl:= addsq(simp(cadr(gl)), negsq(simp(caddr(gl))))
		else
			gl:= simp(gl);
		gls:= cdr(gls);
		for j:=0:n do begin
			putv(getv(a,row), j, simp(coeffn(aeval mk!*sq gl, getv(var,j), 1)));
			gl:= (subsq(gl, {getv(var,j) . 0}));
		end;
		putv(getv(a,row), n+1, gl);
	end;
	timing('nullspace_equations2sqmatrix);
	return a;
end$

% ----------------------------------------------------------------------

symbolic procedure nullspacesolve(a, var);
begin
	scalar !*FACTOR, !*EXP, !*GCD, !*MCD, !*LIMITEDFACTORS, 
			m, n, nr_pref_va, va;
	timing('nullspacesolve);
	on EXP, MCD;  off GCD, LIMITEDFACTORS;  % switch-setting
	% put equations into list and remove 'zeroe-entries'...
	if pairp(a) and (car(a) = 'list) then 
		a:= cdr(a)
	else
		a:= (a . nil);
	m:= length(a);
	va:= nil;
	for j:=1:m do begin
		n:= car(a);
		a:= cdr(a);
		if (n neq 0) then va:= n . va;
	end;
	a:= va;
	% put variables in list and then into a vector
	if pairp(var) and (car(var) = 'list) then
		var:= cdr(var)
	else
		var:= (var . nil);
	m:= length(a) - 1;
	n:= length(var) - 1;
	nr_pref_va:= n;
	va:= mkvect(n);
	for j:=0:n do <<putv(va,j,car(var)); var:= cdr(var)>>;
	a:= nullspace_equations2sqmatrix(a, va, m, n);
	on FACTOR;  % switch-setting
	a:= a;
	a:= nullspace_triangulize(a, va, m, n+1, nr_pref_va);
	va:= cadr(a);
	a:= car(a);
	a:= nullspace_sort(a);
	a:= nullspace_matrix2solution(a, va);
	timing('nullspacesolve);
	return a;
end$

symbolic operator nullspacesolve;
% ----------------------------------------------------------------------

symbolic procedure nullspace_showmat(a);
begin
	scalar m, n;
	m:= upbv(a);
	n:= upbv(getv(a,1));
	for j:=0:m do begin
		prin2("{");
		for i:=0:n do begin
			prin2(prepsq getv(getv(a,j),i));
			prin2("  ");
		end;
		prin2t("}");
	end;
end$
		
% ----------------------------------------------------------------------

symbolic procedure nullspace_triangulize(a, var, m, n, nr_pref_va);
begin
	scalar tmp, c, not_changed, j, pivot;
	timing('nullspace_triangulize);
	% Determine number of equations and number of columns
	% Initialize vector c determines whether a row was "triangulized"
	c:= mkvect(m);
	for j:=0:m do putv(c,j,-1);
	not_changed:= (for j:=0:m collect j);
	% Start triangulization
	for k:=0:m do begin
		pivot:= nullspace_triangulize_pivot
			(a, not_changed, m, n-1, k, nr_pref_va);
		if (pivot neq nil) then begin
			j:= cadr(pivot);
			% Exchange columns such that pivot-element is at column k
			nullspace_triangulize_exchange_columns(a, j, k);
			% Change variable order
			tmp:= getv(var,j);
			putv(var,j,getv(var,k));
			putv(var,k,tmp);
			j:= car(pivot);
			pivot:= simp mk!*sq negsq(getv(getv(a,j),k));
			for l:=0:n do 
				putv(getv(a,j), l, simp mk!*sq quotsq(getv(getv(a,j),l),pivot));
			% Mark row j as 'used'
			putv(c,j,k);
			not_changed:= {};
			for l:=0:m do 
				if (getv(c,l) < 0) then not_changed:= l.not_changed;
			% Eliminate column-entry k in 'unused' rows
			for each h in not_changed do begin
				pivot:= getv(getv(a,h),k);
				for l:=0:k-1 do <<
					tmp:= simp mk!*sq multsq(pivot,getv(getv(a,j),l));
					tmp:= simp mk!*sq addsq(getv(getv(a,h),l),tmp);
					putv(getv(a,h),l,tmp);
				>>;
				putv(getv(a,h),k,simp(0));
				for l:=k+1:n do <<
					tmp:= simp mk!*sq multsq(pivot,getv(getv(a,j),l));
					tmp:= simp mk!*sq addsq(getv(getv(a,h),l),tmp);
					putv(getv(a,h),l,tmp);
				>>;
			end; % of for each h in not_changed
		end; % of if (pivot neq nil)
	end; % of for k:=0:n
	timing('nullspace_triangulize);
	return {a, var};
end$

% ----------------------------------------------------------------------

symbolic procedure 
	nullspace_triangulize_pivot(a, not_changed, m, n, k, nr_pref_va);
begin
	scalar !*EXP, !*FACTOR, !*MCD, !*GCD,
			row, pivot, pivotsize, l1, l2, tmp;
	timing('nullspace_triangulize_pivot);
	off FACTOR, EXP, MCD, GCD;  % switch-setting
	pivot:= nil;
	pivotsize:= {10^10, 10^10};
	for each j in not_changed do begin
		for h:=k:nr_pref_va do begin
			row:= getv(a,j);
			tmp:= getv(row,h);
			if (tmp neq simp(0)) then begin
				l1:= nullspace_size(tmp);
				if (l1 < car(pivotsize)+10) then begin
					l2:= (for r:=k:n sum
						nullspace_size(quotsq(getv(row,r),tmp)));
					if (l2 < cadr(pivotsize)+100) then begin
						pivot:= {j, h};
						pivotsize:= {l1, l2};
					end;
				end;
			end;  % of if
		end;  % of for h:=k:nr_pref_va
	end; % of for each j 
	timing('nullspace_triangulize_pivot);
	if (nr_pref_va < n) and (pivot = nil) then
		return nullspace_triangulize_pivot(a, not_changed, m, n, k, n);
	return pivot;
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_triangulize_exchange_columns(a, j, k);
begin
	scalar length_a, tmp;
	if (j = k) then return a;
	length_a:= upbv(a);
	for l:=0:length_a do begin
		tmp:= getv(getv(a,l), j);
		putv(getv(a,l), j, getv(getv(a,l),k));
		putv(getv(a,l), k, tmp);
	end;
	return a;
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_triangulize_exchange_rows(a, j, k);
begin
	scalar tmp;
	if (j = k) then return a;
	tmp:= getv(a, j);
	putv(a, j, getv(a,k));
	putv(a, k, tmp);
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_sort_comp(l1, l2);
begin
	scalar z1, z2, len1, len2, zeroe;
	zeroe:= simp(0);
	z1:= 0;
	len1:= upbv(l1);
	while (z1 <= len1) and (getv(l1,z1) = zeroe) do z1:= z1+1;
	z2:= 0;
	len2:= upbv(l2);
	while (z2 <= len2) and (getv(l2,z2) = zeroe) do z2:= z2+1;
	if (z1 > z2) then return t else return nil;
end$


% ----------------------------------------------------------------------

symbolic procedure nullspace_bubblesort(l,fn);
begin 
   scalar ln, tmp;
   ln:= upbv(l);
   for i:=0:ln do
      for j:=i+1:ln do
         if (i neq j) and apply2(fn,getv(l,j),getv(l,i)) then begin
            tmp:= getv(l,i);
				putv(l, i, getv(l,j));
				putv(l, j, tmp);
         end;
   return l;
end$


% ----------------------------------------------------------------------

symbolic procedure nullspace_sort(a);
begin
	scalar n, zeroelist, l, sorted_a;
	timing('nullspace_sort);
	a:= nullspace_bubblesort(a, 'nullspace_sort_comp);
	l:= upbv(getv(a,0));
	zeroelist:= mkvect(l);
	for j:=0:l do putv(zeroelist, j, simp(0));
	n:= 0;
	l:= upbv(a);
	while (n <= l) and (getv(a,n) = zeroelist) do n:= n+1;
	sorted_a:= mkvect(l-n);
	for j:=n:l do putv(sorted_a,j-n,getv(a,j));
	timing('nullspace_sort);
	return sorted_a;
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_matrix2solution(a, var);
begin
	scalar m, n, solu, tmp, row;
	timing('nullspace_matrix2solution);
	m:= upbv(a);
	n:= upbv(var);
	% All rows with zeroe entries (only) have been cancelled.
	% If the first row has n zeroes as first entries, then the
	% last one has to be different from zeroe, i.e. there is no
	% solution!
	solu:= (for j:=0:n collect getv(getv(a,0),j));
	if (solu = (for j:=0:n collect simp(0))) then 
		return <<timing('nullspace_matrix2solution); 'list . nil>>;
	% Backsubstitution...
	% Append 1 to variables for righhandside of equation.
	solu:= mkvect(n+1);
	for j:=0:n do putv(solu, j, simp(getv(var,j)));
	putv(solu, n+1, simp(1));
	for j:=m step (-1) until 0 do begin
		tmp:= simp(0);
		row:= getv(a,m-j);
		for h:=j+1:n+1 do 
			tmp:= addsq(tmp, multsq(negsq(getv(row,h)),getv(solu,h)));
		putv(solu, j, quotsq(tmp, getv(row,j)));
	end; % of for j
	solu:= (for j:=0:n collect
		{'equal, getv(var,j), mk!*sq(getv(solu,j))});
	timing('nullspace_matrix2solution);
	return ('list . solu);
end$

% ----------------------------------------------------------------------

algebraic procedure nullspace_profile();
begin
	write "nullspace_coefflist:        ", 
		showcputiming(nullspace_equations2sqmatrix);
	write "nullspace_triangulize:      ", 
		showcputiming(nullspace_triangulize);
	write "nullspace_triangulize_pivot:",
		showcputiming(nullspace_triangulize_pivot);
	write "nullspace_sort:             ", 
		showcputiming(nullspace_sort);
	write "nullspace_matrix2solution:  ",
		showcputiming(nullspace_matrix2solution);
	write "nullspace:                  ",
		showcputiming(nullspacesolve), "   (", showgctiming(nullspacesolve), ")";
end$

% ----------------------------------------------------------------------
% ======================================================================

algebraic procedure trace_qsum(text, term);
begin
	if (lisp !*qsum_trace) then 
		write text, "    ", (sub(!*qsumrecursion!@sub, term));
end$

% ======================================================================
% ----------------------------------------------------------------------

symbolic procedure qsumrecursion_number(n, d);
begin
	scalar l, b;
	l:= explode reval n;
	b:= d-length(l);
	if (b > 0) then for j:=1:b do prin2(" ");
	for each j in l do prin1 compress list(j);
end;
	
% ----------------------------------------------------------------------

symbolic procedure qsumrecursion_qprofile;
begin 
	scalar qrat, qupd, qdis, qfin, qsol, qdeg, qsum, qsgc, maxt, lmax;
	qrat:= reval showcputiming('qratios);
	qupd:= reval showcputiming('qupdate);
	qdis:= reval showcputiming('qdispersionset);
	qfin:= reval showcputiming('qfindf);
	qsol:= reval showcputiming('solve);
	qdeg:= reval showcputiming('qdegreebound);
	qsum:= reval showcputiming('qsumrecursion);
	qsgc:= reval showgctiming('qsumrecursion);
	maxt:= length explode max(qrat,qupd,qdis,qsol,qdeg,qsum);
	lmax:= length explode max(qdis,qsol,qsgc);
	prin2t " ";
	prin2  " qratios:        ";
	qsumrecursion_number(qrat, maxt);
	prin2t "";
	prin2  " qupdate:        ";
	qsumrecursion_number(qupd, maxt);
	prin2  "     (";
	qsumrecursion_number(qdis, lmax);
	prin2t " qdispersionset)";
	prin2  " qfindf:         ";
	qsumrecursion_number(qfin, maxt);
	prin2  "     (";
	qsumrecursion_number(qsol, lmax);
	prin2  " solve,  ";
	prin2  qdeg; %qsumrecursion_number(qdeg, lmax);
	prin2t " qdegreebound)";
	prin2  " qsumrecursion:  ";
	qsumrecursion_number(qsum, maxt);
	prin2  "     (";
	qsumrecursion_number(qsgc, lmax);
	prin2t " gc-time)";
end$

symbolic operator qsumrecursion_qprofile;

% ----------------------------------------------------------------------
% ======================================================================

clear binomial, qpochhammer, qfac, qbinomial, qbrackets, qfactorial;
operator binomial, qpochhammer, qfac, qbinomial, qbrackets, qfactorial;

% ======================================================================

algebraic procedure qpsihyperterm(nu, de, q, z, n);
begin
	scalar	r, s;
   r:= length(nu);
   s:= length(de);
	nu:= (for each j in nu product qpochhammer(j,q,n));
	de:= (for each j in de product qpochhammer(j,q,n));
   nu:= nu * (-1)^((s-r)*n) * q^((s-r)*n*(n-1)/2) * z^n;
   return nu/de;
end$

# ----------------------------------------------------------------------

algebraic procedure qphihyperterm(nu, de, q, z, n);
begin
	scalar r, s;
   r:= length(nu);
   s:= length(de);
	nu:= (for each j in nu product qpochhammer(j,q,n));
	de:= (for each j in de product qpochhammer(j,q,n));
   nu:= nu * z^n * ((-1)^n*q^(n*(n-1)/2))^(1+s-r);
   return nu/(de * qpochhammer(q,q,n));
end$


% ======================================================================
% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_standard_integer_part_sf(f);
begin
	scalar l, tmp, z;
	l:= nil;
	while pairp(f) do <<
		tmp:= qsimpcomb_standard_integer_part_sf(lc f);
		z:= ((mvar f).(ldeg f));
		repeat <<
			l:= (((z.car(tmp)).nil) . l);
			tmp:= cdr(tmp);
		>> until null(tmp);
		f:= red f;
	>>;
	if not(null f) then l:= (f . l);
	return l;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_standard_integer_part(z);
begin
	scalar !*BALANCED_MOD, !*EXP, !*FACTOR, !*RATIONAL, !*DMODE,
		n, d, tmp;
	on EXP;  off BALANCED_MOD, RATIONAL;  % switch-setting
	z:= simp aeval mk!*sq z;
	n:= numr z;
	d:= denr z;
	n:= qsimpcomb_standard_integer_part_sf n;
	if null(n) then return 0;
	z:= simp 0;
	repeat <<
		tmp:= simp mk!*sq (car(n) . d);
		if (fixp numr tmp) and (fixp denr tmp) then z:= addsq(z, tmp);
		n:= cdr n;
	>> until null(n);
	if ((denr z) eq 1) then
		if null(numr z) then return 0 else return (numr z);
	n:= numr z;
	d:= denr z;
	z:= (car qremf(n,d));
	if (null(z) and !:minusp(n)) or !:minusp(z) then
		z:= addf(z,-1);
	if null(z) then return 0 else return z;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_standard_qexp_part_sf(f,q);
begin
	scalar p, z;
	p:= simp nil;
	while pairp(f) and (null (red f)) do <<
		if (mvar(f) eq q) then
			p:= addsq(p, simp(ldeg f))
		else 
			begin
				z:= mvar f;
				if pairp(z) and (car(z) eq 'expt) and (cadr(z) eq q) then
					p:= addsq(p, simp({'times,caddr z,ldeg(f)}));
			end;
		f:= lc f;
	>>;
	return p;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_standard_qexp_part(a,q,qe);
begin
	scalar !*FACTOR, !*EXP, n, d;
	on FACTOR;  % switch-setting
	a:= simp aeval mk!*sq a;
	n:= numr a;
	d:= denr a;
	n:= qsimpcomb_standard_qexp_part_sf(n,q);
	d:= qsimpcomb_standard_qexp_part_sf(d,q);
	n:= subtrsq(n,d);
	n:= qsimpcomb_standard_integer_part(quotsq(n,(simp qe)));
	d:= simp {'expt,q,{'times,mk!*sq(simp n),qe}};
	if null(simp aeval mk!*sq(subtrsq(a, d))) then
		n:= !:difference(n,-1);
	return (n);
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qpochhammer_finite(u);
begin
	scalar k, f, f1, jj;
	k:= caddr(u);
	f:= simp(1);
	if !:zerop(k) then return f;
	jj:= gensym();
	f1:= simp({'difference,1,{'times,car(u),{'expt,cadr(u),jj}}});
	if !:minusp(k) then
		(for j:=k:-1 do f:= quotsq(f,subsq(f1,{jj.j})))
	else <<
		k:= reval({'difference,k,1});
		for j:=0:k do f:= multsq(f,subsq(f1,{jj.j}));
	>>;
	return f;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qpochhammer_infinity(u,a,q,qe,k,m);
begin
	scalar jj, f, f2;
	if (k eq simp({'minus,'infinity})) or !:zerop(m) then
		return mksq(('qpochhammer.u),1)
	else if (k neq simp('infinity)) then
		rederr "Invalid arguments in qpochhammer.";
	f:= simp(1);
	jj:= gensym();
	a:= prepsq quotsq(a, simp {'expt,q,{'times,qe,m}});
	f2:= simp {'difference,1,{'times,a,{'expt,q,{'times,qe,jj}}}};
	if !:minusp(m) then % (m < 0)
		for j:=m:-1 do f:= multsq(f, subsq(f2, {jj.j}))
	else % (m >= 0)
		for j:=0:m-1 do f:= quotsq(f, subsq(f2, {jj.j}));
	f:= multsq(f, mksq({'qpochhammer,a,cadr(u),caddr(u)},1));
	return f;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qpochhammer(u);
begin
	scalar a, q, qq, qe, k, n, m, f, jj, f1, f2;

	if (length(u) neq 3) then
		rederr "Invalid number of arguments in qpochhammer";

	if fixp(caddr u) then
		return qsimpcomb_qpochhammer_finite(u);

	a:= simp car u;
	qq:= simp cadr u;
	q:= qq;
	k:= simp caddr u;

	% Die vereinfachten Argumente wieder als Liste nach u,
	% damit der zur"uckgelieferte qpochhammer-Term
	% standardisierte Argumente besitzt. (Sonst k"urzen sich diese
	% unter Umst"anden nicht ordentlich weg...)
	u:= {prepsq(a), prepsq(qq), prepsq(k)};

	if idp(cadr u) then <<
		qe:= 1;
		q:= mvar(numr q);
	>> else if (denr(q) eq 1) then <<
		q:= numr q;
		qe:= ldeg q;
		if not(lc(q) eq 1) or not(idp(mvar q)) then 
			rederr "Invalid arguments in qpochhammer";
		q:= mvar q;
	>> else if (numr(q) eq 1) then <<
		q:= denr q;
		qe:= -(ldeg q);
		if not(lc(q) eq 1) or not(idp(mvar q)) then
			rederr "Invalid arguments in qpochhammer.";
		q:= mvar q;
	>> else
		rederr "Invalid arguments in qpochhammer.";

	if null(a) then return (simp 1);

	if (a eq qq) then
		m:= 0
	else <<
		m:= qsimpcomb_standard_qexp_part(a,q,qe);
		if (a eq simp({'expt,q,{'times,qe,m}})) and !:minusp(!:minus(m)) then 
			m:= !:difference(m,1);
	>>;
	n:= qsimpcomb_standard_integer_part(k);

	if !:zerop(n) and !:zerop(m) then 
		return mksq(('qpochhammer.u),1);

	if not(freeof(k,'infinity)) then
		return qsimpcomb_qpochhammer_infinity(u,a,q,qe,k,m);

	f:= simp 1;
	jj:= gensym();
	qq:= cadr u;
	a:= prepsq quotsq(a, simp {'expt,q,{'times,m,qe}});
	k:= prepsq subtrsq(k,simp(n));
	f1:= simp {'difference,1,{'times,a,{'expt,q,{'times,qe,{'plus,jj,k}}}}};
	f2:= simp {'difference,1,{'times,a,{'expt,q,{'times,qe,jj}}}};
	if !:minusp(!:plus(n,m)) then  % (m+n < 0)
		if !:minusp(m) then <<  % (m < 0)
			for j:=m+n:-1 do f:= quotsq(f, subsq(f1, {jj.j}));
			for j:=m:-1 do f:= multsq(f, subsq(f2, {jj.j}));
		>> else << % (m >= 0)
			for j:=m+n:-1 do f:= quotsq(f, subsq(f1, {jj.j}));
			for j:=0:m-1 do f:= quotsq(f, subsq(f2, {jj.j}));
		>>
	else % (m+n >= 0)
		if !:minusp(m) then <<  % (m < 0)
			for j:=0:n+m-1 do f:= multsq(f, subsq(f1, {jj.j}));
			for j:=m:-1 do f:= multsq(f, subsq(f2, {jj.j}));
		>> else << % (m >= 0)
			for j:=0:n+m-1 do f:= multsq(f, subsq(f1, {jj.j}));
			for j:=0:m-1 do f:= quotsq(f, subsq(f2, {jj.j}));
		>>;
	u:= multsq(f, mksq({'qpochhammer,a,qq,k},1));
	return u;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_binomial(u);
begin
	scalar f, n, k;
	if not(fixp(cadr(u)) and (cadr(u) >= 0)) then
		return mksq({'binomial,car u,cadr u},1);
	n:= simp(car u);
	k:= cadr u;
	if (k eq 0) then return simp(1);
	f:= simp 1;
	for j:=0:(!:difference(k,1)) do f:= multsq(f, subtrsq(n,simp(j)));
	f:= quotsq(f, simp({'factorial,k}));
	return f;
end;
  
% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qbinomial(u);
begin
	scalar n, k, q;
	n:= car u;
	k:= cadr u;
	q:= caddr u;
	u:= {'quotient,{'qpochhammer,q,q,n},{'times,
		{'qpochhammer,q,q,k},{'qpochhammer,q,q,{'difference,n,k}}}};
	return mksq(u,1);
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qbrackets(u);
begin
	scalar n, q;
	n:= car u;
	q:= cadr u;
	u:= {'quotient,{'difference,{'expt,q,n},1},{'difference,q,1}};
	return mksq(u,1);
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qfactorial(u);
begin
	scalar n, q;
	n:= car u;
	q:= cadr u;
	u:= {'quotient,{'qpochhammer,q,q,n},{'expt,{'difference,1,q},n}};
	return mksq(u,1);
end;


% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qfac(u);
begin
	return mksq(('qpochhammer . u), 1);
end;
% ----------------------------------------------------------------------

symbolic procedure qsimplify(f);
begin
	scalar !*precise, !*factor, !*exp, !*mcd, !*gcd, !*rational,
		redefmode, orig_bino, orig_qbin, orig_qbra, orig_qfct,
		orig_qfac, orig_qpoc;
	on FACTOR, MCD, GCD;  off RATIONAL, PRECISE;  % switch-setting

	if (length(f) neq 1) then
		rederr "Wrong number of arguments in qsimp";

	% Install the procedure new_simpexpt, which does more rigid
	% simplifications of powers and save original one
	% AND prevent redefined-messages.
	redefmode:= !*redefmsg;
	!*redefmsg:= nil;
	copyd('simpexpt, 'new_simpexpt);
	orig_bino:= get('binomial,    'simpfn);
	put('binomial,    'simpfn, 'qsimpcomb_binomial);

	f:= aeval(car f);

	% Get old 'simplify-functions' for q-expressions
	orig_qbin:= get('qbinomial,   'simpfn);
	orig_qbra:= get('qbrackets,   'simpfn);
	orig_qfct:= get('qfactorial,  'simpfn);
	orig_qfac:= get('qfac,        'simpfn);
	orig_qpoc:= get('qpochhammer, 'simpfn);

	% Declare all 'simplify-functions' for q-expressions
	put('qbinomial,   'simpfn, 'qsimpcomb_qbinomial);
	put('qbrackets,   'simpfn, 'qsimpcomb_qbrackets);
	put('qfactorial,  'simpfn, 'qsimpcomb_qfactorial);
	put('qfac,        'simpfn, 'qsimpcomb_qpochhammer);
	put('qpochhammer, 'simpfn, 'qsimpcomb_qpochhammer);

	% Simplify expression
	rmsubs();
	f:= mk!*sq(simp(reval f));

	% Hide all 'simplify-functions
	put('binomial,    'simpfn, orig_bino);
	put('qbinomial,   'simpfn, orig_qbin);
	put('qbrackets,   'simpfn, orig_qbra);
	put('qfactorial,  'simpfn, orig_qfct);
	put('qfac,        'simpfn, orig_qfac);
	put('qpochhammer, 'simpfn, orig_qpoc);

	% Restore old simpexpt and former !*redefmsg-mode
	copyd('simpexpt, 'original_simpexpt);
	!*redefmsg:= redefmode;

	return f;
end;

put('qsimpcomb, 'psopfn, 'qsimplify);

% ----------------------------------------------------------------------
% ======================================================================

algebraic procedure down_qratio(a, k);
begin
   a:= qsimpcomb(a / sub(k=k-1,a));
	return a;
end$

% ----------------------------------------------------------------------

algebraic procedure up_qratio(a, k);
begin
   a:= qsimpcomb(sub(k=k+1,a) / a);
	return a;
end$

% ----------------------------------------------------------------------

algebraic procedure qratio(a, k);
begin
   a:= qsimpcomb(sub(k=k+1,a) / a);
	return a;
end$

% ======================================================================

% ----------------------------------------------------------------------

% select patch by W. Neun 12.96

symbolic procedure select!-eval u;
 % select from a list l members according to a boolean test.
 begin scalar l,w,v,r;
  l := reval cadr u; w := car u;
  if atom l or (car l neq'list and not flagp(car l,'nary)) then
           typerr(l,"select operand");
  if idp w and get(w,'number!-of!-args)=1 then w:={w,{'~,'!&!&}};
  if eqcar(w,'replaceby) then <<v:=cadr w;w:=caddr w>>;
  w:=freequote formbool(w,nil,'algebraic);
  if v then w:={'replaceby,v,w};
  r:=for each q in
        pair(cdr map!-eval1(l,w,function(lambda y;y),'lispeval),cdr l)
      join if car q and car q neq 0 then {cdr q};
  if r then return car l . r;
  if (r:=atsoc(car l,'((plus . 0)(times . 1)(and . 1)(or . 0))))
    then return cdr r
   %else rederr {"empty selection for operator ",car l}
    else return list('list);
end$

% ======================================================================

algebraic procedure type_homogeneous(f,z);
begin
	scalar !*EXP, !*FACTOR, !*MCD, c, deg_f;
	on EXP, MCD;  % switch-setting
	if not(type_ratpoly(f,z)) then return nil;
	deg_f:= laurentdegree(f,z);
	c:= laurentcoeffn(f,z,deg_f);
	if ((f - c*z^deg_f) = 0) and freeof(c,z) then return t;
	return nil;
end$

% ----------------------------------------------------------------------

algebraic procedure qgosper_qprimedispersion(f, g, q, qk);
begin
	scalar !*EXP, !*FACTOR, !*GCD, !*MCD, n, m, a, b, c, d, j;
	on EXP, MCD;  off GCD; % switch-setting
	f:= f;
	n:= laurentdegree(f,qk);
	if (n = 0) or (n neq laurentdegree(g,qk)) then return {};
	m:= laurentldegree(f, qk);
	if (m = n) or (m neq laurentldegree(g, qk)) then return {};
	a:= laurentcoeffn(f,qk,n);
	b:= laurentcoeffn(f,qk,m);
	c:= laurentcoeffn(g,qk,n);
	d:= laurentcoeffn(g,qk,m);
	on GCD;  % switch-setting
	j:= a*d / (b*c);
	off GCD;  % switch-setting
	if not type_homogeneous(j,q) then return {};
	j:= laurentdegree(j,q) / (n-m);
	if not(fixp(j) and (-1 < j)) then return {};
	m:= sub(qk=qk*q^j, g);
	c:= laurentcoeffn(m, qk, n);
	if ((c*f-a*m) = 0) then return j;
	return {};
end$

% ----------------------------------------------------------------------

algebraic procedure qgosper_qdispersionset_simple_factorlist(p, x);
begin
	scalar !*EXP, !*FACTOR, !*GCD, !*LIMITEDFACTORS, !*MCD;
	on FACTOR, MCD;  off GCD, LIMITEDFACTORS;  % switch-setting
	p:= product2list(p);
	p:= (for each j in p collect if (arglength(j)>-1) and
		(part(j,0)=expt) and (fixp(part(j,2))) then part(j,1) else j);
	p:= select(not freeof(~z,x), p);
	return p;
end$

% ----------------------------------------------------------------------

algebraic procedure qgosper_qdispersionset(qq, rr, q, qk);
begin
	scalar disp, j;
	timing(qdispersionset);
	qq:= qgosper_qdispersionset_simple_factorlist(qq, qk);
	rr:= qgosper_qdispersionset_simple_factorlist(rr, qk);
	disp:= {};
	for each f in qq do 
		for each g in rr do begin
			j:= qgosper_qprimedispersion(f,g,q,qk);
			if (j neq {}) and not(j member disp) then disp:= j.disp;
		end;
	trace_qsum("dispersionset:", disp);
	timing(qdispersionset);
	return disp;
end$

% ======================================================================

algebraic procedure qgosper_qupdate(pp, qq, rr, q, qk);
begin
	scalar !*FACTOR, !*EXP, !*MCD, !*DIV, !*GCD, !*LIMITEDFACTORS, disp, g;
	timing(qupdate);
	on FACTOR, MCD, DIV;  off LIMITEDFACTORS;  % switch-setting
	disp:= qgosper_qdispersionset(qq, rr, q, qk);
	for each j in disp do begin
		on EXP;  % switch-setting;
		g:= gcd(qq, sub(qk=qk*q^j,rr));
		on FACTOR;  % switch-setting
		if not freeof(g, qk) then begin
			qq:= qq / g;
			rr:= rr / sub(qk=qk/q^j, g);
			pp:= pp * (for l:=0:j-1 product sub(qk=qk/q^l, g));
		end;  % of if
	end;  % of for
	trace_qsum("q-Gosper representation:", {pp, qq, rr});
	timing(qupdate);
	return {pp, qq, rr};
end$

% ======================================================================

algebraic procedure qgosper_qdegreebound_q_exponent(f, q);
begin
	scalar !*EXP, !*FACTOR, !*MCD, !*GCD, !*COMBINELOGS, !*EXPANDLOGS;
	on EXPANDLOGS, EXP, MCD, GCD;  OFF COMBINELOGS;  % switch-setting
	return log(f)/log(q);
end$

% ----------------------------------------------------------------------

algebraic procedure qgosper_qdegreebound(pp, qq, rr, q, qk);
begin
	scalar !*MCD, !*FACTOR, !*EXP, !*GCD,
			ldegpp,ldegqq,ldegrr,ldegff,dd,ee,degpp,degqq,degrr,degff;
	timing(qdegreebound);
	on EXP, MCD;  off GCD;  % switch-setting
	% untere Gradschranke
	ldegpp:= laurentldegree(pp, qk);
	ldegqq:= laurentldegree(qq, qk);
	ldegrr:= laurentldegree(rr, qk);
	if (ldegqq neq ldegrr) then
		ldegff:= ldegpp - min(ldegqq, ldegrr)
	else begin
		dd:= laurentcoeffn(qq, qk, ldegqq);
		ee:= laurentcoeffn(rr, qk, ldegqq);
		ee:= qgosper_qdegreebound_q_exponent(ee/dd, q);
		if fixp(ee) then
			ldegff:= min(ee,ldegpp) - ldegqq
		else
			ldegff:= ldegpp - ldegqq;
	end; % of else
	% obere Gradschranke
	degpp:= laurentdegree(pp, qk);
	degqq:= laurentdegree(qq, qk);
	degrr:= laurentdegree(rr, qk);
	if (degqq neq degrr) then
		degff:= degpp - max(degqq, degrr)
	else begin
		dd:= laurentcoeffn(qq, qk, degqq);
		ee:= laurentcoeffn(rr, qk, degqq);
		ee:= qgosper_qdegreebound_q_exponent(ee/dd, q);
		if fixp(ee) then
			degff:= max(ee,degpp) - degqq
		else
			degff:= degpp - degqq;
	end; % of else
	timing(qdegreebound);
	if (degff < ldegff) then return {};
	return {ldegff, degff};
end$

% ======================================================================

symbolic procedure qsumrecursion_inds2arbcmplx(u);
begin
	scalar solu, var, arbsubs, gl, tmp, j;
	solu:= car u;
	if not(freeof(solu, 'arbcomplex)) then return solu;
	if null(cdr(solu)) then return 'list.nil;
	if (caadr(solu) eq 'list) then solu:= 'list. cdadr(solu);
	solu:= cdr(solu);
	var:= cdr(reval cadr(u));
	arbsubs:= nil;
	for each gl in solu do <<
		tmp:= var;
		while (tmp neq nil) do <<
			j:= car(tmp);
			tmp:= cdr(tmp);
			if pairp(gl) and not(freeof(caddr(gl),j)) then <<
				arbsubs:= {'equal,j,prepsq(!*f2q(makearbcomplex()))}.arbsubs;
				var:= delete(j, var);
			>>;
		>>;
	>>;
	if (arbsubs eq nil) then return car u;
	arbsubs:= 'list . arbsubs;
	tmp:= nil;
	while (solu neq nil) do <<
		gl:= car(solu);
		solu:= cdr(solu);
		if pairp(gl) then
			caddr(gl):= reval({'sub, arbsubs, caddr(gl)});
		tmp:= gl . tmp;
	>>;
	tmp:= 'list . tmp;
	return tmp;
end$

put('qsumrecursion_indets2arbcomplex, 'psopfn, 'qsumrecursion_inds2arbcmplx);

% ======================================================================

algebraic procedure qgosper_qfindf(pqr, q, qk);
begin
	scalar !*EXP, !*FACTOR, !*MCD, !*CRAMER, 
			pp, qq, rr, d, var, f, a, i, eqn, solu;
	timing(qfindf);
	on EXP, MCD;  % switch-setting
	pp:= part(pqr, 1);
	qq:= part(pqr, 2);
	rr:= part(pqr, 3);
	d:= qgosper_qdegreebound(pp, qq, rr, q, qk);
	trace_qsum("degreebounds:", d);
	if (d = {}) then return <<timing(qfindf); {}>>;
	var:= (for j:=part(d,1):part(d,2) collect (lisp gensym()));
	f:= (for j:=part(d,1):part(d,2) sum part(var,j-part(d,1)+1)*qk^j);
	eqn:= sub(qk=qk*q,qq)*f - rr*sub(qk=qk/q,f) - pp;
	eqn:= laurentcoeff(eqn,qk);
	on CRAMER;  % switch-setting
	timing(solve);
	if (lisp !*qsum_nullspace) then
		solu:= nullspacesolve(eqn, var)
	else
		solu:= solve(eqn, var);
	timing(solve);
	on FACTOR;  % switch-setting
	if (solu = {}) then return <<timing(qfindf); {}>>;
	solu:= qsumrecursion_indets2arbcomplex(solu, var);
	f:= sub(solu, f);
	for each j in var do if not(freeof(f,j)) then
		sub(j=(lisp mk!*sq !*f2q makearbcomplex()), f);
	timing(qfindf);
	return f;
end$

% ======================================================================

% Old Version with f as laurentpolynomial:
% f:= (for j:=part(d,1):part(d,2) sum part(var,j-part(d,1)+1)*qk^j);
% eqn:= sub(qk=qk*q,qq)*f - rr*sub(qk=qk/q,f) - pp;
% eqn:= laurentcoeff(eqn, qk);

algebraic procedure qsumrecursion_qfindf_equations
	(pp, qq, rr, d, q, qk, sigma_var);
begin
	scalar !*EXP, !*FACTOR, !*LIMITEDFACTORS, !*MCD, !*CRAMER,
			var, f, eqn, solu, ld;
	on EXP, MCD;  % switch-setting
	var:= (for j:=part(d,1):part(d,2) collect (lisp gensym()));
	if (part(d,1) < 0) then begin
		f:= (for j:=0:part(d,2)-part(d,1) sum part(var,j+1)*qk^j);
		ld:= -part(d,1);
		eqn:= sub(qk=qk*q^2,qq)*sub(qk=qk*q,f) - sub(qk=qk*q,rr)*f*
				q^ld - sub(qk=qk*q,pp)*qk^ld*q^ld;
		end
	else begin
      f:= (for j:=part(d,1):part(d,2) sum part(var,j+part(d,1)+1)*qk^j);
		eqn:= sub(qk=qk*q^2,qq)*sub(qk=qk*q,f) - sub(qk=qk*q,rr)*f - 
				sub(qk=qk*q,pp);
	end;

	var:= append(sigma_var, var);
	timing(solve);
	if (lisp !*qsum_nullspace) then begin
		eqn:= coeff(eqn, qk);
		for each i in var do factor i;
		on FACTOR, MCD;  % switch-setting
		eqn:= eqn;
		solu:= nullspacesolve(eqn, var);
		for each i in var do remfac i;
		end
	else begin
		on CRAMER;  % switch-setting
		eqn:= coeff(eqn, qk);
		solu:= solve(eqn, var);
	end; % of else
	timing(solve);
	if (solu = {}) then return {};
	solu:= qsumrecursion_indets2arbcomplex(solu, var);
	if (lisp !*qsumrecursion_certificate) then <<
		f:= sub(solu, f);
	>> else
		f:= nil;
	solu:= {f, select(qsumrecursion_has(~w,sigma_var), solu)};
	if (lisp !*qsumrecursion_exp) and not(lisp !*qsum_nullspace) then 
		on EXP  % switch-setting
	else 
		on FACTOR;  % switch-setting
	solu:= reval solu;
	return solu;
end$

% ======================================================================

symbolic procedure qsumrecursion_has(z, varlist);
begin
	scalar has;
	has:= nil;
	repeat <<
		varlist:= cdr varlist;
		has:= not freeof(z, car varlist);
	>> until null(cdr varlist) or has;
	return has;
end$
		
symbolic operator qsumrecursion_has$
	
% ======================================================================

algebraic procedure qsumrecursion_qfindf(pqr, q, qk, sigma_var);
begin
	scalar !*FACTOR, !*EXP, !*LIMITEDFACTORS, !*MCD, !*CRAMER, 
			pp, qq, rr, d, var, f, a, i, eqn, solu;
	timing(qfindf);
	on EXP, MCD;  % switch-setting
	pp:= part(pqr, 1);
	qq:= part(pqr, 2);
	rr:= part(pqr, 3);
	d:= qgosper_qdegreebound(pp, qq, rr, q, qk);
	trace_qsum("degreebounds:", d);
	if (d = {}) then return <<timing(qfindf); {}>>;
	solu:= qsumrecursion_qfindf_equations(pp, qq, rr, d, q, qk, sigma_var);
	timing(qfindf);
	return solu;
end$

% ======================================================================
# ----------------------------------------------------------------------

symbolic procedure qsumrecursion_range(x);
begin
	scalar lo, hi;
	if (length(qsumrecursion_recrange!*) neq 3) or
		not(pairp(qsumrecursion_recrange!*) and 
		(car(qsumrecursion_recrange!*) = 'list)) then <<
		write "Global variable qsumrecursion_recrange!* must be a list";
		write "of two positive integers: {lo,hi} with lo<=hi.";
		rederr "Invalid value of qsumrecursion_recrange!*";
	>>;
	lo:= cadr(qsumrecursion_recrange!*);
	hi:= caddr(qsumrecursion_recrange!*);
	if not(fixp(lo) and fixp(hi) and (0<lo) and (lo<=hi)) then <<
		write "Global variable qsumrecursion_recrange!* must be a list";
		write "of two positive integers: {lo,hi} with lo<=hi.";
		rederr "Invalid value of qsumrecursion_recrange!*";
	>>;
	if null(x) then return {'list, lo, hi};
	if (length(x) neq 1) then rederr "Wrong type of arguments.";
	x:= car(x);
	if (fixp(x)) and (x > 0) then return {'list, x, x};
	if atom(x) or (car(x) neq 'list) or (length(x) neq 3) then 
		rederr "Wrong type of arguments.";
	x:= cdr(x);
	lo:= car(x);
	hi:= cdr(x);
	if not(fixp(lo) and fixp(hi) and (lo<=hi) and (0<lo)) then
		rederr "Wrong type of arguments.";
	return {'list, lo, hi};
end$

# ----------------------------------------------------------------------

symbolic procedure qsumrecursion_qhyper(arg);
begin 
	scalar nu, de, q, z, n;
	if (length(arg) < 5) then return nil;
	nu:= car(arg);
	if atom(nu) or (car(nu) neq 'list) then return nil;
	de:= cadr(arg);
	if atom(de) or (car(de) neq 'list) then return nil;
	arg:= cddr(arg);
	q:= car(arg);
	if not(idp(q)) then
		if atom(q) and (car(q) neq 'expt) or not(idp(cadr(q))) or
			not(fixp(caddr(q))) then return nil;
	z:= cadr(arg);
	n:= caddr(arg);
	if not(idp(n) or ((length(n) eq 2) and 
		idp(car n) and idp(cadr n))) then return nil;
	return t;
end$

# ----------------------------------------------------------------------

symbolic procedure qsumrecursion(arg);
begin
	scalar nargs, f, q, k, n, recrange, prefac, nu, de, z, func;
	arg:= (for each j in arg collect reval j);
	nargs:= length(arg);
	if (nargs < 4) or (7 < nargs) then
		rederr "Wrong number of arguments.";
	q:= cadr(arg);
	% Is it a call like qsumrecursion(f,q,k,func,n)?
	if idp(q) then begin
		f:= car(arg);
		arg:= cddr(arg);
		k:= car(arg);
		n:= cadr(arg);
		if not(idp(k)) and not(idp(n) or 
			((length(n) eq 2) and idp(car n) and idp(cadr n))) then
			rederr "Wrong type of arguments.";
		if idp(n) then 
			func:= 'summ
		else begin
			func:= car(n);
			n:= cadr(n);
		end;  % of if
		recrange:= qsumrecursion_range(cddr(arg));
		end
	else if qsumrecursion_qhyper(arg) then begin
		nu:= car(arg);
		de:= cadr(arg);
		q:= caddr(arg);
		arg:= cdddr(arg);
		z:= car(arg);
		k:= gensym();
		n:= cadr(arg);
		if idp(n) then 
			func:= 'summ
		else begin
			func:= car(n);
			n:= cadr(n);
		end;  % of if
		f:= qphihyperterm(nu,de,q,z,k);
		if not(idp(q)) then q:= cadr(q);
		recrange:= qsumrecursion_range(cddr(arg));
		end
	else if qsumrecursion_qhyper(cdr arg) then begin
		prefac:= car(arg);
		arg:= cdr(arg);
      nu:= car(arg);
      de:= cadr(arg);
      q:= caddr(arg);
      arg:= cdddr(arg);
      z:= car(arg);
      k:= gensym();
		n:= cadr(arg);
		if idp(n) then 
			func:= 'summ
		else begin
			func:= car(n);
			n:= cadr(n);
		end;  % of if
		f:= qphihyperterm(nu,de,q,z,k);
      f:= aeval {'times, prefac, f};
		if not(idp(q)) then q:= cadr(q);
      recrange:= qsumrecursion_range(cddr(arg));
		end
	else 
		rederr "Wrong type of arguments.";
	f:= qsumrecursion_eval(f,q,k,func,n,recrange);
	return f;
end$

put('qsumrecursion, 'psopfn, 'qsumrecursion);

# ----------------------------------------------------------------------

symbolic procedure qgosper(arg);
begin
	scalar f, q, k, m, n;
	arg:= (for each j in arg collect reval(j));
	if (length(arg) neq 3) and (length(arg) neq 5) then
		rederr "Wrong number of arguments.";
	f:= car(arg);
	q:= cadr(arg);
	k:= caddr(arg);
	if not(idp(q)) or not(idp(k)) then
		rederr "Wrong type of arguments.";
	if freeof(f,k) then <<
		write "WARNING: Summand is independent of summation variable.";
		rederr "No q-hypergeometric antidifference exists.";
	>>;
	arg:= cdddr(arg);
	if not(null(arg)) then begin
		m:= car(arg);
		n:= cadr(arg);
		%if not(freeof(m,k)) or not(freeof(n,k)) then
		%	rederr "Summation bounds contain the summation variable.";
	end;
	f:= qgosper_eval(f,q,k);
	if not(null(arg)) then begin
		f:= simp(f);
		if !*qgosper_down then
			m:= aeval {'plus, m, list('minus, 1)}
		else
			n:= aeval {'plus, n, 1};
		f:= subtrsq(subsq(f,{k . n}), subsq(f,{k . m}));
		f:= mk!*sq(f);
	end;  % of if
	return f;
end$

put('qgosper, 'psopfn, 'qgosper);

# ----------------------------------------------------------------------
% ======================================================================

algebraic procedure qgosper_eval(a, q, k);
begin
	scalar !*PRECISE, !*EXP, !*FACTOR, !*MCD, qk, pqr, f, redefmode;
	on FACTOR, MCD; off PRECISE;  % switch-setting

	% Turn off function-has-been-redefined-messages.
	share redefmode;
	redefmode:= (lisp !*redefmsg);
	lisp (!*redefmsg:= nil);

	% Set new_simpexpt as standard which does more simplifications
	% on power-terms:
	copyd('simpexpt, 'new_simpexpt);

	qk:= (lisp gensym());
	f:= down_qratio(a,k);
% qsimpcomb_simpexpt shouldn't be necessary any longer (new_simpexpt!)
% f:= qsimpcomb_simpexpt(down_qratio(a,k), q);

	if (lisp !*qsum_trace) then
		write "Applied substitution: ", q^k=k;
	!*qsumrecursion!@sub:= {qk=k};
	trace_qsum("down ratio wrt. k:", sub(qk=k,f));
	f:= (f where (q^k=>qk));
	if not(freeof(f,k)) then 
		rederr "Input term is probably not q-hypergeometric.";

	pqr:= qgosper_qupdate(1, num(f), den(f), q, qk);
	f:= qgosper_qfindf(pqr, q, qk);

	if (f = {}) then 
		rederr "No q-hypergeometric antidifference exists.";
	if (lisp !*qgosper_down) then % Gosper downwards
		f:= sub(qk=q^(k+1), part(pqr,2)) * sub(qk=q^k, f/part(pqr,1)) * a
	else % Gosper upwards:
		f:= sub(qk=q^k, part(pqr,3)/part(pqr,1)) * sub(qk=q^(k-1), f) * a;
	
	if (lisp !*qgosper_specialsol) then
		f:= (f where (arbcomplex(~z) => 0));
	
	% restore simpexpt and proper redefmsg-mode...
	copyd('simpexpt, 'original_simpexpt);
	lisp (!*redefmsg:= redefmode);
	return f;
end$ 

% ======================================================================
% ======================================================================

algebraic procedure qsumrecursion_denom_lcm(dl);
begin
	scalar !*FACTOR, !*EXP, !*GCD, !*MCD, g;
	on FACTOR, MCD, GCD;  % switch-setting
	g:= (part(dl,1)*part(dl,2)/gcd(part(dl,1),part(dl,2)));
	if (length(dl) = 2) then return g;
	dl:= (for j:=3:length(dl) collect j);
	return qsumrecursion_denom_lcm(g . dl);
end$

% ======================================================================

algebraic procedure qsumrecursion_denom(req, vars);
begin
	scalar !*FACTOR, !*EXP, !*GCD, !*MCD, numer, denom;
	on FACTOR, MCD, GCD;  % switch-setting
	numer:= (for each j in vars collect coeffn(req,j,1)*j);
	denom:= (for each j in numer collect den(j));
	denom:= qsumrecursion_denom_lcm(denom);
	numer:= (for each j in numer collect j*denom);
	off FACTOR; off EXP; % lisp setq(!*really_off_exp,t);  % switch-setting
	return (for each j in numer sum j);
end$

% ======================================================================

algebraic procedure qsumrecursion_qratios(f, q, k, qk, n, qn);
begin
	scalar !*FACTOR, !*EXP, !*MCD, !*GCD, !*LIMITEDFACTORS, kn_ratio;
	on FACTOR, MCD;  off GCD, LIMITEDFACTORS;  % switch-setting
	timing(qratios);
	kn_ratio:= {down_qratio(f,k), qratio(f,n)};
	kn_ratio:= (kn_ratio where {q^k=>qk, q^n=>qn});
	!*qsumrecursion!@sub:= {qk=k, qn=n};
	if not freeof(kn_ratio,k) then 
		%<<write kn_ratio; rederr "bad qratios...">>;
		rederr "Input term is probably not q-hypergeometric.";
	trace_qsum("Applied the substitutions:", {q^k=>k, q^n=>n});
	trace_qsum("down ratio wrt. k:", part(kn_ratio,1));
	trace_qsum("up ratio wrt. n:", part(kn_ratio,2));
	timing(qratios);
	return kn_ratio;
end$

% ======================================================================


algebraic procedure qsumrecursion_eval(f, q, k, summ, n, recrange);
begin
	scalar !*PRECISE, !*FACTOR, !*EXP, !*MCD, !*GCD, !*LIMITEDFACTORS,
			redefmode, qk, qn, rk, rn, lo, hi, a, poly, sigmalist,
			record, pqr, fpol, solu, cert;
	timing(start); timing(qsumrecursion);

	on FACTOR, MCD;  off PRECISE, GCD, LIMITEDFACTORS;  % switch-setting
	% Turn off function-has-been-redefined-messages.
	share redefmode;
	redefmode:= (lisp !*redefmsg);
	lisp (!*redefmsg:= nil);

	% Set new_simpexpt as standard which does more simplifications
	% on power-terms:
	copyd('simpexpt, 'new_simpexpt);

	lo:= part(recrange, 1);
	hi:= part(recrange, 2);
	qk:= (lisp gensym());
	qn:= (lisp gensym());
%clear sigma; operator sigma;
   rn:= qsumrecursion_qratios(f, q, k, qk, n, qn);
	rk:= part(rn, 1);
	if (lisp !*qsumrecursion_down) then
		rn:= 1 / sub(n=n-1, qn=qn/q, part(rn, 2))
	else
		rn:= part(rn, 2);
	poly:= 1;
	record:= 0;
	sigmalist:= {};
	repeat begin
		record:= record + 1;
		sigmalist:= append(sigmalist, {lisp intern gensym()});
%!*qsumrecursion!@sub:= append(!*qsumrecursion!@sub, 
%	{first reverse sigmalist=sigma(record)});
		if (lisp !*qsumrecursion_down) then
			a:= (for l:=0:record-1 product sub({n=n-l, qn=qn/q^l}, rn))
		else
			a:= (for l:=0:record-1 product sub({n=n+l, qn=qn*q^l}, rn));
		on GCD;  % switch-setting???
		poly:= poly + part(sigmalist,record)*a;
		fpol:= {};
		if (record >= lo) then begin
			a:= rk * sub(qk=qk/q, den(poly)) / den(poly);
			off GCD;  % switch-setting???
%trace_qsum("rat:=", a);
			pqr:= qgosper_qupdate(num(poly), num(a), den(a), q, qk);
			fpol:= qsumrecursion_qfindf(pqr, q, qk, sigmalist);
		end;
	end until (fpol neq {}) or (record = hi);
	if (fpol = {}) then 
		rederr "Found no recursion. Use higher order.";
	solu:= part(fpol, 2);
	fpol:= part(fpol, 1);
	if (lisp !*qsumrecursion_down) then
		rec:= summ(n) + (for j:=1:record sum part(sigmalist,j)*summ(n-j))
	else
		rec:= summ(n) + (for j:=1:record sum part(sigmalist,j)*summ(n+j));
	if (lisp !*qsumrecursion_exp) then
		on EXP  % switch-setting
	else
		on FACTOR;  % switch-setting
	factor summ;
	rec:= sub(solu, rec);
	if (lisp !*qsumrecursion_certificate) then begin
		pqr:= sub(solu, pqr);
		cert:= den(rec) * sub(solu, poly);
		if (lisp !*qgosper_down) then << % Gosper downwards
			cert:= cert * sub(qk=qk*q,part(pqr,2))*fpol/part(pqr,1);
			a:= downward_antidifference;
		>> else <<% Gosper upwards:
			cert:= cert * part(pqr,3)/part(pqr,1)*sub(qk=qk/q,fpol);
			a:= upward_antidifference;
		>>;
		rec:= {num rec, cert, f, k, a};
		end
	else
		rec:= num rec;
	timing(qsumrecursion); 
	if (lisp !*qsumrecursion_profile) then qsumrecursion_qprofile();

	% restore original simpexpt and redefmsg-mode...
	copyd('simpexpt, 'original_simpexpt);
	lisp (!*redefmsg:= redefmode);
	
	return sub(qn=q^n, qk=q^k, rec);
end$

% ======================================================================
% ======================================================================


lisp setq(!*redefmsg, nth(!*qsumrecursion!@sub,1));
lisp setq(!*echo, nth(!*qsumrecursion!@sub,2));
lisp setq(!*output, nth(!*qsumrecursion!@sub,3));

endmodule;

$end$
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]