unit GarbageC;
//*******************************************************
// Class implementing a resizable array-based list with
// garbage collection.
//*******************************************************
// Copyright (C) 1998 John Wiley & Sons, Inc.
// All rights reserved. See additional copyright
// information in Readme.txt.
//
// Revised (C) 1999 Andrzej Grażyński, HELION Publishing
//*******************************************************

interface

uses
    Dialogs, SysUtils, Classes;

const
    GARBAGE_VALUE = #0; // A garbage entry.

type
    String10 = String[10];
    TGarbageList = class(TObject)
        private
            List         : array of String10;
            NumItems     : Longint;           // Liczba elementów używanych
            NumAllocated : Longint;           // Liczba elementów przydzielonych
            ShrinkWhen   : Longint;           // Granica kompresji
            NumGarbage   : Longint;           // Liczba wolnych elementów
            MaxGarbage   : Longint;           // Graniczna liczba wolnych elementów
                                              // dla odzysku
            procedure ResizeList;


        public
            constructor Create;
            destructor Destroy; override;
            procedure Add(value : String10);
            function Count : Longint;
            function AllocatedCount : Longint;
            function Item(index : Longint) : String10;
            procedure Remove(index : Longint);
            procedure CollectGarbage;
    end;

implementation

constructor TGarbageList.Create;
begin
  Inherited Create;
  List := NIL;
  NumAllocated := 0;
  NumItems := 0;
end;


// Zwolnij przydzieloną pamięć.
destructor TGarbageList.Destroy;
begin
  List := NIL;
  inherited Destroy;
end;

// Dodaj element do listy
procedure TGarbageList.Add(value : String10);
begin
    // Upewnij się, że istnieje wolne miejsce.
    if (NumItems >= NumAllocated)
    then
      ResizeList;
    NumItems := NumItems + 1;
    List[NumItems-1] := value;
end;

// Return the number of items in the list.
function TGarbageList.Count : Longint;
begin
    Count := NumItems;
end;

// Return the number of items allocated.
function TGarbageList.AllocatedCount : Longint;
begin
    AllocatedCount := NumAllocated;
end;

// Podaj wartość elementu na pozycji "index".
function TGarbageList.Item(index : Longint) : String10;
begin
    if ((index < 1) or (index > NumItems)) then
        raise ERangeError.CreateFmt(
            'Index %d poza zakresem %d..%d',
            [index, 1, NumItems]);

    Item := List[index-1];
end;

// Remove the last item from the list.
procedure TGarbageList.Remove(index : Longint);
begin
    if ((index < 1) or (index > NumItems)) then
        raise ERangeError.CreateFmt(
            'Index %d poza zakresem %d..%d',
            [index, 1, NumItems]);

    if (List[index-1] = GARBAGE_VALUE) then exit;
    List[index-1] := GARBAGE_VALUE;
    NumGarbage := NumGarbage + 1;
    if (NumGarbage > MaxGarbage) then CollectGarbage;
end;



// Zmień rozmiar tablicy jeżeli  udział wolnych
// elementów przekracza WANT_FREE_PERCENT.

// Normalnie wartości WANT_FREE_PERCENT i MIN_FREE powinny wynosić
// (odpowiednio)  0.1 i 10. Wartości 0.5 i 1 pozwolą lepiej prześledzić
// pracę algorytmu. MIN_FREE musi wynosić co najmniej 1


procedure TGarbageList.ResizeList;
const
    WANT_FREE_PERCENT = 0.5;
    MIN_FREE = 1;
    CR = #13#10;
    CRCR = #13#10#13#10;
var
    want_free, new_size : Longint;

begin
    // Oblicz nowy rozmiar.
    want_free := Round(WANT_FREE_PERCENT * NumItems);
    if (want_free < MIN_FREE) then want_free := MIN_FREE;
    new_size := NumItems + want_free;

    //Zmień rozmiar tablicy z zachowaniem zawartości
    Setlength(List,new_size);

    NumAllocated := new_size;

    // Oblicz graniczną liczbę elementów,
    // poniżej której konieczna jest kompresja

    ShrinkWhen := NumItems - want_free;

    // Collect garbage when there are more than want_free
    // garbage items in the list.


    //Odzyskaj wolne miejsce, gdy zbyt dużo zwolnionych elementów
    MaxGarbage := want_free;



    ShowMessage('Zmiana rozmiaru:' + CRCR +
        'Przydzielonych: ' + IntToStr(NumAllocated) + CR +
        'Używanych: ' + IntToStr(NumItems) + CR +
        'Wolnych: ' + IntToStr(want_free) + CR +
        'Max. zwolnionych: ' + IntToStr(MaxGarbage) + CR +
        'Granica kompresji: ' + IntToStr(ShrinkWhen));


end;




procedure TGarbageList.CollectGarbage;
//© Andrzej Grażyński
var
  L, R, kd, ke : integer;
begin

  ShowMessage('Nastąpi odzyskanie wolnej przestrzeni.');
  L := 1;
  R := NumItems;
  kd := 0;

  while L <= R do
  begin
    // szukaj dziury począwszy od lewej strony
    kd := L;
    while (kd <= r) and (List[kd-1] <> GARBAGE_VALUE) do
      Inc(kd);


    if kd > R then
    begin
      // Nie znaleziono dziury,indeks R wskazuje na ostatni element
      Dec(kd);
      Break;
    end;


    // szukaj prawdziwego elementu poczawszy od prawej strony,
    // aby zastapic nim dziure pod indeksem kd
    ke := R;
    while (ke > kd) and (List[ke-1] = GARBAGE_VALUE) do
      dec(ke);

    if ke <= kd then
    begin
      // na pozycji kd i dalej sa juz same dziury; element o indeksie
      // kd-1 jest ostatnim elementem
      dec(kd);
      break;
    end;


    // zastap dziure na pozycji kd elementem znajdujacym sie na pozycji ke
    List[kd-1] := List[ke-1];

    // zawęż granice poszukiwania
    L := kd+1;
    R := ke-1;

    // ponizej pozycji L są same pełnoprawne elementy
    // powyżej pozycji R sa same dziury
  end;
  NumItems := kd;
  NumGarbage := 0;

  // czy zmniejszyć tablicę?
  if (NumItems < ShrinkWhen)
  then
    ResizeList;

end;


end.
