{$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.