program AEli_M8;                                              { Ver 10-2003 }
uses                                   { символьные комплексные вычисления  }
  Dos,                               { с целыми комплексными коэффициентами }
  Crt;                                             { + новый тип сопряжения }

const MaxDegree = 8;
      MaxLog = 10000;

type
  TNumber = record               { TNumber должно быть всегда нормализовано }
    M: Int64;                            { М - мантисса (числитель) дроби }
    P: Byte;                          { Р - порядок знаменателя дроби (2^P) }
    MI: Int64;                        { мантисса (числитель) мнимой части }
    PI: Byte;                          { порядок 2-знаменателя мнимой части }
  end;

  TLetters = String[MaxDegree];

  PSumm = ^TSumm;                  { TSumm должно быть всегда отсортировано }
  TSumm =
    record
      Co: TNumber;
      Letters: TLetters;
      Next: PSumm;
    end;

  type VocItem = record             { * U }
    Name: Char;
    Value: PSumm;
  end;

  Const VocLen = 16;
  var Voc: array[1..VocLen] of VocItem;
  Const VocLast: Byte = 0;

  type
    MString = array[1..16] of PSumm;           { Matrix Determinant n <= 16 }
    Matrix  = record
    Dim: Byte;
    El: array[1..16] of MString;
  end;

  procedure SWrite(P: PSumm); forward;

{ Операции над числами ------------------------------------------------------}

  procedure NNorm(var X: TNumber);        { Нормализация (упрощение) дроби }
  begin
    while (X.P > 0) and not Odd(X.M) do begin
      Dec(X.P);
      X.M:= X.M div 2;
    end;
    while (X.PI > 0) and not Odd(X.MI) do begin              { мнимая часть }
      Dec(X.PI);
      X.MI:= X.MI div 2;
    end;
  end;

  procedure NNorm2(var X, Y: TNumber);    { Приведение к общему знаменателю }
  begin
    if X.P > Y.P then begin
      Y.M:= Y.M shl (X.P - Y.P);
      Y.P:= X.P;
    end;
    if X.P < Y.P then begin
      X.M:= X.M shl (Y.P - X.P);
      X.P:= Y.P;
    end;
    if X.PI > Y.PI then begin                                { мнимая часть }
      Y.MI:= Y.MI shl (X.PI - Y.PI);
      Y.PI:= X.PI;
    end;
    if X.PI < Y.PI then begin
      X.MI:= X.MI shl (Y.PI - X.PI);
      X.PI:= Y.PI;
    end;
  end;

  procedure NNew(MM, PP, MMI, PPI: Int64; var X: TNumber);
  begin
    X.M:= MM; X.P:= PP;
    X.MI:= MMI; X.PI:= PPI;
  end;

  procedure NInt(X: Int64; var TN: TNumber);
  begin
    NNew(X, 0, 0, 0, TN);
  end;

  procedure NImInt(X: Int64; var TN: TNumber);                 { мнимая 1 }
  begin
    NNew(0, 0, X, 0, TN);
  end;

  procedure NRePart(X: TNumber; var Y: TNumber);
  begin
    NNew(X.M, X.P, 0, 0, Y);
  end;

  procedure NImPart(X: TNumber; var Y: TNumber);
  begin                                         { Im часть X - в Re часть Y }
    NNew(X.MI, X.PI, 0, 0, Y);
  end;

  procedure NAbs(X: TNumber; var Y: TNumber);
  begin
    NNew(Abs(X.M), X.P, Abs(X.MI), X.PI, Y);
  end;

  procedure NNego(var X: TNumber);
  begin
    X.M:= - X.M;
    X.MI:= - X.MI;
  end;

  procedure NSopr(var X: TNumber);
  begin
    X.MI:= - X.MI;
  end;

  procedure NHalf(var X: TNumber);
  begin
    Inc(X.P);
    Inc(X.PI);
    if not Odd(X.M) or not Odd(X.MI) then
      NNorm(X);                          { Нужно для целых результатов: 8/2 }
  end;

  {procedure NSqr(var X: TNumber);
  begin
    NMul(X, X);
  end;}

  procedure NSum(var X, Y: TNumber);
  begin
    NNorm2(X, Y);
    X.M:= X.M + Y.M;
    X.MI:= X.MI + Y.MI;
    NNorm(X);
  end;

  procedure NMul(var X, Y: TNumber);
  var
    A, B, Res: TNumber;
  begin
    NNew(X.M*Y.M, X.P+Y.P, 0, 0, A);
    NNew(-X.MI*Y.MI, X.PI+Y.PI, 0, 0, B);
    NSum(A,B);                                  { a1*a2/u1*u2 - b1*b2/v1*v2 }
    Res:= A;
    NNew(0, 0, X.M*Y.MI, X.P+Y.PI, A);
    NNew(0, 0, X.MI*Y.M, X.PI+Y.P, B);
    NSum(A,B);                                  { a1*b2/u1*v2 + b1*a2/v1*u2 }
    NSum(Res, A);
    NNorm(Res);
    X:= Res;
  end;

  function NIsZero(X: TNumber): Boolean;
  begin
    NIsZero:= (X.M = 0) and (X.MI = 0);
  end;

  function NIsZeroSum(X, Y: TNumber): Boolean;
  begin
    NIsZeroSum:= ((X.P = Y.P) and (X.M + Y.M = 0))
           and ((X.PI = Y.PI) and (X.MI + Y.MI = 0));
  end;

  function NIs1(X: TNumber): Boolean;
  begin
    NIs1:= ((X.M = 1) and (X.P = 0))
      and ((X.MI = 0) and (X.PI = 0));
  end;

  function NImIs1(X: TNumber): Boolean;
  begin
    NImIs1:= ((X.M = 0) and (X.P = 0))
        and ((X.MI = 1) and (X.PI = 0));
  end;

  function NIsEqual(X, Y: TNumber): Boolean;
  begin
    NIsEqual:= ((X.M = Y.M) and (X.P = Y.P))
           and ((X.MI = Y.MI) and (X.PI = Y.PI));
  end;

