{$I KEYS}


unit uarray;

interface
uses Acnt1;

type   ARRAY_ELEM_TYPE = record case f :byte of
                            1: (D :double);
                            2: (S :string[10]);
                            3: (P :^string );
                         end;

       pARRAY_ELEM_TYPE = ^ARRAY_ELEM_TYPE;

        ARRAY_TYPE  = array [1..5000] of ARRAY_ELEM_TYPE;

       pARRAY_TYPE  = ^ARRAY_TYPE;

type    ARRAYS_TYPE = array ['>'..'Z']
                      of record
                           n :longint;
                           A :array [1..200] of record
                                                 pa: pARRAY_TYPE;
                                                 bs: boolean;
                                                 m : integer;
                                               end;
                         end;

const DO_NOT_FREE_ARRAYS :boolean = false;

var   ARRAYS      :^ARRAYS_TYPE;

var   Arr_Result :byte;

procedure INIT_ARRAYS;
function  FREE_ARRAY(c :char; b :boolean) :longint;
function  FREE_ARRAYS(b :boolean) :longint;
procedure PROC_ARRAY(c1, c2 :char; NFUN :byte);

procedure GET_ARR(c :char; i :longint; var r :double; var St :string);
procedure PUT_ARR(c :char; i :longint; var r :double; var St :string);


var ArrayLink :pLink;


implementation
uses Lib1, Pro1, Interna;


procedure INIT_ARRAYS;
var c :char; i :integer;
begin
new(ARRAYS);
FillChar(ARRAYS^, sizeof(ARRAYS^), 0);
ArrayLink:=nil;
end;


function FREE_ARRAY(c :char; b :boolean) :longint;
label 1;
var i,j,k :longint; h :integer; t :longint;
begin
t:=0; if ARRAYS^[c].n = 0 then goto 1;

with ARRAYS^[c]
do begin
   for k:=1 to 200
   do begin
      if A[k].m <> 0
      then begin
           if A[k].bs
           then for j:=1 to A[k].m
                do if A[k].pa^[j].f = 2
                   then begin
                        h:=length(A[k].pa^[j].P^);
                        t:=t + h;
                        if b then FreeMem(A[k].pa^[j].P, h);
                        end;
           t:=t + sizeof(ARRAY_TYPE);
           if b
           then begin
                FreeMem(A[k].pa, sizeof(ARRAY_TYPE));
                A[k].pa :=nil;  A[k].m :=0;  A[k].bs:=false;
                end;
           end;
      end;
   if b then n:=0;
   end;
1:
FREE_ARRAY:=t;
end;


procedure FreeArrayLink; forward;


function FREE_ARRAYS(b :boolean) :longint;
var c :char; i,t :longint; h :integer;
begin
t:=0;
for c:='>' to 'Z' do t:=t + FREE_ARRAY(c, b);
FREE_ARRAYS:=t;
if b then FreeArrayLink;
end;


procedure SortArray (c         :char); forward;
procedure SortArray2(c1, c2    :char); forward;
procedure BuildArrayLink;              forward;


procedure PROC_ARRAY(c1, c2 :char; NFUN :byte);
var t :longint;
begin
if NFUN=0
then t:=FREE_ARRAY(c1, true)
else if NFUN=1
     then if c2 = ' '
          then SortArray (c1)
          else SortArray2(c1,c2)
     else if NFUN=2
          then begin
               BuildArrayLink;
               end;
end;



procedure GET_ARR(c :char; i :longint; var r :double; var St :string);
var ii,jj :longint; b :byte;
begin
if i = 0
then begin r:=ARRAYS^[c].n; St:=''; end
else begin
     ii:=(i-1) div 5000 + 1; jj:=(i-1) mod 5000 + 1;

     with ARRAYS^[c].A[ii]
     do
     if pa = nil
     then begin r:=0.0; St:=''; end
     else if jj > m
          then begin r:=0.0; St:=''; end
          else begin
               b:=pa^[jj].f;
               if b = 0       then begin r :=pa^[jj].D;    St:='';         end
               else if b = 1  then begin r :=_SUPERVALUE_; St:=pa^[jj].S;  end
               else if b = 2  then begin r :=_SUPERVALUE_; St:=pa^[jj].P^; end;
            end;
     end;
end;



procedure PUT_ARR(c :char; i :longint; var r :double; var St :string);
var ii,jj :longint; b :byte;
begin
if i > ARRAYS^[c].n then ARRAYS^[c].n:=i;
ii:=(i-1) div 5000 + 1; jj:=(i-1) mod 5000 + 1;

with ARRAYS^[c].A[ii]
do begin
   if pa = nil
   then begin
        GetMem(pa, sizeof(ARRAY_TYPE));
        FillChar(pa^, sizeof(ARRAY_TYPE), 0);
        m:=0; bs:=false;
        end;

   b:=pa^[jj].f;

   if IsSuperValue(r)
   then begin
        if length(St) > 10
        then if b = 2
             then begin
                  if length(St) <> length(pa^[jj].P^)
                  then begin
                       FreeMem(pa^[jj].P, length(pa^[jj].P^)+1);
                       GetMem (pa^[jj].P, length(St)+1);
                       end;
                  pa^[jj].P^:=St; bs:=true;
                  end
             else begin
                  GetMem (pa^[jj].P, length(St)+1);
                  pa^[jj].P^:=St; pa^[jj].f:=2; bs:=true;
                  end
        else begin
             if b = 2 then FreeMem(pa^[jj].P, length(pa^[jj].P^)+1);
             pa^[jj].S:=St; pa^[jj].f:=1;
             end
        end
   else begin
        if b = 2 then FreeMem(pa^[jj].P, length(pa^[jj].P^)+1);
        pa^[jj].D:=r; pa^[jj].f:=0;
        end;

   if jj > m then m:=jj;
   end;
