
#
 File: tutorial
 Contains all programs from the "MuPAD Tutorial".
#

PRETTY_PRINT:=FALSE:

minus_list := proc(list1, list2)
 local i, j;
 begin
   for i from 1 to nops(list1) do 
     for j from 1 to nops(list2) do
       if list1[i] = list2[j] then 
         list1[i] := NIL;     
       end_if
     end_for
   end_for;
 list1 
end_proc:




mistake:= proc(n)
 local a, b, c;
 begin
   n;
   nops_own(sin(x));
   c:=(12*n;float(PI)*n;144);
   a:=last(2);
   b:=last(3);
   a*b
end_proc:




FUNC:=proc(argu)
  local newargu, fct, dummy1, dummy2;
  option hold;
begin
  if type(args(1)) = "_equal" then 
     _exprseq(op(args(1))); 
     newargu:=(last(1), NIL, args(i)$i=2..args(0))
  else 
     newargu:=args()
  end_if; 

  fct:=proc(dummy1)
     begin
       dummy2
     end_proc; 

  fct:=subsop(fct, 1=op(op(newargu, 1)), 4=op(newargu, 2)); 
  fct:=level(fct);
  domtype(op(newargu, 1)); 
  if % = DOM_EXPR or % = DOM_ARRAY then 
      op(newargu, [1,0]); 
      if domtype(level(last(1))) = DOM_FUNC_ENV then 
         return("Please, do not redefine functional environments")
      else 
	fct := subsop(fct, 6=op(newargu, [1,0]));
         evalassign(op(newargu, [1,0]), fct, 1);
      end_if
  else 
     fct
  end_if
end_proc:




nops_own := proc()
local ERRORLEVEL;	
begin 		
   if ERRORLEVEL = 3 then
      if 0 < traperror(op(args(1), 0)) then 	
         nops(args(1))           	
      else 	
        nops(args(1)) + 1 	
     end_if;	
   else	
     if op(args(1),0) = FAIL then 	
        nops(args(1))	
     else 	
     	nops(args(1)) + 1	
     end_if;	
   end_if;
end_proc:



readtext:= proc(fname)
  local fid, text, line;
  begin
    if args(0) <> 1 then 
       error("wrong no of args") 
    end_if;
    if domtype(fname) <> DOM_STRING then 
       error("no filename") 
    end_if;
    fid:= fopen(fname);
    text:= ftextinput(fid);
    if text = null() then 
       return("") 
    end_if;
    while (line:= ftextinput(fid)) <> null() do
       text:= text . "\n" . line
    end_while;
    text
end_proc:




get_ufunc := proc()
   local i, ufunc;
begin
   ufunc := [];
   for i in anames(0) do
       if strmatch("".i, "_\*") then
           ufunc := append(ufunc, i)
       end_if
   end_for: 
   ufunc  
end_proc:


purge_locals:=proc(f)
  local dummy, a, i;
begin
  a:={}; 
  for i in op(f, 2) do 
    if subs(op(f, 4), i=dummy)<>op(f, 4) then 
      a:={i, op(a)}
    end_if
  end_for; 
  subsop(f, 2=op(a))
end_proc:
        



fib := proc(n)
       begin 
         if n<2 then n else fib(n-1)+fib(n-2) end_if; 
       end_proc:

fib_remember := proc(n)
               option remember;
               begin 
                 if n<2 then n else fib(n-1)+fib(n-2) end_if; 
               end_proc:

fib_fast := proc(n) local i ;  
                 begin 0;0;1; 
                   (%1 +%3;%) $ i=1..n-1; 
                   op(%,nops(%)) 
               end_proc:



s_seq:= proc(ex, ber)
  local  last, A;
  option hold;
begin
  A := level(hold(_stmtseq)(op(args(), 3..nops(args())), eval(ex)$ber), 2);
  context(A);
end_proc:




compare := proc(A, B)
                 local m, n, i, k, z;
               begin
                 z:=0; 
                 m:=nops(A); 
                 n:=nops(B); 
                 for i from 1 to m do 
                   for k from 1 to n do 
                     if A[i]=B[k] then 
                       z:=z+1
                     end_if
                   end_for
                 end_for; 
                 z
               end_proc:

compare2 := proc(A, B)	
               local a, b, z;	
               begin	
                 z := 0;	
                 for a in val(A) do	
                   for b in val(B) do	
                      if a = b then	
                        z := z + 1	
                      end_if	
                   end_for	
                 end_for;	
                 z	
               end_proc:




sum1 := proc(n)
          local i,S;
          begin 
	     S := 0;
             for i from 1 to n do
               S:=S+a*x^i + b*x^i;
             end_for;
          end_proc:

sum2 := proc(n)
             local i,S;
             begin
               0;
               for i from 1 to n do
                 S:= % + a*x^i + b*x^i;
               end_for;
           end_proc:

sum := proc(n)
        local i;
        begin
          a*x^i + b*x^i $ i = 1..n:
          _plus(%);
        end_proc:




binom1 := proc(n,k) 
          local bk;  
          begin  
            bk:=0;  
            if k>n then bk;  
            else  bk:=1;  
              case k  
              of 0 do bk:=1; break;  
              of 1 do bk:=n; break;  
              otherwise  
                for i from 1 to k-1 do bk:=bk*(n-i)/i; end_for;  
                bk:=bk*n/k;  
              end_case;  
            end_if;  
            bk  
          end_proc:

binom2 := proc(n,k) 
         local i ;  
         begin  
           if k= 0 then  return(0) end_if;  
           if k>n div 2 then bin(n,n-k) end_if;  
           _mult(n+1-i$i=1..k) ; 
           %/fact(k)  
          end_proc:




taylor := proc(f, eqn, n)   
            local a, k, x;  
            begin  
              x := op(eqn, 1);  
              a := op(eqn, 2);  
              _plus(subs(f, eqn),  
              subs(diff(f, x $ k ), eqn) / fact(k) * (x-a)^k $ k = 1..n)    
           end_proc:

taylor_fast := proc(f,eqn,n) local x, y, a,i,xi; 
             begin 
               x := op(eqn, 1);
               y := op(eqn, 2); 
               a:=f; xi:=NIL;
               (a:=diff(val(a),x)/i*xi) $ i=1..n;
               _plus(subs((f,level(%,1)),[x=y,xi=x-y]));  
             end_proc:




_write := subsop(_exprseq, [1,3] = "_write", [2,2] = 15, [2,3] = " &t ",
[2,4] = "_write"):

t:= proc() 
   local a,b, i;  
   begin 
   if args(0) > 2 then 
      t(args(1), t(op(args(),2..args(0))))  
   else 
      case args(0)  
         of 1 do args(1); break 
         of 2 do a:=args(1); b:= args(2); 
            if type(a) = "_plus" then  
               _plus(t(op(a,i),b) $ i=1..nops(a)) 
            elif type(b) = "_plus" then  
               _plus(t(a,op(b,i)) $ i=1..nops(b)) 
            else _write(a,b) 
            end_if; 
            break 
      end_case; 
   end_if 
end_proc:




der := proc()
           local d, n;
           option remember;
         begin
           d:=type(args(1));
           case d
               of DOM_INT do
               of DOM_RAT do
               of DOM_FLOAT do
               of DOM_COMPLEX do
               of DOM_IDENT do
                 if args(1)=args(2) then 1 else 0 end_if;
                 break
               of "_mult" do
                 _plus(der(op(args(1), n), args(2))*
                   subsop(args(1), n=1) $ n=1..nops(args(1)));
                 break
               of "_plus" do
                 _plus(der(op(args(1), n),
                    args(2)) $ n=1..nops(args(1)));
                   break
               of "_power" do op(args(1), 1);
                 op(args(1), 2);
                 args(1)*ln(last(2))*der(last(1),
                     args(2))+last(1)*der(last(2),
                     args(2))*last(2)^(last(1)-1);
                 break
               otherwise
                 _par(text2expr(d))(op(args(1)))*der(op(args(1), 1), args(2))
           end_case;
           eval(last(1))
         end_proc:

_par(sin):=cos: 
_par(sinh):=cosh: 
_par(cos):=FUNC([x],-sin(x)): 
_par(cosh):=sinh: 
_par(tan):=FUNC([x],cos(x)^(-2) ): 
_par(tanh):=FUNC([x],cosh(x)^(-2) ): 
_par(asin):=FUNC([x],(1-x^2)^(-1/2) ): 
_par(asinh):=FUNC([x],(1+x^2)^(-1/2) ): 
_par(acos):=FUNC([x],-(1-x^2)^(-1/2) ): 
_par(acosh):=FUNC([x],(x^2-1)^(-1/2) ): 
_par(atan):=FUNC([x],(1+x^2)^(-1) ): 
_par(atanh):=FUNC([x],(1-x^2)^(-1) ): 
_par(exp):=exp: 
_par(sqrt):=FUNC([x],(2*(x))^(-1/2)): 
_par(ln):=FUNC([x],(x)^(-1)): 
_par(ln):=FUNC([x],(x)^(-1)): 




heu_gcd:= proc(a, b)
local x, xv, g, tries, bound;
begin
   x:= op(a,[2,1]);
   bound := max(degree(a,x), degree(b,x));
   xv := 2*min(norm(a), norm(b)) + 2;

   for tries from 1 to 6 do
      if strlen("".xv) * bound > 5000 then return(FALSE) end_if;
      if nops(op(a,2)) = 1 then
            g := igcd(evalp(a,x=xv), evalp(b,x=xv))
      else
            g := heu_gcd(evalp(a,x=xv), evalp(b,x=xv));
            if g = FALSE then return(FALSE) end_if
      end_if;
      if g <> FAIL then
            g := genpoly(g, xv, x);
            if divide(a, g, hold(Exact)) <> FAIL then
               if divide(b, g, hold(Exact)) <> FAIL then
                  return(g)
               end_if
            end_if
      end_if;
      xv := trunc(xv * 73794 / 27011);
   end_for;
   FAIL
