define_variable(g,'g,any)$

/*this block checks for a polynomial in n*/
polyp(g,n):=block([d,f,c],
     g:ratexpand(g), if freeof(n,g) then return(true),
     d:hipow(g,n), f:true,
     for i:d step -1 thru 0 do
     (c:coeff(g,n,i), if not(freeof(n,c)) then f:false,
      g:ratexpand(g-c*n^i)),
     return(is(g=0 and f)))$
   


/*this block checks for a constant to a polynomial power*/
polyinn(x,n):=block([b,e],
     if inpart(x,0)="*" then
     return(polyinn(inpart(g,1),n) and polyinn(inpart(g,2),n)),
     if inpart(x,0)#"^" then return(false),
     b:inpart(x,1),
     e:inpart(x,2),
     if not freeof(n,b) then return(false),
     return(polyp(e,n)))$



/*this block implements the characteristic equation method*/
char(e,g,u,n,k,iv):=block([gensol,homsol,parsol,los,multiplicities,
h,v,l,ss,dispflag],
local(a,aa,b,r,m),
dispflag:false,
  for i:0 thru k do
    aa[i]:coeff(e,u(n+k-i)),
    h:0,
  for i:0 thru k do
    h:h+aa[i]*u(n+k-i),
  if h#e then return("erroneous input"),

  for i:0 thru k do
    h:subst(u^(k-i),u(n+k-i),h),

  multiplicities:true,
  los:solve(h,u),
  for i:1 thru length(los) do
    (r[i]:los[i], r[i]:rhs(ev(r[i])),
     m[i]:multiplicities[i]),
  homsol:
    sum(sum(a[i,j]*n^(m[i]-j),j,1,m[i])*r[i]^n,i,1,length(los)),


  if g=0 then
     (v:[ ],
      for i:1 thru length(los) do
      for j:1 thru m[i] do v:cons(a[i,j],v),
         l:[ ],
      for q:0 thru k-1 do l:cons(subst(q,n,homsol)=u(q),l),
      ss:ev(solve(l,v),iv),
      return(u(n)=(ev(homsol,ss))))

  else if polyp(g,n) = true then
     (g:ratexpand(g), parsol:sum(b[j]*n^j,j,0,hipow(g,n)),
      for j:0 thru k do
       (l:0, v:e,
         for i:0 thru k do
         (l:ratexpand(subst(n+k-i,n,b[j]*n^j)),
          v:ratexpand(subst(l,u(n+k-i),v))),
          v:ratsimp(v),
           if v#0 then return(v) else parsol:n*parsol),
         v:e,
      for i:0 thru k do (l:ratexpand(subst(n+k-i,n,parsol)),
         v:ratexpand(subst(l,u(n+k-i),v))),
         l:[ ],
      for i:0 thru hipow(parsol,n) do
         l:cons(coeff(v=g,n,i),l),
         v:[ ],
      for j:0 thru hipow(parsol,n) do
         v:cons(b[j],v),
      ss:solve(l,v),
      parsol:ev(parsol,ss))

  else if polyinn(g,n) = true then
     (parsol:b1*g,
      for j:0 thru k do
       (l:0, v:e,
         for i:0 thru k do
         (l:subst(n+k-i,n,parsol), v:subst(l,u(n+k-i),v)),
          v:ratsimp(v),
          if v#0 then return(v) else parsol:n*parsol),
      ss:solve(v=g,b1),
      parsol:ev(parsol,ss))

  else if inpart(g,0)=sin or inpart(g,0) = cos then
     (parsol:b[1]*sin(inpart(g,1)) + b[2]*cos(inpart(g,1)),
      for j:0 thru k do
       (l:0, v:e,
         for i:0 thru k do
         (l:expand(subst(n+k-i,n,parsol)),
          v:expand(subst(l,u(n+k-i),v))),
      v:trigexpand(v),
      if v#0 then return(v) else parsol:n*parsol),
         v:e,
      for i:0 thru k do(l:expand(subst(n+k-i,n,parsol)),
         v:expand(subst(l,u(n+k-i),v))),
      v:trigexpand(v),
         l:[ ],
      lt:[sin(inpart(g,1)),cos(inpart(g,1))],
      for jj:1 thru 2 do
         l:cons(coeff(v=g,lt[jj]),l),
         v:[ ],
      for j:1 thru 2 do
         v:cons(b[j],v),
      ss:solve(l,v),
      parsol:ev(parsol,ss))


  else return("can't be solved in closed form by program"),

  gensol:homsol + parsol,
     v:[ ],
  for i:1 thru length(los) do
  for j:1 thru m[i] do v:cons(a[i,j],v),
     l:[ ],
  for q:0 thru k-1 do
  l:cons(subst(q,n,gensol)=u(q),l),
  ss:ev(solve(l,v),iv),
  return(u(n)=(ev(gensol,ss))))$




/*this block implements the generating function method*/
genf(e,g,u,n,k,iv):=block([multiplicities,l,v,ss,vv,los,
nr,f,sol,p,dispflag],
local(a,aa,b),
dispflag:false,
  for i:0 thru k do
    aa[i]:coeff(e,u(n+k-i)),
    h:0,
  for i:0 thru k do
    h:h+aa[i]*u(n+k-i),
  if h#e then return("erroneous input"),

     l:e,
  for i:0 thru k do
    l:subst((f-sum(u(j)*x^j,j,0,k-i-1))*x^i,u(n+k-i),l),

  if g=0 then
     (s:solve(l,f),
      f:ev(f,s))

  else if polyp(g,n) = true then
     (g:ratexpand(g),
      v:subst(x^k/(1-x)*coeff(g,n,0),coeff(g,n,0),g),
      vv:ratsimp(diff(1/(1-x),x)),
      for i:1 thru hipow(g,n) do
        (v:subst(x^k*x*vv*coeff(g,n,i),coeff(g,n,i)*n^i,v),
         vv:ratsimp(diff(x*vv,x))),
      v:ratsimp(v),
      ss:solve(l=v,f),
      f:ev(f,ss))

  else if polyinn(g,n) = true and hipow(inpart(g,2),n) < 2 then
     (g1:(x^k)*(inpart(g,1)^coeff(inpart(g,2),n,0)),
      g2:1 - x*(inpart(g,1)^coeff(inpart(g,2),n,1)),
      v:ratsimp(g1/g2),
      ss:solve(l=v,f),
      f:ev(f,ss))

  else return("can't be solved in closed form by program"),


  multiplicities:true,
  los:solve(newrat(f),x),
  for i:1 thru length(los) do
     (r[i]:los[i], r[i]:rhs(ev(r[i])),
      m[i]:multiplicities[i]),

     v:[ ],
  b:product((1-r[i]*x)^m[i],i,1,length(los)),
  for i:1 thru length(los) do
  for j:1 thru m[i] do
     (p[i,j]:b*a[i,j]/((1-r[i]*x)^j),  v:cons(a[i,j],v)),
  p:sum(sum(p[i,j],j,1,m[i]),i,1,length(los)),

     l:[ ],
  nf:ratexpand(num(f)/abs(coeff(denom(f),x,0))), p:ratexpand(p),
  for i:0 thru hipow(ratexpand(b),x)-1  do
     l:cons(coeff(nf=p,x,i),l),
  sss:ev(solve(l,v),iv),

  sol:sum(sum(a[i,j]*coeff(denom(f),x,0)/abs(coeff(denom(f),x,0))*
     binomial(j+n-1,n)*r[i]^n,j,1,m[i]),i,1,length(los)),

  return(u(n)=(ev(sol,sss))))$


/*this block finds the new polynomial associated to f*/
newrat(f):=block([hd,cp,dp],
     hd:hipow(denom(f),x),
     cp:coeff(denom(f),x,hd),
     dp:sum((coeff(denom(f),x,i))/cp*x^i,i,0,hd),
     return(sum(coeff(dp,x,hd-i)*x^i,i,0,hd)))$





/*this block implements the variable coefficient method*/
varc1(e,g,u,n,k,iv):=block([v,vv,eq,y,cauchysum,finsol,sersol,dispflag],
local(a,b),dispflag:false,
  for i:0 thru k do
    (a[i]:coeff(e,u(n+i)),
     a[i]:ratexpand(a[i]),
     if polyp(a[i],n)=false then return("can't do it")),
  if k=2 and (b:besselcheck(e,k) # false) then return(b),
  v:ratexpand(e),
  for i:k step -1 thru 0 do
     for j:hipow(a[i],n) step -1 thru 0 do
       (v:ratsubst(x^j*'diff(y,x,i+j),n^j*u(n+i),v),
        v:ratexpand(v)),
  v:ratsubst(y,'diff(y,x,0),v),
  v:ratexpand(v),
  if polyp(g,n) = true then
    (g:ratexpand(g), vv:g,
     for i:0 thru hipow(g,n) do
        vv:subst(x^i,n^i,vv),
        vv:%e^x*vv)
  else return("can't do it"),

     eq:v-vv,
  dependencies(y(x)),
  sol:ode2(eq=0,y,x),
        if k=1 then finsol:ic1(sol,x=0,y=ev(u(0),iv))
        else if k=2 then finsol:ic2(sol,x=0,y=ev(u(0),iv),'diff(y,x)=ev(u(1),iv))
  else return("o.d.e. can't be solved at present by macsyma"),
     cauchysum:true,
  sersol:powerseries(rhs(finsol),x,0), sersol:expand(sersol),
  b:inpart(sersol,2),
  b:ev(b,x=1),
  if atom(b)=false then b:substpart(n,b,4),
  return(u(n)=((n!)*b)))$


/*this block checks for a bessel recurrence relation*/

besselcheck(e,k):=block([a,ans],
local(a),
     for i:0 thru k do
     (a[i]:coeff(e,u(n+i)),
      a[i]:ratexpand(a[i])),
     if not(integerp(a[0])) then return(false),
     if not(integerp(ev(a[1],n=0))) then return(false),
     if not(hipow(a[1],n)=1) then return(false),
     if not(integerp(coeff(a[1],n,1))) then return(false),
     if not(a[2]=1) then return(false),
     ans:"a linear combination of bessel functions",
     /*exact details are of no significance,since we are merely
       demonstrating the feasibility of this approach*/
     return(ans))$





/*this block implements the first order method*/
varc2(e,g,u,n,k,iv):=block([h,p,v,c,sol,sj,si,pn,hi,ap],
     p:(-1)*coeff(e,u(n))/coeff(e,u(n+1)),
     v:g/coeff(e,u(n+1)),
     sj:subst(j,n,p),
     si:subst(i,n,p),
     pn:product(si,i,1,n-1),
     hi:subst(i,n,v)/product(sj,j,1,i-1),
     v1:sum(hi,i,0,n),
     ap:ev(u(0)-subst(0,n,v),iv),
     return(u(n)=ap*pn+pn*v1))$