end;



function CompareElem(c :char; i :longint; d :double; s :string; b :boolean) :boolean;
var d1 :double; s1 :string;
begin
GET_ARR(c, i, d1, s1);
if b
then begin
     if IsSuperValue(d1)
     then if IsSuperValue(d)
          then CompareElem:=s1 < s else CompareElem:=false
     else if IsSuperValue(d)
          then CompareElem:=true   else CompareElem:=d1 < d;
     end
else begin
     if IsSuperValue(d1)
     then if IsSuperValue(d)
          then CompareElem:=s1 > s else CompareElem:=true
     else if IsSuperValue(d)
          then CompareElem:=false  else CompareElem:=d1 > d;
     end;
end;



function CompareElem2(c1,c2 :char; i :longint; d :double; s :string; b :boolean) :boolean;
var d1 :double; s1 :string;
begin
GET_ARR(c2, i,         d1, s1);
GET_ARR(c1, round(d1), d1, s1);
if b
then begin
     if IsSuperValue(d1)
     then if IsSuperValue(d)
          then CompareElem2:=s1 < s else CompareElem2:=false
     else if IsSuperValue(d)
          then CompareElem2:=true   else CompareElem2:=d1 < d;
     end
else begin
     if IsSuperValue(d1)
     then if IsSuperValue(d)
          then CompareElem2:=s1 > s else CompareElem2:=true
     else if IsSuperValue(d)
          then CompareElem2:=false  else CompareElem2:=d1 > d;
     end;
end;



procedure SwapElem(c :char; i,j :longint);
var d1,d2 :double; s1,s2 :string;
begin
GET_ARR(c, i, d1, s1); GET_ARR(c, j, d2, s2);
PUT_ARR(c, i, d2, s2); PUT_ARR(c, j, d1, s1);
end;



procedure SortArray(c :char);
const M = 2000;
var i, j, L, R, s, x :longint;
    Stack  :array [1..M] of record L,R :longint; end;
    N      :longint;
    xd     :double;
    xs     :string;
begin
N:=ARRAYS^[c].n;
if N > 1
then begin
     s:=1; Stack[1].L:=1; Stack[s].R:=N;
     repeat
       L:=Stack[s].L; R:=Stack[s].R; dec(s);
       repeat
         i:=L; j:=R; GET_ARR(c, (L+R) div 2, xd, xs);
         repeat
           while CompareElem(c, i, xd, xs, true)  and (i < N) do inc(i);
           while CompareElem(c, j, xd, xs, false) and (j > 1) do dec(j);
           if i <= j
           then begin
                SwapElem(c,i,j);
                inc(i); dec(j);
                end;
         until i > j;
         if i < R
         then begin
              inc(s);
              if s > M then Abort((its_30013));  { 'Недостаточное значение M' }
              Stack[s].L:=i; Stack[s].R:=R
              end;
         R:=j;
       until L >= R
     until s = 0;
     end;
end;



procedure SortArray2(c1, c2 :char);
const M = 2000;
var i, j, L, R, s, x :longint;
    Stack  :array [1..M] of record L,R :longint; end;
    N      :longint;
    xd     :double;
    xs     :string;
    tt     :longint; dd :double; ss :string[10];
begin
N:=ARRAYS^[c1].n;

tt:=FREE_ARRAY(c2, true);
for i:=1 to N do begin dd:=i; ss:=''; PUT_ARR(c2, i, dd, ss); end;

if N > 1
then begin
     s:=1; Stack[1].L:=1; Stack[s].R:=N;
     repeat
       L:=Stack[s].L; R:=Stack[s].R; dec(s);
       repeat
         i:=L; j:=R;

         GET_ARR(c2, (L+R) div 2, xd, xs);
         GET_ARR(c1, round(xd),   xd, xs);

         repeat
           while CompareElem2(c1,c2, i, xd, xs, true)  and (i < N) do inc(i);
           while CompareElem2(c1,c2, j, xd, xs, false) and (j > 1) do dec(j);
           if i <= j
           then begin
                SwapElem(c2,i,j);
                inc(i); dec(j);
                end;
         until i > j;
         if i < R
         then begin
              inc(s);
              if s > M then Abort((its_14013));  { 'Недостаточное значение M' }
              Stack[s].L:=i; Stack[s].R:=R
              end;
         R:=j;
       until L >= R
     until s = 0;
     end;
end;



procedure FreeArrayLink;
var p, next :pLink;
begin
p:=ArrayLink;
while p <> nil
do begin next:=p^.Next; dispose(p); p:=next; end;
ArrayLink:=nil;
end;



procedure BuildArrayLink;
var i,k,N,t  :longint; d :double; s :string;
    p,prev   :pLink;
begin
FreeArrayLink;

GET_ARR('?', 0, d, s); N:=round(d);

prev:=nil;
for i:=N downto 1
do begin
   GET_ARR('@', i, d, s);
   k:=round(d);
   GET_ARR('?', k, d, s);
   new(p); p^.This:=AcntP(s); p^.Next:=prev; prev:=p;
   end;

ArrayLink:=p;

t:=FREE_ARRAY('>', true);
t:=FREE_ARRAY('?', true);
t:=FREE_ARRAY('@', true);
end;


begin
end.