{ Суммы (PSumm) -------------------------------------------------------------}

  const
    FreeList: PSumm = nil;

  var
    ShowScreen: Boolean;

  procedure NewF(var P: PSumm);
  begin
    if (FreeList <> nil) then begin
      P:= FreeList;
      FreeList:= P^.Next;
      P^.Next:= nil;
    end
    else
      New(P);
  end;

  procedure DisposeF(var P: PSumm);
  begin
    P^.Next:= FreeList;
    FreeList:= P;
    P:= nil;
  end;

  procedure DisposeFreeList;
  var
    P: PSumm;
  begin
    while FreeList <> nil do begin
      P:= FreeList;
      FreeList:= P^.Next;
      Dispose(P);
    end;
  end;

  function SNew(aCo: TNumber; aLetters: TLetters): PSumm;
  var
    Res: PSumm;
  begin
    NewF(Res);                                                          { * }
    with Res^ do begin
      Co:= aCo;
      Letters:= aLetters;
      Next:= nil;
    end;
    SNew:= Res;
  end;

  function SNewNumber(X: TNumber): PSumm;
  begin
    if not NisZero(X) then
      SNewNumber:= SNew(X, '')
    else SNewNumber:= nil;
  end;

  function SInt(X: Int64): PSumm;
  var
   N: TNumber;
  begin
    NInt(X, N);
    SInt:= SNewNumber(N);
  end;

  function SImInt(X: Int64): PSumm;
  var
   N: TNumber;
  begin
    NImInt(X, N);
    SImInt:= SNewNumber(N);
  end;

  function SNewLetter(C: Char): PSumm;
  var
    N: TNumber;
  begin
    NInt(1, N);
    SNewLetter:= SNew(N,  Chr(Byte(C) shl 1));
  end;                  { освобождение последнего бита для флага сопряжения }

  function SCopy(P: PSumm): PSumm;
  var
    Res, P1: PSumm;
  begin
    Res:= nil;
    if P <> nil then begin
      NewF(Res);                                                        { * }
      P1:= Res;
      Move(P^, P1^, SizeOf(TSumm));
      P:= P^.Next;
      while P <> nil do begin
        NewF(P1^.Next);                                                 { * }
        P1:= P1^.Next;
        Move(P^, P1^, SizeOf(TSumm));
        P:= P^.Next;
      end;
      P1^.Next:= nil;
    end;
    SCopy:= Res;
  end;

  procedure DisposeSumm(var P: PSumm);               { удаление во FreeList }
  var
    NextSumm: PSumm;
  begin
    while P <> nil do begin
      NextSumm:= P^.Next;
      DisposeF(P);                                                      { * }
      P:= NextSumm;
    end;
  end;

  procedure DisposeSummX(var P: PSumm);                   { полное удаление }
  var
    NextSumm: PSumm;
  begin
    while P <> nil do begin
      NextSumm:= P^.Next;
      Dispose(P);                                                       { * }
      P:= NextSumm;
    end;
  end;

                             { проверяет, все ли слагаемые одинаковой длины }
      { - для сохранения сортировки в MulSumm:  a < a*b, однако a*z > a*b*z }
  function DifferSumm(P: PSumm): Boolean;
  var
    nn: byte;
  begin
    DifferSumm:= False;
    if P = nil then Exit;
    nn:= Length(P^.Letters);
    while P <> nil do begin
      if Length(P^.Letters) <> nn then
        DifferSumm:= True;
      P:= P^.Next;
    end;
  end;


  function Summa(P1, P2: PSumm): PSumm;
  var
    R0, RLast, RNext, W, Res: PSumm;
  begin
    Res:= nil;
    R0:= nil;
    while (P1 <> nil) and (P2 <> nil) do
    begin
      if P1^.Letters < P2^.Letters then begin
        RLast:= P1;
        RNext:= RLast^.Next;

        { Find Last with step = 1 }
        while  (RNext <> nil) and (RNext^.Letters < P2^.Letters) do begin
           RLast:= RNext;
           RNext:= RLast^.Next;
        end;

        if R0 = nil then
          Res:= P1
        else
          R0^.Next:= P1;
        R0:= RLast;
        P1:= RNext;
      end
      else if P2^.Letters < P1^.Letters then begin
        RLast:= P2;
        RNext:= RLast^.Next;

        { Find Last with step = 1 }
        while  (RNext <> nil) and (RNext^.Letters < P1^.Letters) do begin
           RLast:= RNext;
           RNext:= RLast^.Next;
        end;

        if R0 = nil then
          Res:= P2
        else
          R0^.Next:= P2;
        R0:= RLast;
        P2:= RNext;
      end
      else if NIsZeroSum(P1^.Co, P2^.Co) then begin
        W:= P1; P1:= P1^.Next; W^.Next:= nil; DisposeF(W);              { * }
        W:= P2; P2:= P2^.Next; W^.Next:= nil; DisposeF(W);              { * }
        if ShowScreen then Write('0');
      end
      else begin
        NSum(P1^.Co, P2^.Co);
        if R0 = nil then begin
          R0:= P1;
          Res:= R0;
        end
        else begin
          R0^.Next:= P1;
          R0:= R0^.Next;
        end;
        P1:= P1^.Next;
        W:= P2; P2:= P2^.Next; W^.Next:= nil; DisposeF(W);              { * }
        if ShowScreen then Write('.');
      end;
    end;

    if P1 <> nil then
      if R0 = nil then
        Res:= P1
      else
        R0^.Next:= P1
    else if P2 <> nil then
      if R0 = nil then
        Res:= P2
      else
        R0^.Next:= P2
    else if R0 <> nil then
      R0^.Next:= nil;

    Summa:= Res
  end;

  procedure CompareSumm(P1, P2: PSumm);
  var
    CError: Boolean;
  begin
    CError:= False;
    while (P1 <> nil) and (P2 <> nil) do begin
      if P1^.Letters <> P2^.Letters then CError:= True;
      if NIsEqual(P1^.Co, P2^.Co) then CError:= True;
      If CError then break;
      P1:= P1^.Next;
      P2:= P2^.Next;
    end;
    if CError then writeln('CompareError!!!');
  end;

  function SortHead(var P: PSumm; Len: longint): PSumm;
  { P <> nil }
  var
    Res: PSumm;
  begin
    if Len = 1 then begin
      Res:= P;
      P:= P^.Next;
      Res^.Next:= nil;
    end
    else begin
      Res:= SortHead(P, Len shr 1);
      if P <> nil then
        Res:= Summa(Res, SortHead(P, Len - Len shr 1));
    end;
    SortHead:= Res;
  end;

  procedure Sort(var P: PSumm);
  var
    Len: longint;
    Head: PSumm;
  begin
    if (P = nil) or (P^.Next = nil) then
      Head:= P
    else begin
      Head:= SortHead(P, 1);

      Len:= 1;
      repeat
        if P <> nil then
        Head:= Summa(Head, SortHead(P, Len))
        else Break;
        Len:= Len shl 1;
      until False;
    end;
    P:= Head;
  end;

  procedure PSort(var P: PSumm);                  { Пузырьковая сортировка. }
  var                                           { Эффективна при сортировке }
    PrevAddr: ^PSumm;                       { почти упорядоченных массивов. }
    PNext: PSumm;
    Done: Boolean;
  begin
    if (P = nil) or (P^.Next = nil) then Exit;
    repeat
      Done:= True;
      PrevAddr:= @P;
      PNext:= PrevAddr^^.Next;
      while PNext <> nil do begin
        if PrevAddr^^.Letters < PNext^.Letters then
        PrevAddr:= @(PrevAddr^^.Next)
        else if PrevAddr^^.Letters > PNext^.Letters then
        begin
          PrevAddr^^.Next:= PNext^.Next;
          PNext^.Next:= PrevAddr^;
          PrevAddr^:= PNext;
          PrevAddr:= @(PNext^.Next);
          Done:= False;
        end

        else if NIsZeroSum(PrevAddr^^.Co, PNext^.Co) then begin
          DisposeF(PrevAddr^);                                          { * }
          PrevAddr^:= PNext^.Next;
          DisposeF(PNext);                                              { * }
          if ShowScreen then Write('0');
          Done:= False;
        end
        else begin
          NSum(PrevAddr^^.Co, PNext^.Co);
          PrevAddr^^.Next:= PNext^.Next;
          DisposeF(PNext);                                              { * }
          if ShowScreen then Write('.');
          Done:= False;
        end;

        if PrevAddr^ = nil then Exit;
        PNext:= PrevAddr^^.Next;
      end
    until Done;
  end;


  procedure ESort(var P: PSumm);                           { E - сортировка }
  var                     { возвращение сортировки, испорченной сопряжением }
    P0, P2, PrevAddr: ^PSumm;
    PNext: PSumm;
    C, D, E: String;
    k: byte;
  begin
    if (P = nil) or (P^.Next = nil) then Exit;
    k:= 1;
    while k <= MaxDegree do begin
      P0:= @P;
      while (P0^ <> nil) and (length(P0^^.Letters) < k) do
        P0:= @P0^^.Next;
        if P0^ = nil then Exit;
      while P0^ <> nil do begin
        C:= Copy(P0^^.Letters, 1, k);
        PrevAddr:= P0;
        PNext:= PrevAddr^^.Next;
        while (PNext <> nil) do begin     { отрезок c k-подстрокой равной C }
          D:= Copy(PNext^.Letters, 1, k);
          if D <> C then break;
          PrevAddr:= @(PrevAddr^^.Next);
          PNext:= PrevAddr^^.Next;
        end;
        if PNext = nil then break;
        P2:= @PrevAddr^^.Next;
        if (D > C) then
          P0:= P2
        else begin
          while (PNext <> nil) do begin   { отрезок c k-подстрокой равной D }
            E:= Copy(PNext^.Letters, 1, k);
            if E <> D then break;
            PrevAddr:= @(PrevAddr^^.Next);
            PNext:= PrevAddr^^.Next;
          end;
          PrevAddr^^.Next:= P0^;
          P0^:= P2^;
          P2^:= PNext;               {write('+');}
          if E > C then P0:= P2
          else P0:= {P2} @P0^^.Next;
                   { приходится притормаживать из-за множителей типа a*S(a) }
        end;
      end;
      Inc(k);
    end;
  end;


  procedure MulToProd(P: PSumm; aCo: TNumber; aLetters: TLetters);
  var
    NewLetters: TLetters;
    i1, i2: Byte;
    k, Len: Byte;
    L1, L2: Byte;
    C1, C2: Char;
  begin
    while P <> nil do begin
      with P^ do begin
        NMul(Co, aCo);
        i1:= 1; i2:= 1;
        k:= 0;
        L1:= Length(Letters); L2:= Length(aLetters);
        C1:= Letters[1]; C2:= aLetters[1];
        while (i1 <= L1) and (i2 <= L2) do begin
          Inc(k);
          if C1 < C2 then begin
            NewLetters[k]:= C1; Inc(i1); C1:= Letters[i1];
          end
          else begin
            NewLetters[k]:= C2; Inc(i2); C2:= aLetters[i2];
          end;
        end;
        if i1 <= L1 then begin
          Len:= L1 - i1 + 1;
          Move(Letters[i1], NewLetters[k+1], Len);
          Inc(k, Len);
        end
        else if i2 <= L2 then begin
          Len:= L2 - i2 + 1;
          Move(aLetters[i2], NewLetters[k+1], Len);
          Inc(k, Len);
        end;
        NewLetters[0]:= Chr(k);
        Letters:= NewLetters;
      end;
      P:= P^.Next;
    end;
  end;


  function MulHead(P1: PSumm; var P2: PSumm; Len: longint; Dif: Boolean): PSumm;
  { P2 <> nil }
  var
    Res: PSumm;
  begin
    if Len = 1 then begin
      Res:= SCopy(P1);
      MulToProd(Res, P2^.Co, P2^.Letters);
      if Dif then PSort(Res);       { нужно, если строки неравной длины }
      P2:= P2^.Next;
    end
    else begin
      Res:= MulHead(P1, P2, Len shr 1, Dif);
      if P2 <> nil then
        Res:= Summa(Res, MulHead(P1, P2, Len - Len shr 1, Dif));
    end;
    MulHead:= Res;
  end;

  function Mul(P1, P2: PSumm): PSumm;
  var
    Res, W: PSumm;
    Len: longint;
    Diff: Boolean;
  begin
    Res:= nil;
    if P1 = nil then
      DisposeSumm(P2)
    else if P2 = nil then
      DisposeSumm(P1)
    else if (P1^.Next = nil) and (P1^.Letters = '') then begin
      Res:= P2;
      while P2 <> nil do begin
        NMul(P2^.Co, P1^.Co);
        P2:= P2^.Next;
      end;
      DisposeF(P1);                                                     { * }
    end
    else if (P2^.Next = nil) and (P2^.Letters = '') then begin
      Res:= P1;
      while P1 <> nil do begin
        NMul(P1^.Co, P2^.Co);
        P1:= P1^.Next;
      end;
      DisposeF(P2);                                                     { * }
    end
    else begin
      Diff:= DifferSumm(P1);
      W:= P2;
      Res:= MulHead(P1, P2, 1, Diff);

      Len:= 1;
      repeat
        if P2 <> nil then
        Res:= Summa(Res, MulHead(P1, P2, Len, Diff))
        else Break;
        if Len < 256 then                  { не более 256 слагаемых в сумме }
          Len:= Len shl 1;                            { для экономии памяти }
      until False;
      DisposeSumm(W); DisposeSumm(P1);
    end;
    Mul:= Res;
  end;


  function Sopr(P: PSumm): PSumm;
  var
    Res: PSumm;
    i, j, k, s, n: Byte;
    C, D: Char;
  begin
    Res:= P;
    while P <> nil do begin
      with P^ do begin
        NSopr(Co);      { мнимая 1-ца i внутренняя, реагирует на сопряжение }
        n:= Length(Letters);
        for i:= 1 to n do
          Byte(Letters[i]):= Byte(Letters[i]) xor 1;      { флаг сопряжения }
        i:= 1;
        while i < n do begin
          while (i < n) and (Letters[i+1] > Letters[i]) do Inc(i);
          if i = n then Break;
          C:= Letters[i];
          j:= i;
          while (j < n) and (Letters[j+1] = C) do Inc(j);
          if j = n then break;
          k:= j;
          while (k < n) and (Letters[k+1] < C) do Inc(k);
          if k = j then i:= j
          else begin
            D:= Letters[k];
            for s:= i to k-j+i-1 do Letters[s]:= D;
            for s:= k-j+i to k do Letters[s]:= C;
          end;
        i:= k;
        end;
      end;
      P:= P^.Next;
    end;
    ESort(Res);
    {PSort(Res);}                                            { уже не нужно }
    Sopr:= Res;
  end;

  function CountSumm(P: PSumm): longint;
  var
    k: longint;
  begin
    k:= 0;
    while (P <> nil) do begin
      k:= k + 1;
      P:= P^.Next;
    end;
    CountSumm:= k;
  end;

{ Операции над формулами ---------------------------------------------------}

  function Nego(P: PSumm): PSumm;
  begin
    Nego:= P;
    while P <> nil do begin
      P^.Co.M:= -P^.Co.M;
      P^.Co.MI:= -P^.Co.MI;
      P:= P^.Next;
    end;
  end;

  function Half(P: PSumm): PSumm;
  begin
    Half:= P;
    while P <> nil do begin
      NHalf(P^.Co);
      P:= P^.Next;
    end;
  end;

  function SReal(P: PSumm): PSumm;
  var
    P1: PSumm;
  begin
    if P <> nil then begin
      P1:= SCopy(P);
      P:= Half(Summa(P1, Sopr(P)));
    end;
    SReal:= P;
  end;

  function Im(P: PSumm): PSumm;
  var
    P1: PSumm;
  begin
    if P <> nil then begin
      P1:= SCopy(P);
      P:= Half(Summa(P1, Nego(Sopr(P))));
    end;
    Im:= P;
  end;

  function Norm(P: PSumm): PSumm;
  var
    P1: PSumm;
  begin
    if P <> nil then begin
      P1:= Sopr(SCopy(P));
      P:= Mul(P, P1);
    end;
    Norm:= P;
  end;

  function Scal(P1, P2: PSumm): PSumm;
  var
    Res: PSumm;
  begin
    Res:= nil;
    if (P2 = nil) then DisposeSumm(P1)
    else if (P1 = nil) then DisposeSumm(P2)
    else begin
      P1:= Mul(P1, Sopr(P2));
      {Dispose(P2);}
      Res:= SReal(P1);
    end;
    Scal:= Res;
  end;

  function Vect(P1, P2: PSumm): PSumm;
  var
    Res: PSumm;
  begin
    Res:= nil;
    if (P2 = nil) then DisposeSumm(P1)
    else if (P1 = nil) then DisposeSumm(P2)
    else begin
      P1:= Mul(P1, Sopr(P2));
      {Dispose(P2);}
      Res:= Im(P1);
    end;
    Vect:= Res;
  end;

  procedure ShowMatrix(M: Matrix);
  var
    I, j, k: Byte;
  begin
    I:= M.Dim;
    k:= 1;
    writeln;
    while k <= I do begin
      j:= 1;
      while j <= I do begin
        SWrite(M.El[k,j]);
        write(' ');
        Inc(j);
      end;
      Inc(k);
      writeln;
    end;
    writeln;
  end;

  function FDetMatrix3(M: Matrix): PSumm;                       { 3-матрица }
  var                              { для ускорения счёта и сокращения стека }
    Res: PSumm;
    I: Word;
  begin
    Res:= nil; 
    I:= M.Dim;
    if I = 2 then with M do begin
        Res:= Summa(Mul(El[1,1], El[2,2]), Nego(Mul(El[1,2], El[2,1])));
    end
    else if I = 3 then with M do begin
      Res:= Mul(El[1,1], Summa(Mul(SCopy(El[2,2]), SCopy(El[3,3])), Nego(Mul(SCopy(El[2,3]), SCopy(El[3,2])))));
      Res:= Summa(Res, Mul(El[1,2], Summa(Nego(Mul(SCopy(El[2,1]), El[3,3])), Mul(El[2,3], SCopy(El[3,1])))));
      Res:= Summa(Res, Mul(El[1,3], Summa(Mul(El[2,1], El[3,2]), Nego(Mul(El[2,2], El[3,1])))));
    end;
    FDetMatrix3:= Res;
  end;


  function FSimpleDetMatrix(M: Matrix; MShow: Boolean): PSumm;
  var                                    { Simple algorithm for determinant }
    N: Matrix;
    I, s, j, k, p: Word;
    Res: PSumm;
  begin
    Res:= nil;
    I:= M.Dim;
    if I < 4 then
      Res:= FDetMatrix3(M)
    else begin
      s:= 1;
      while s <= I do begin
        if MShow then write('+ ');              { для контроля за процессом }
        if M.El[1,s] <> nil then begin    { Создание минора размерности I-1 }
          N.Dim:= I - 1;
          k:= 1;
          while (k <= I - 1) do begin
            j:= 1;
            while (j < I) do begin
              if j < s then p:= j
              else p:= j + 1;
              if (s = I) or ((s = I - 1) and (j = I - 1)) then
                N.El[k,j]:= M.El[k + 1,p]
              else N.El[k,j]:= SCopy(M.El[k + 1,p]);
              Inc(j);
            end;
            Inc(k);
          end;
          if s = 1 then
            Res:= Mul(M.El[1,s], FSimpleDetMatrix(N, False))
          else if odd(s) then
            Res:= Summa(Res, Mul(M.El[1,s], FSimpleDetMatrix(N, False)))
          else
            Res:= Summa(Res, Nego(Mul(M.El[1,s], FSimpleDetMatrix(N, False))));
        end
        else begin                                        { M.El[1,s] = nil }
          if (s = I - 1) then begin
            k:= 2;
            while k <= I do begin
              Dispose(M.El[k,I]);
              Inc(k);
            end;
          end
          else if (s = I) then begin
            k:= 2;
            while k <= I do begin
              j:= 1;
              while j < I do begin
                Dispose(M.El[k,j]);
                Inc(j);
              end;
              Inc(k);
            end;
          end;
        end;
        Inc(s);             {or ((s = I - 1) and (j = I - 1))}
      end;
    end;
    FSimpleDetMatrix:= Res;
  end;


  function FDetMatrix(M: Matrix; MShow: Boolean): PSumm;
  var                                    { 2-step algorithm for determinant }
    N: Matrix;
    I, s, t, j, k, p, ss: Word;
    Res, P1, P2: PSumm;
  begin
    {ShowMatrix(M);}
    Res:= nil;
    I:= M.Dim;
    if I < 4 then
      Res:= FDetMatrix3(M)
    else begin
      t:= 1;
      while t <= I do begin
        if MShow then write('+ ');              { для контроля за процессом }
        s:= 1;
        while s <= I do begin
          if (s = t) then Inc(s);                     { s не может быть = t }
          if s > I then Break;
          N.Dim:= I - 2;
          k:= 1;                     { Приготовление минора размерности I-2 }
          while (k <= I - 2) do begin
            j:= 1;
            while (j < I - 1) do begin
              if (j < s) and (j < t) then p:= j
              else if (j >= s) and (j < t-1) then p:= j + 1
              else if (j >= t) and (j < s-1) then p:= j + 1
              else p:= j + 2;
              if ((t = I) and ((s = I - 1) or ((s = I - 2) and (j = I - 2))))
                  or ((t = I - 1) and (s = I - 2) and (j = I - 2)) then
                N.El[k,j]:= M.El[k + 2,p]
              else N.El[k,j]:= SCopy(M.El[k + 2,p]);
              Inc(j);
            end;
            Inc(k);
          end;

          if (t = I) or ((t = I - 1) and (s = I)) then
            P2:= M.El[2,s]
          else P2:= SCopy(M.El[2,s]);
          if (s = I) or ((t = I) and (s = I - 1)) then
            P1:= M.El[1,t]
          else P1:= SCopy(M.El[1,t]);
          if s > t then ss:= s - 1
          else ss:= s;
          if (t = 1) and (s = 2) then
            Res:= Mul(P1, Mul(P2, FDetMatrix(N, False)))
          else if (not odd(t+ss)) then
            Res:= Summa(Res, Mul(P1, Mul(P2, FDetMatrix(N, False))))
          else
            Res:= Summa(Res, Nego(Mul(P1, Mul(P2, FDetMatrix(N, False)))));
          Inc(s);
        end;
        Inc(t);
      end;
    end;
    FDetMatrix:= Res;
  end;

  procedure NConstructor; forward;


{ Транслятор ----------------------------------------------------------------}

  var
    Ch: Char;
    SS: String;
    Pos: Byte;
    LeftPart: PSumm;

    Buf: array[1..16383] of Char;  { 16K buffer }

    InFile, OutFile, LogFile: Text;
    DirFile, DirProg: DirStr;
    NameFile, NameProg: NameStr;
    ExtFile, ExtProg: ExtStr;

    x, y: Byte;                 { Screen }
    NumberStr, CurrentStr: longint;
    BigFile: Boolean;
    ECode: Word;
    Block: Word;
    ContinueScan, AlterDo: Boolean;
    report: String[40];

  procedure WriteStrWindow(pl1: Byte; pl2: Byte; mes: String; Cl: Byte);
  begin
    x:= WhereX; y:= WhereY;
    Window(pl1,pl2,80,pl2);
    ClrScr;
    TextColor(Cl);
    Write(mes);
    TextColor(14);
    Window(1,7,80,25);
    GotoXY(x,y);
  end;

  procedure WriteCurrentStr;
  begin
    if not BigFile then WriteStrWindow(1, 1, SS, 14)
    else if (ParamCount > 0) then begin
      CurrentStr:= CurrentStr + 1;
      Str(CurrentStr, report);
      WriteStrWindow(40, 1, report, 14);
    end;
  end;

  procedure NextChar;
  begin
    Inc(Pos);
    while Pos > Length(SS) do
    begin
      if EOF(InFile) then begin
        Ch:= '.';
        Exit;
      end;

      ReadLn(InFile, SS);
     {if Length(SS) = 0 then begin
        Ch:= '.';
        Exit;
      end;}
      WriteCurrentStr;
      Pos:= 1;
    end;
    Ch:= SS[Pos];
  end;

  procedure Message(S: String);
  begin
    Writeln;
    Writeln(SS);
    if Pos > 1 then Write(' ': Pos - 1);
    Writeln('│');
    if Pos > 1 then Write(' ': Pos - 1);
    Writeln('└─ ', S);
    ECode:= 2;
  end;

  procedure SkipSpace;
  begin
    while Ch = ' ' do
      NextChar;
  end;

  function ScanChar(C: Char): Boolean;
  begin
    SkipSpace;
    if Ch = C then begin
      ScanChar:= True;
      NextChar
    end
    else
      ScanChar:= False;
  end;

  procedure CheckChar(C: Char; var P: PSumm);
  begin
    SkipSpace;
    if Ch <> C then begin
      Message('Должно быть ''' + C + '''');
      DisposeSumm(P);
    end
    else if Ch <> '.' then NextChar;
  end;

  function ScanInt: Int64;
  var
    N: Int64;
  begin
    N:= 0;
    repeat
      N:= N*10 + Ord(Ch) - Ord('0');
      NextChar;
    until not (Ch in ['0'..'9']);
      ScanInt:= N;
  end;

  function ScanA: PSumm;
  var
    N: Int64; I: Byte;
  begin
    SkipSpace;
    if Ch in ['0'..'9'] then begin
      N:= ScanInt;
      ScanA:= SInt(N);
    end
    else if Ch = 'i' then begin                                  { мнимая 1 }
      ScanA:= SImInt(1);
      NextChar;
    end
    else if (Ch in ['A'..'P', 'a'..'p']) or (Ch in ['R'..'S', 'r'..'s']) then
      begin
        ScanA:= SNewLetter(Ch);
        NextChar;
      end
    else if Ch in ['Q'..'Z', 'q'..'z'] then begin             { * U-функция }
      for I:= 1 to VocLast do                                 { uvwq   xyzt }
        if Ch = Voc[I].Name then begin
          ScanA:= SCopy(Voc[I].Value);
          NextChar;
          Exit;
        end;
      {Message('Переменная '''+ C + ''' не определена');
      ScanA:= nil;}
      ScanA:= SNewLetter(Ch); {Возможность прямого введения символов u..z, qt}
      NextChar;                     { для совместимости с программами Al-h. }
    end
    else begin
      Message('Ошибка в формуле');
      ScanA:= nil;
    end;
  end;

  function ScanF: PSumm; forward;

  function ScanMatrix(I: Word): PSumm;         { Matrix Determinant n <= 16 }
      var
      k, j: Byte;
      M: Matrix;
      Res: PSumm;
    begin
      Res:= nil;
      M.Dim:= I;
      k:= 1;
      while (k <= I) do begin
        j:= 1;
        while (j <= I) do begin
          M.El[k,j]:= ScanF;
          if (j < I) then
            CheckChar(',', M.El[k,j])
          else if (k < I) then
            CheckChar(';', M.El[k,j]);
          Inc(j);
        end;
        Inc(k);
      end;
      {M[k,k]:= ScanF;}
      ShowMatrix(M); write('  ',I, '  ');
      Res:= FDetMatrix(M, True);
      ScanMatrix:= Res;
    end;

  function ScanT: PSumm;
  var
    Res, P: PSumm;
    N: Int64; I: Byte;
  begin
    Res:= nil;
    if ScanChar('N') then begin
      if ScanChar('(') then begin
        Res:= Norm(ScanF);
        CheckChar(')', Res);
      end
      else if ScanChar('{') then begin
        Res:= Norm(ScanF);
        CheckChar('}', Res);
      end
      else Res:= SNewLetter('N');                                { * }
    end
    else if ScanChar('R') then begin
      if ScanChar('(') then begin
        Res:= SReal(ScanF);
        CheckChar(')', Res);
      end
      else if ScanChar('{') then begin
        Res:= SReal(ScanF);
        CheckChar('}', Res);
      end
      else Res:= SNewLetter('R');                           { * }
    end
    else if ScanChar('I') then begin
      if ScanChar('(') then begin
        Res:= Im(ScanF);
        CheckChar(')', Res);
      end
      else if ScanChar('{') then begin
        Res:= Im(ScanF);
        CheckChar('}', Res);
      end
      else Res:= SNewLetter('I');                           { * }
    end
    else if ScanChar('S') then begin
      if ScanChar('(') then begin
        Res:= Sopr(ScanF);
        CheckChar(')', Res);
      end
      else if ScanChar('{') then begin
        Res:= Sopr(ScanF);
        CheckChar('}', Res);
      end
      else Res:= SNewLetter('S');                           { * }
    end
    else if ScanChar('(') then begin
      Res:= ScanF;
      CheckChar(')', Res);
    end
    else if ScanChar('{') then begin
      Res:= ScanF;
      CheckChar('}', Res);
    end
    else if ScanChar('[') then begin
      Res:= ScanF;
      CheckChar(',', Res);
        Res:= Scal(Res, ScanF);
        CheckChar(']', Res);
    end
    else if ScanChar('<') then begin
      Res:= ScanF;
      CheckChar(',', Res);
      Res:= Vect(Res, ScanF);
      CheckChar('>', Res);
    end
    else if ScanChar('M') then begin                   { Matrix Determinant }
      if (Ch = '_') then begin
        NextChar;
        if (Ch in ['0'..'9']) then
          I:= ScanInt
        else I:= 0;
        if I <> 0 then begin
          if ScanChar('(') then begin
            Res:= ScanMatrix(I);
            CheckChar(')', Res);
          end
          else if ScanChar('{') then begin
            Res:= ScanMatrix(I);
            CheckChar('}', Res);
          end
          else begin
            Message('Должна быть скобка  ( или {');
            DisposeSumm(Res);
          end
        end;
      end
      else Res:= SNewLetter('M');                                       { * }
    end
    else
      Res:= ScanA;
    if ScanChar('^') then begin
      SkipSpace;
      if Ch in ['1'..'9'] then begin
        N:= ScanInt;
        if N > 1 then begin                                  { new }
          P:= SCopy(Res);
          while N > 2 do begin
            Res:= Mul(Res, SCopy(P));
            Dec(N);
          end;
          Res:= Mul(Res, P);
        end;
      end
      else begin
        Message('Должна быть цифра 1..9');
        DisposeSumm(Res);
      end;
    end;
    ScanT:= Res;
  end;

  function ScanS: PSumm;
  var
    Res: PSumm;
  begin
    Res:= ScanT;
    while ScanChar('*') do
      Res:= Mul(Res, ScanT);
    ScanS:= Res;
  end;

  function ScanHead(Sign:Shortint; Len: longint): PSumm;
  var
    Res: PSumm;
  begin
    if Len = 1 then begin
        Res:= ScanS;
        if Sign = -1 then Res:= Nego(Res);
    end
    else begin
      Res:= ScanHead(Sign, Len shr 1);
      if ScanChar('+') then
        Res:= Summa(Res, ScanHead(+1, Len - Len shr 1))
      else if ScanChar('-') then
        Res:= Summa(Res, ScanHead(-1, Len - Len shr 1));
    end;
    ScanHead:= Res;
  end;

  function ScanF: PSumm;
  var
    Sign: Shortint;
    Len : longint;
    Head: PSumm;
    IncLen: Boolean;
  begin
    if ScanChar('+') then
      Sign:= +1
    else if ScanChar('-') then
      Sign:= -1
    else
      Sign:= +1;
    {Head:= ScanHead(Sign, 1);}

      if LeftPart = nil then begin
        Head:= ScanS;
        if Sign = -1 then Head:= Nego(Head);
      end
      else begin                    { чтобы не держать в памяти левую часть }
        Head:= LeftPart;
        LeftPart:= nil;
        if Sign = +1 then Head:= Summa(Head, ScanS)
        else  Head:= Summa(Head, Nego(ScanS));
      end;

    IncLen:= BigFile;                  { для экономии памяти в малых файлах }
    Len:= 1;
    repeat
      if ScanChar('+') then
        Head:= Summa(Head, ScanHead(+1, Len))
      else if ScanChar('-') then
        Head:= Summa(Head, ScanHead(-1, Len))
      else
        Break;
                       { диспетчер  память - быстродействие, MaxLen = 16384 }
      if IncLen and (Len < 16383) then
        Len:= Len shl 1;
    until False;
    ScanF:= Head;
  end;

  function ScanDef: Boolean;                             { * U }
  var P: PSumm;
      Name: Char;
  begin
    ScanDef:= False;
    if ScanChar('!') then begin
      SkipSpace;
      P:= nil;
      if Ch in ['Q','T'..'Z','q','t'..'z'] then begin
        Name:= Ch;
        NextChar;
        CheckChar(':',P);
        P:= ScanF;
        CheckChar(';',P);
      end
      else Message('Должна быть буква u..z');
      begin
        Inc(VocLast);
        Voc[VocLast].Name:= Name;
        Voc[VocLast].Value:= P;
        ScanDef:= True;
      end;
    end;
  end;

  function ScanE: PSumm;
  var
    Res: PSumm;
  begin
    LeftPart:= nil;
    while Ch = '#' do begin        { возможность комментария в начале блока }
      ReadLn(InFile, SS);
      WriteCurrentStr;
      Pos:= 1;
      Ch:= SS[Pos];
      SkipSpace;
    end;

    while ScanDef do;         { * U }

    if ScanChar('@') then begin                         { N-конструктор }
      AlterDo:= True;
      Writeln(' NConstructor works ');
      NConstructor;
      ScanE:= nil;
      Exit;
    end;

    Res:= ScanF;
    if ScanChar('=') then begin
      LeftPart:= Nego(Res);         { чтобы не держать в памяти левую часть }
      Res:= Nego(ScanF);            { LeftPart cразу же суммируется в ScanF }
    end;
    CheckChar('.', Res);
    ScanE:= Res;
  end;

  function ScanMain: PSumm;
  begin
    Writeln;
    if ParamStr(1) = '' then
      Writeln('Введите формулу:');
    SS:= ''; Pos:= 0;
    NextChar; SkipSpace;
    if Ch = ('.') then begin
      ScanMain:= nil;
      ContinueScan:= False;
    end
    else
      ScanMain:= ScanE;
  end;

{ Печать формулы ------------------------------------------------------------}

  const
    WriteToFile: Boolean = False;
    OutPos     : Byte = 0;

  var
    WriteMemory, WriteTest: Boolean;
    CS0, CS1: longint;

  procedure WriteNewLine;
  begin
    if WriteToFile then
      WriteLn(OutFile)
    else
      WriteLn;
    OutPos:= 0;
  end;

  procedure WriteStr(S: String);
  begin
    {if WriteToFile and (OutPos + Length(S) > LineWidth) then
      WriteNewLine;}

    if WriteToFile then
      Write(OutFile, S)
    else
      Write(S);

    if WriteToFile then
      Inc(OutPos, Length(S));
  end;

  procedure WriteInt(X: Int64);
  var
    S: String[11];
  begin
    Str(X, S);
    WriteStr(S);
  end;

  procedure NWrite(X: TNumber);
  begin
    NNorm(X);
    WriteInt(Abs(X.M));
    if X.P > 0 then begin
      WriteStr('/');
      WriteInt(1 shl X.P);
    end;
  end;

  procedure WriteProd(P: PSumm; WriteSign: Boolean);
  var
    N: TNumber;
    X, i: Byte;
    WriteBracket, WriteAst, SoprFlag: Boolean;
  begin
    if P <> nil then with P^ do begin
      if OutPos >= 48 then WriteNewLine;      { для удобства вида }

      if ((Co.M <> 0) and (Co.MI <> 0)) and (Length(Letters) > 0) then
        WriteBracket:= True
      else WriteBracket:= False;
      if WriteBracket then
        if WriteSign then WriteStr(' + (')
        else WriteStr('(');

      if (Co.M <> 0) then begin
        if not WriteBracket then WriteStr(' ');
        if WriteSign then begin
          if Co.M < 0 then WriteStr('- ')
          else if not WriteBracket then WriteStr('+ ');
        end
        else if Co.M < 0 then WriteStr('-');

        NRePart(Co, N);
        N.M:= Abs(N.M);
        if not NIs1(N) or (Length(Letters) = 0) or WriteBracket then begin
          NWrite(N);
          WriteAst:= True;
        end
        else WriteAst:= False;
      end;

      if (Co.MI <> 0) then begin
        if Co.MI < 0 then
          WriteStr(' - ')
        else WriteStr(' + ');
        NImPart(Co, N);
        N.M:= Abs(N.M);
        if not NIs1(N) then begin
          NWrite(N);
          WriteAst:= True;
        end
        else WriteAst:= False;
        WriteStr('i');
      end;

      if WriteBracket then WriteStr(')');

      for i:= 1 to Length(Letters) do begin
        if WriteAst then
          WriteStr('*')
        else
          WriteAst:= True;

        X:= Byte(Letters[i]);
        if X and 1 <> 0 then  { проверка флага сопряжения = последнему биту }
        begin
          {X:= X xor $FF;}
          TextColor(12);
          SoprFlag:= True;
        end
        else
          SoprFlag:= False;

        if WriteToFile and SoprFlag then WriteStr('S(');
        WriteStr(Chr(X shr 1 or $40));                { $40 = Byte('A') - 1 }
        if WriteToFile and SoprFlag then WriteStr(')');

        {if SoprFlag then}
          TextColor(14);
      end;
    end;
  end;


  procedure SWrite(P: PSumm);
  var
    k: Int64;
  begin
    if P = nil then begin
      WriteStr(' 0');
      Exit;
    end
    else begin
      WriteStr(' ');
      k:= 1;
      WriteProd(P, False);
      P:= P^.Next;
      while (P <> nil) and (k < MaxLog) do begin
        k:= k + 1;
        WriteProd(P, True);
        P:= P^.Next;
      end;
      if CS0 > MaxLog then WriteStr(' + ... ');
    end;
  end;

  procedure SWriteFile(P: PSumm);                          { * last variant }
  begin
      Append(OutFile);
      WriteToFile:= True;
      OutPos:= 0;
      if ECode = 2 then
        Write(OutFile, ' Sintax Error')
      else SWrite(P);
      WriteStr('.');
      WriteNewLine;
      if Block > 1 then
        Writeln(OutFile, 'Block  ':40, Block);
      WriteNewLine;
      Close(OutFile);
      WriteToFile:= False;
  end;

  procedure SWriteLog(T: Real; EC: Word);               { * last variant }
  begin
    {$I-}
    if not WriteTest then Assign(LogFile, '0-ael.log')
    else Assign(LogFile, '0-test.log');
    Append(LogFile);
    {$I+}
    if IOResult <> 0 then  Rewrite(LogFile);

    if EC = 4 then begin
      Writeln(LogFile, NameFile:9, 'No file   ':15, NameProg:8);
      Close(LogFile);
      Exit;
    end
    else if EC = 3 then begin
      Writeln(LogFile, NameFile:9, 'Bad file   ':15, NameProg:8);
      Close(LogFile);
      Exit;
    end
    else if EC = 2 then
      Write(LogFile, NameFile:9, 'Sintax error ':15)
    else if EC = 1 then
      Write(LogFile, NameFile:9, 'NONZERO   ':15)
    else if EC = 0 then
      Write(LogFile, NameFile:9, '0      ':15);
    Write(LogFile, NameProg:8, T:11:3, 'sec':5, 'Res:':6, CS1:9, 'sl':4);
    Writeln(LogFile, ParamStr(2):10);
    Close(LogFile);
    Append(OutFile);
    Writeln(OutFile, '.  Всего  ', CS1, '  слагаемых');
    Writeln(OutFile, '   Программа  ', NameProg:8, '.  Время  счёта:   ', T:11:3, 'sec':5);
    Close(OutFile);
  end;

  procedure CheckFile;
  begin
    FSplit(ParamStr(0), DirProg, NameProg, ExtProg);
    if ParamCount = 0 then
    begin
    AssignCrt(InFile); Reset(InFile);
    end
    else begin
    Assign(InFile, ParamStr(1));
    SetTextBuf(InFile, Buf);
    FSplit(ParamStr(1), DirFile, NameFile, ExtFile);
    {$I-}
    Reset(InFile);
    {$I+}
      if IOResult <> 0 then begin
        Writeln; Writeln('   Нет такого файла: ', ParamStr(1));
        SWriteLog(0, 4);
        Halt(4);
      end;
      if (ExtFile = '.ces') then begin
        Writeln; Writeln('   Некорректный формат файла: ', ParamStr(1));
        SWriteLog(0, 3);
        Halt(3);
      end;
    Assign(OutFile, DirFile + NameFile + '.ces');
    Rewrite(OutFile); Close(OutFile);
    end;
  end;


{--------------------------------------- NConstructor --------------------}

  procedure NConstructor;
  var
    i1, j1, i2, j2, k, l: Int64;
    b: DWord;    
  begin
    i1:= 834538578338573865;
    j1:= 972382875832753297;
    i2:= 334346373845543655;
    j2:= 572544564627532978;
    l:=  32325234634643*23423532543643;
    {write(j);}
    b:= 1;
    while (b < 100000000) do begin
      k:= i1*j1 - i2*j2;
      if k = l then writeln(' OK ');
      Inc(b);
    end;
  end;

{--------------------------------------- Директивы --------------------}


  function CountStr(var F: Text): longint;    { подсчёт числа строк }
  var
    k: longint;
  begin
    k:= 0;
    if ParamCount > 0 then begin
    Reset(F);
    while not EOF(F) do begin
    k:= k + 1;
    ReadLn(F);
    end;
    Close(F);
    Reset(F);
    end;
    if (k < 100) then BigFile:= False
    else BigFile:= True;
    CountStr:= k;
  end;

  procedure Indicator;
  begin
    if ParamCount > 0 then begin
      WriteStrWindow(1, 1, ' Сканирование файла:', 14);
      NumberStr:= CountStr(InFile);
      if BigFile then begin
        WriteStrWindow(1, 1, ' Индикатор строк:', 14);
        Str(NumberStr:9, report);
        report:= report + '   <';
        WriteStrWindow(24, 1, report, 14);
      end;
    end;
  end;

  procedure PlayOk;
  begin
    Sound(350);
    delay(100);
    Sound(400);
    delay(100);
    Sound(440);
    delay(200);
    NoSound;
  end;

  procedure PlayBad;
  var
    k: Byte;
  begin
    for k:= 1 to 10 do begin
      Sound(800);
      delay(30);
      Sound(700);
      delay(30);
    end;
    NoSound;
  end;

  function SIsZero(P: PSumm): Boolean;
  begin
    SIsZero:= True;
    if (P <> nil) then
        SIsZero:= False;
  end;  

  function MemCount(P: PSumm): PtrInt;
    var 
      Res: PtrInt;
  begin
    Res:= 0;
    while P <> nil do begin
      Res:= Res + MemSize(P);
      P:= P^.Next;
    end;
    MemCount:= Res;
  end;

  procedure WriteFreeMem(mes: String; pl1, pl2: Byte);
  var
    i: Byte;
    Pi: PtrInt;
    m1: String;
    MemLog: Text;
  begin
    {Writeln('Memory. Free: ', MemAvail, ', MaxFree: ', MaxAvail);}
    {Str(MemAvail, m1);} {Str(MaxAvail, m2);}
    Pi:= MemCount(FreeList);
    for I:= 1 to VocLast do
    Pi:= Pi + MemCount(Voc[I].Value);
    Str(Pi, m1);
    WriteStrWindow(pl1, pl2, 'MemFree: ' + m1, 14);
    if WriteMemory then begin
      {$I-}
      Assign(MemLog, '0-mem.log'); Append(MemLog);
      {$I+}
      if IOResult <> 0 then  Rewrite(MemLog);
      Writeln(MemLog, NameFile:10, NameProg:10, mes:8, 'MemFree:':12, m1:11);
      if mes = 'end' then Writeln(MemLog);
      Close(MemLog);
    end;
  end;

  Procedure BadMessage;
  begin
    Writeln;
    Writeln('   Не ясна директива  ');
    Halt(5);
  end;

  Procedure ScanDirective(NStr: String);
  begin
    ShowScreen:= False;
    WriteMemory:= False;
    WriteTest:= False;
    if Length(NStr) = 0 then Exit;
    Pos:= 1;
    Ch:= NStr[Pos];

    while (Ch in ['/', 'f', 'F', 'm', 'M', 's', 'S', 't', 'T']) do
    begin
      if Ch in ['s','S'] then ShowScreen:= True
      else if Ch in ['t','T'] then WriteTest:= True
      else if Ch in ['m','M'] then WriteMemory:= True;
      Inc(Pos);
      Ch:= NStr[Pos];
    end;
  if (Pos < Length(NStr)) then BadMessage;
  end;


{ Таймер ------------------------------------------------------------------}
     { до недели работы + годен и для Free Pascal }

   var
     Timer0: longint;
     systimer: longint absolute $40:$6c;
     year1, month1, day1, dayweek1,
     year2, month2, day2, dayweek2: word;

   procedure StartTimer;
   begin
      GetDate (year1, month1, day1, dayweek1);
      Timer0:= SysTimer;
   end;

   function  GetTimer: real;
   var
     Res: longint;
   begin
      Res:= SysTimer - Timer0;
      GetDate (year2, month2, day2, dayweek2);
     if dayweek2 = dayweek1 then
       GetTimer:= Res/18.2065
     else if dayweek2 > dayweek1 then
       GetTimer:= Res/18.2065 + (dayweek2 - dayweek1)*86400
     else
       GetTimer:= Res/18.2065 + (dayweek2 - dayweek1 + 7)*86400;
   end;

   { delta T = 0,0549255 sec }


{ Старт программы -----------------------------------------------------------}

var
  PF: PSumm;
  T: Real;

  procedure FinishBlock;
  var
    I: Byte;
  begin
    DisposeSummX(PF);
    for I:= 1 to VocLast do
    DisposeSummX(Voc[I].Value);
    DisposeFreeList;
    VocLast:= 0;
    Inc(Block);
  end;

begin

  TextColor(Yellow);
  ClrScr;
  ScanDirective(ParamStr(2));
  CheckFile;
  report:= NameProg + ExtProg +  '  ' + ParamStr(1) + '  ' + ParamStr(2);
  WriteStrWindow(1, 3, report, 14);
  Window(1,7,80,25);
  Indicator;

  ECode:= 0;
  ContinueScan:= True;
  Block:= 1;
  CurrentStr:= 0;
  CS1:= 0;
  T:= 0;
  {WriteFreeMem('start', 1, 5);}

  repeat
    StartTimer;
    PF:= ScanMain;
    T:= T + GetTimer;
    if T < 0 then T:= T + 86400;

    {if PF = nil then Break;}
    if (ContinueScan = False) or (ECode = 2) then Break;
    {WriteFreeMem('scan', 30, 5);}

    Str(Block, report);
    report:= 'Блок  ' + report;
    WriteStrWindow(33, 3, report, 14);

    if SIsZero(PF) then
      {PlayOk}
    else
    begin
      ECode:= 1;
      {PlayBad;}
    end;

    Str(T:11:3, report);
    report:=  'Итого:' + report + '  sec';
    WriteStrWindow(43, 3, report, 14);

    if AlterDo then break;

    CS0:= CountSumm(PF);                                     { текущий блок }
    CS1:= CS1 + CS0;                                    { все блоки в сумме }
    Writeln;
    if CS1 > 0 then begin
      Str(CS1, report);
      report:= report + '   sl';
    end
    else report:= 'ZERO !!';
    WriteStrWindow(67, 3, report, 10);             { Итог счёта всех блоков }

    Writeln;
    TextColor(10);
    Writeln(' Результат:');
    TextColor(14);
    SWrite(PF);                           { Результата счёта текущего блока }
    writeln;

    if ParamCount > 0 then SWriteFile(PF);
    FinishBlock;
   until False;

   if ECode = 2 then begin
     Str(Block, report);
     report:= 'Блок  ' + report;
     WriteStrWindow(33, 3, report, 14);
     Str(T:11:3, report);
     report:= 'Итого:' + report + '  sec';
     WriteStrWindow(43, 3, report, 14);
     WriteStrWindow(67, 3, 'Syntax Error!', 10);
     if ParamCount > 0 then SWriteFile(PF);
   end;

   if ParamCount > 0 then SWriteLog(T, ECode);
   FinishBlock;
   Close(InFile);
   {WriteFreeMem('end', 60, 5);}
   Halt(ECode);

end.

{Коды ошибок:
 0 - результат 0
 1 - результат не 0
 2 - синтаксическая ошибка
 3 - недопустимое окончание файла ввода
 4 - файл ввода отсутствует.

 Основан на ядре Al-c8:
 Работает с целыми комплексными коэффициентами.
 Мнимая 1-ца i внутренняя, реагирует на комплексное сопряжение.
 Новое, убыстренное сопряжение по последнему биту.
 Работает с матрицами (детерминантами).

 Ключи:
 /t - вместо файла отчёта 0-alex.log создаётся 0-test.log (test mode);
  s - показ хода процесса на экране (замедляет работу в 2-6 раз);
  m - вывод использования памяти в файл.
                                                                          }