program hermit(input,output);  {Prak5.pas}
{        Berechnung der Hermitschen Polynome , von Rene' Scholz         }

uses crt;

type  Zeichen                 = set of char;

var   erg,polynom,st1         : string;
      Grad                    : integer;
      Numbers,Produkts,trset  : Zeichen;

{--------------------------------------------------------------------------}

function rekstr(n:integer) :string;

        function rs(n:integer):string;
        var    s    :string;
        begin
        if (n>1) then
          begin
            str(2*n-2,s);
            rs:=   '('  +   '2*x'  +   '*'  +  rs(n-1)
                 + '-'  +     s    +   '*'  +  rs(n-2)  +  ')'  ;
          end
        else
        if (n=0) or (n=1) then
          begin
           if n=0 then rs:='1' ;
           if n=1 then rs:='2*x';
          end;
        if (n<0) then  rs:=''
       end;                       { of rs ,unterfunction }


var hs: string;
begin                             { of Rekstr }
 hs:=rs(n);
 if (n=0) or (n=1) then hs:= '(' + hs + ')';
 rekstr:=hs;
end;                              { of rekstr }







procedure del_spaces( var e:string);
{ loeschen aller Leerzeichen in e bis '!' erreicht ist }
var  i:   integer;
begin
  i:=1;
  repeat
   if e[i]=' ' then
     begin
       delete(e,i,1);
       i:=i-1;
     end;
   i:=i+1;
  until e[i]='!';
end;




function lies_zahl( e:string ; Zahl_anfang:integer ):string;
{ liest ab Zahl_anfang alle folgenden Ziffern in einen String ein }

var  i :integer;
begin
 i:=Zahl_anfang;
 while    e[i] in Numbers    do   i:=i+1;
 lies_zahl:=copy( e , Zahl_anfang , i - Zahl_anfang);
end;




procedure loesch_zahl( var e:string ;beginn,ende :integer);
{ loescht alle Ziffern von beginn bis ende mit Spaces }

var  i    :integer;
begin
 for i:=beginn to ende do   e[i]:=' ';
end;



{----------------- soweit alles o.k. --------------------}





function kuerze_produkt(var e:string ;pa:integer) :integer;

{ verkuerzt string  e  ab pa=produktanfang ; gibt position
  des naechsten moeglichen produkts zurÜck,
  das aber schon zum naechsten Ausdruck gehoeren kann ,
  z.B. ')'  '-'  '+'  '('    }


var  i,pe,az,zahl      :integer;  {pe: Potenz_ende}
     power,error,kp    :integer;
     hz,xpot           :string;
     mal               :boolean;

begin
 i      :=pa;
 Zahl   :=1;
 hz     :='';
 xpot   :='';
 power  :=0;
 mal    :=false;


 while   e[i] in Produkts  do  i:=i+1;
 pe:=i-1;                        { Ermittlung des Endes des produkts }
 if e[pe]='*' then
   begin
     pe:=pe-1;                   { Malzeichen vor Klammer soll bleiben }
     mal:=true;
   end;


 for i:=pa to pe do
   if e[i]='x' then
    begin
      power:=power+1;
      e[i]:=' '; e[i-1]:=' ';    { Loeschen von  '*x'  }
    end;                         { Ermittlung Anzahl von x --> Potenz von x }


  i:=pa;

  repeat  { Ermittlung des Faktors im Produkt der durch '*' getrennten Zahlen}
    hz:=lies_zahl(e,i);
    loesch_zahl(e,i,i+length(hz) - 1 );   {die Zahl hz loeschen }
    val(hz,az,error);
    Zahl:=Zahl*az;                        { Hier Aufrechnen des Faktors }
    i:=i+length(hz) ;
    while (not (e[i] in Numbers))  and (i<=pe)
      do   i:=i+1;                        {naechste zahl in Produkt suchen}
    if (e[i]='*') and (i<=pe) then i:=i+1;
    if e[i-1]='*' then loesch_zahl(e,i-1,1);
  until  (not(e[i] in Numbers)) or (i>pe);


  str(Zahl,hz);                          {hz wird der string von Zahl}

  if (power>0) then
       for  i:=1 to power               { auf der VAX : Pad ! }
          do  xpot:=xpot + 'x';         {x^n --> x...x (n-mal) }

  delete(e,pa,pe-pa+1);                  {ganzes Produkt loeschen}

  if  (xpot<>'') then insert(hz + '*' + xpot,e,pa)
   else               insert (hz,e,pa);  {und neues einsetzen}

  kp:=pa+length(hz + xpot) ;
  if  (xpot<>'')  then kp:=kp+1;
  if mal=true then kp:=kp+1;
 kuerze_produkt:=kp;
end;         { of function kuerze_produkt }





function begin_of_produkt( e:string ; i:integer):integer;
{suche in e ab position i naechstes Produkt }

begin
  while   e[i] in trset    do   i:=i+1;
  begin_of_produkt:=i;
end;




procedure kuerze_polynom( var e:string);
var      i,pa,pe      :integer;

begin
  i:=1;
  pa:=i;
  repeat
     pa:=begin_of_produkt(e,pa);
     pa:=kuerze_produkt(e,pa);
     while (e[pa]= ')' )  do  pa:=pa+1;
  until e[pa]='!';
{  e[pa]:=' ';  }   { make_potenz braucht  '!' ebenfalls }
end;



{--------------------------------------------------------------------------}

procedure make_potenz( var e:string);
var   potenz,i,potanfang    :integer;
      ps                    :string;

begin
 i:=1;
 repeat
   while (e[i]<>'x') and (i<length(e))  do  i:=i+1;
   potanfang:=i;
   while (e[i]='x')  do  i:=i+1;

   potenz:=i-potanfang;
   delete(e,potanfang,potenz);
   str(potenz,ps);
   if (ps<>'0') then
     if  ps='1' then insert('x' , e , potanfang)
                else insert('x^' + ps ,e,potanfang);
 until (e[i]='!');
 e[i]:=' ';
end;




{--------------------------------------------------------------------------}
{                      This is the Main Program                            }


begin
 Numbers:=['0'..'9'];
 produkts:=Numbers + [ '*' , 'x' ];
 trset:=[ '(' , ')' , '+' , '-' ];
 clrscr;

for Grad:=0 to 4 do
 begin
  polynom:=rekstr(Grad) + '!';
  writeln(polynom);

  kuerze_polynom(polynom);
  writeln(polynom);

  make_potenz(polynom);
  writeln(polynom);
  writeln;
end;

  writeln;
  st1:='(2*x*x*4*x*x-4*x*x-12*x*3*x*x+2*2*x*x*3)!';
  writeln(st1);
  kuerze_polynom(st1);
  writeln(st1);
  make_potenz(st1);
  writeln(st1);

end.