end_proc:



Chebyshev := proc(n,x)
local T;
begin
   case n
     of 0 do
        T := poly(1,[x]);
        break;
     of 1 do
        T := poly(x,[x]);
        break;
     otherwise
        T := poly(2 * x,[x]) * Chebyshev(n-1,x) - Chebyshev(n-2,x);
   end_case;
   T;
end_proc:


Cheby_iter := proc(n, x)
        local i;
        begin
          poly(1,[x]); poly( x, [x]);
          for i from 1 to n-1 do
            poly(2*x, [x]) * eval(%1) - eval(%2)
          end_for;
        end_proc:




permute:= proc(list)
local perm;
begin
   perm := proc(l)
   local i, elem, result, res, rl, lcopy;
   begin
      if nops(l) = 2
         then return([[op(l,1), op(l,2)], [op(l,2), op(l,1)]])
      end_if;
      result := []; lcopy := l;
      for i from 1 to nops(l) do
         elem := l[i]; l[i] := NIL;
         res := perm(l);
         for rl in res do
            result := append(result, [elem].rl)
         end_for;
         l := lcopy
      end_for;
      result;
   end_proc;

   perm(list);
end_proc:




bininsert := proc(list)
local i, j, l, r, m, x;
begin
   for i from 2 to nops(list) do
      x := list[i]; l := 1; r := i -1;
      while l <= r do
         m := (l + r) div 2;
         if x < list[m]
            then r := m-1
            else l := m + 1
         end_if;
      end_while;
      for j from i-1 downto l do
         list[j+1] := list[j]
      end_for;
      list[l] := x;
   end_for;
   list;
end_proc:




short_path := proc(V, c)
local i, j, k, d;
begin
   for i in V do
      for j in V do
         if i <> j
            then d[i,j] := c[i,j]
            else d[i,j] := 0
         end_if;
      end_for;
   end_for;
   for k in V do
      for i in V do
         for j in V do
            d[i,j] := min(d[i,j], d[i,k] + d[k,j])
         end_for;
      end_for;
   end_for;
   d;
end_proc:





bipartite_matching:=proc(V,U,EDGE)
local v, erg, A, Q, mate, exposed, label, init,
      build_Q, build_A, augment, loop;
begin
 
   init := proc(V, U, EDGE)
   local v;
   begin
      for v in V do exposed[v] := 0; end_for;
      A := {}; build_A(V,U,EDGE); build_Q(V,U,EDGE);
      loop(V,U,EDGE);
   end_proc:
   
   build_A := proc(V,U,EDGE)
   local v, u, edge;
   begin
      for edge in EDGE do
         v := op(edge,1); u := op(edge,2);
         if mate[u] = 0 then exposed[v] := u
            elif mate[u] <> v then A := A union {[v,mate[u]]}
         end_if;
      end_for;
   end_proc:
 
   build_Q := proc(V,U,EDGE)
   local v;
   begin
      Q := {};
      for v in V do
         label[v] := 0;
         if mate[v] = 0 then Q := Q union {v} end_if;
      end_for;
   end_proc;
 
   augment := proc(v)
   begin
      if label[v] = 0
         then mate[v] := exposed[v]; mate[exposed[v]] := v;
         else exposed[label[v]] := mate[v]; mate[v] := exposed[v];
            mate[exposed[v]] := v; augment(label[v]);
      end_if;
   end_proc;
 
   loop := proc(V,U,EDGE)
   local v;
   begin
      while Q <> {} do
         v := op(Q,1); Q := Q minus {v};
         if exposed[v] <> 0  then augment(v); init(V,U,EDGE);
            else for vs in V do
               if label[vs] = 0
                  then for edge in A do
                     if edge=[v,vs]
                        then label[vs] := v; Q := Q union {vs}
                     end_if;
                     end_for;
               end_if;
               end_for;
         end_if;
      end_while;
   end_proc;

# begin main program #

   for v in (V union U) do mate[v]:= 0; end_for;
   init(V, U, EDGE); erg := {};
   for v in V do
      if mate[v] <> 0 then erg := erg union {[v,mate[v]]} end_if;
   end_for;
   erg;
end_proc:

fft := proc(A, m)
local i, j, k, l, n, nd2, p2, p2m, ind, r, s, t;
begin
   n := 2 ^ m; nd2 := n div 2; j := 1;
   for i from 1 to n-1 do
      if i < j
         then t := A[j]; A[j] := A[i]; A[i] := t;
      end_if;
      k := nd2;
      while k < j do
         j := j - k; k := k div 2;
      end_while;
      j := j + k;
   end_for;
   for l from 1 to m do
      p2 := 2 ^ l; p2m := p2 div 2;
      r := 1.0; s := float(cos(PI/p2m) + I*sin(PI/p2m));
      for j from 1 to p2m do
         for i from j to n step p2 do
            ind := i + p2m; t := A[ind] * r;
            A[ind] := A[i] - t; A[i] := A[i] + t;
         end_for;
         r := r * s;
      end_for;
   end_for;
   A;
end_proc:

