program assolist;
(* implementation of the quadruple summation formula due to Le-Murakami *)
(* 2009/09/22; edited from old assolist.pas *)
(* generate the expression of the n-th term of the Drinfeld asociator;
   output to stout;
   results for n<=12 are saved in files assolist.N *)
const
   maxnumvar=8200;
   ml=11; (* max length of multiindices *)
type
   nametype=string;
   multiind=array[1..ml] of integer;
   vector=array[1..maxnumvar] of integer;
var
   l: integer; (* length of multiindices *)
   w: integer; (* weight *)
   p,q,i,j: multiind;
   last: boolean;
   zs,ms: string;
   cf:longint;
   varpres: array[1..maxnumvar] of nametype;
   numvar,firstvar,lastvar: integer;
   v:vector;
   k: integer; (* just an index *)
   n:integer;
   debug:boolean;
   
procedure print(p:multiind);
var
   i: integer;
begin
   for i:= 1 to l do write(p[i]);
end;

procedure next(var a: multiind; var last:boolean);
var
   i,j:integer;
begin
{if debug then begin write('next entered; a='); print(a); writeln end;}
   last:=false;
   i:=l;
   while (i>0) and (a[i]=1) do dec(i);
   if i<=1 then last:=true else
   begin
      inc(a[i-1]);
      a[l]:=a[i]-1;
      for j:=i to l-1 do a[j]:=1;
   end;
end;

procedure nextrel(var a: multiind; p:multiind; var last:boolean);
var
   i,j:integer;
begin
{writeln('entering next');}
{wri]te('a='); print(a); write('p=');print(p);}
   last:=false;
   i:=l;
{writeln('i=',i);}
   while (i>0) and (a[i]=p[i]) do dec(i);
   if i=0 then last:=true else
   begin
      inc(a[i]);
      for j:=i+1 to l do a[j]:=0;
   end;
end;

procedure init(var p: multiind; w:integer);
var i: integer;
begin
   for i:=1 to l-1 do p[i]:=1;
   p[l]:=w-(l-1)
end;

procedure init0(var p: multiind);
var i: integer;
begin
   for i:=1 to l do p[i]:=0;
end;

procedure makezetastring(p,q:multiind; var zs: string);
var 
   i,j,k:integer;
   ch:char;
begin
   zs:='z';
   for i:=1 to l do
   begin
      k:=p[i]+1;
      if k<10 then ch:=chr(ord('0')+k)
         else if k=10 then ch:='A'
         else if k=11 then ch:='B'
         else if k=12 then ch:='C';
      zs:=zs+ch;
      for j:=1 to q[i]-1 do zs:=zs+'1';
   end;
end;   

function absval(a:multiind): integer;
var i,r: integer;
begin
   r:=0;
   for i:=1 to l do r:=r+a[i];
   absval:=r
end;

function choose(a,b:integer):longint;
begin
   if b=0 then choose:=1
   else if b=a then choose:=1
   else choose:=choose(a-1,b)+choose(a-1,b-1)
end;

function mchoose(p,s:multiind): longint;
var 
   i:integer;
   r:longint;
begin
   r:=1;
   for i:=1 to l do r:=r*choose(p[i],s[i]);
   mchoose:=r
end;

procedure makecoef (p,q,i,j: multiind; var cf: longint);
begin
   cf:=mchoose(p,i)*mchoose(q,j);
   if odd(absval(p)+absval(i)+absval(j)) then cf:=-cf
end;

procedure makemonstring(p,q,i,j: multiind; var ms: string);
var k,m,no:integer;
begin
   ms:='';
   no:=0;
   k:=absval(q)-absval(j);
   for m:=1 to k do 
   begin 
      inc(no);
      ms:=ms+'B';
   end;
   for k:=1 to l do
   begin
      for m:=1 to i[k] do 
      begin 
         inc(no);
         ms:=ms+'A';
      end;
      for m:=1 to j[k] do 
      begin 
         inc(no);
         ms:=ms+'B';
      end;
   end;
   k:=absval(p)-absval(i);
   for m:=1 to k do 
      begin 
         inc(no);
         ms:=ms+'A';
      end;
end;

procedure nextstr (var s:string; n:integer; var last:boolean);
var 
   i,r:integer;
begin
   last:=false; 
   r:=n;
   while (r>0) and (s[r]='B') do dec(r);
   if r=0 then last:=true else
   begin
      s[r]:='B';
      for i:=r+1 to n do s[i]:='A'
   end;
end;

procedure initstr (var s:nametype; n:integer);
var i: integer;
begin
   s:='';
   for i:=1 to n do s:=s+'A';
end; 

procedure InitVarsAB (n:integer); (* prepare the complete list of names:
                         A,B,AA,AB,...,B^deg *)
var
   k:integer;
   s:nametype;
   last:boolean;
begin
   numvar:=0;
   for k:=1 to n do
   begin
      initstr(s,k);
      repeat
         inc(numvar);
         varpres[numvar]:=s;
         nextstr(s,k,last)
      until last;
   end;
   firstvar:= (numvar div 2) +1; (* first and last numbers of *)
   lastvar:= numvar-1;           (* actual variables of maximal deg *)
end;

function digit(ch:char):integer;
begin
   if ch='A' then digit:=0
   else if ch='B' then digit:=1
   else begin writeln('wrong character'); halt end;
end;

function power(a,b:integer):integer;
var i,r:integer;
begin
   r:=1;
   for i:=1 to b do r:=r*a;
   power:=r
end;
 
function nvar (v:nametype): integer;
var i,l,r: integer;
begin 
   l:=length(v);
   r:=0;
   for i:=1 to l do r:=r*2+digit(v[i]);
   r:=r+power(2,l)-1;
   nvar:=r
end;

procedure initvec(var v:vector);
var i: integer;
begin
   for i:=1 to numvar do v[i]:=0
end;

procedure writevecaspol(v: vector);
var i:integer;
begin
   for i:=firstvar to lastvar do 
   if v[i]<>0 then
   begin
      if v[i]>0 then write('+');
      write(v[i],'*',varpres[i]);
   end;
end;

procedure testnvar;
var s:string;
begin
repeat
   write('var=');readln(s);
   writeln('no=',nvar(s));
until false;
end;

begin
debug:=false;
{   write('n='); readln(n); }
for n:=12 to 12 do
begin
   initvarsAB (n);
   if n<10 then write('ass',chr(ord('0')+n),':= ')
      else if n=10 then write('ass10:= ')
      else if n=11 then write('ass11:= ')
      else if n=12 then write('ass12:= ');
   writeln;
{   writeln('1/(2*Pi*I)^',n,'*('); }
   for l:=1 to n div 2 do
   begin
      for w:=l to n-l do
      begin
         init(p,w);
         repeat
            init(q,n-w);
            repeat
               makezetastring(p,q,zs);
               write('+',zs,'*(');
               initvec(v);
               init0(i);
               repeat
                  init0(j);
                  repeat
if debug then begin 
write('p=');print(p);
write(' q=');print(q);
write(' i=');print(i);
write(' j=');print(j);writeln; end;
                     makecoef(p,q,i,j,cf);
if debug then writeln('makecoef passed; cf=',cf);
                     makemonstring(p,q,i,j,ms);
if debug then writeln('makemonstr passed; ms=',ms);
                     k:=nvar(ms);
if debug then writeln('nvar passed; k=',k);
                     v[k]:=v[k]+cf;
{if debug then writeln('v[k]=',v[k],' entering nextrel');}
                     nextrel(j,q,last);
{if debug then begin write('nextrel passed; j='); print(j); write(' q='); print(q); writeln; end;}
                  until last;
                  nextrel(i,p,last);
               until last;
               writevecaspol(v);
               writeln(')');
{if debug then writeln('entering next q');}
               next(q,last);
{if debug then writeln('next q passed');}
            until last;
{if debug then writeln('entering next p');}
            next(p,last);
{if debug then writeln('next p passed');}
until last
      end;
   end;
{   writeln(');'); }
    writeln(';');
end;
end.