...implement a Linked List Memory Table?

Author: Terry Wray
Homepage: www.inhouse-software.com

Category: Misc

unit Unit1;

interface

uses
  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  
TMyObjectPtr = ^TMyObject;
  TMyObject = record
    
First_Name: String[20];
    Last_Name: String[20];
    Next: TMyObjectPtr;
  end;

type
  
TForm1 = class(TForm)
    bSortByLastName: TButton;
    bDisplay: TButton;
    bPopulate: TButton;
    ListBox1: TListBox;
    bClear: TButton;
    procedure bSortByLastNameClick(Sender: TObject);
    procedure bPopulateClick(Sender: TObject);
    procedure bDisplayClick(Sender: TObject);
    procedure bClearClick(Sender: TObject);
  private
    
{ Private declarations }
  
public
    
{ Public declarations }
  
end;

var
  
Form1: TForm1;
  pStartOfList: TMyObjectPtr = nil;

{List manipulation routines}
procedure SortMyObjectListByLastName(var aStartOfList: TMyObjectPtr);
function CreateMyObject(aFirstName, aLastName: String): TMyObjectPtr;
procedure AppendMyObject(var aCurrentItem, aNewItem: TMyObjectPtr);
procedure ClearMyObjectList(var aMyObject: TMyObjectPtr);
procedure RemoveMyObject(var aStartOfList, aRemoveMe: TMyObjectPtr);
function AreInAlphaOrder(aString1, aString2: String): Boolean;


implementation

{$R *.DFM}


procedure TForm1.bClearClick(Sender: TObject);
begin
  
ClearMyObjectList(pStartOfList);
end;

procedure TForm1.bPopulateClick(Sender: TObject);
var
  
pNew: TMyObjectPtr;
begin
  
{Initialize the list with some static data}
  
pNew := CreateMyObject('Suzy','Martinez');
  AppendMyObject(pStartOfList, pNew);
  pNew := CreateMyObject('John','Sanchez');
  AppendMyObject(pStartOfList, pNew);
  pNew := CreateMyObject('Mike','Rodriguez');
  AppendMyObject(pStartOfList, pNew);
  pNew := CreateMyObject('Mary','Sosa');
  AppendMyObject(pStartOfList, pNew);
  pNew := CreateMyObject('Betty','Hayek');
  AppendMyObject(pStartOfList, pNew);
  pNew := CreateMyObject('Luke','Smith');
  AppendMyObject(pStartOfList, pNew);
  pNew := CreateMyObject('John','Sosa');
  AppendMyObject(pStartOfList, pNew);
end;

procedure TForm1.bSortByLastNameClick(Sender: TObject);
begin
  
SortMyObjectListByLastName(pStartOfList);
end;

procedure TForm1.bDisplayClick(Sender: TObject);
var
  
pTemp: TMyObjectPtr;
begin
  
{Display the list items}
  
ListBox1.Items.Clear;
  pTemp := pStartOfList;
  while pTemp <> nil do
  begin
    
ListBox1.Items.Add(pTemp^.Last_Name + ', ' + pTemp.First_Name);
    pTemp := pTemp^.Next;
  end;
end;

procedure ClearMyObjectList(var aMyObject: TMyObjectPtr);
var
  
TempMyObject: TMyObjectPtr;
begin
  
{Free the memory used by the list items}
  
TempMyObject := aMyObject;
  while aMyObject <> nil do
  begin
    
aMyObject := aMyObject^.Next;
    Dispose(TempMyObject);
    TempMyObject := aMyObject;
  end;
end;

function CreateMyObject(aFirstName, aLastName: String): TMyObjectPtr;
begin
  
{Instantiate a new list item}
  
new(result);
  result^.First_Name := aFirstName;
  result^.Last_Name := aLastName;
  result^.Next := nil;
end;

procedure SortMyObjectListByLastName(var aStartOfList: TMyObjectPtr);
var
  
aSortedListStart, aSearch, aBest: TMyObjectPtr;
begin
  
{Sort the list by the Last_Name "field"}
  
aSortedListStart := nil;
  while (aStartOfList <> nildo
  begin
    
aSearch := aStartOfList;
    aBest := aSearch;
    while aSearch^.Next <> nil do
    begin
      if not 
AreInAlphaOrder(aBest^.Last_Name, aSearch^.Last_Name) then
        
aBest := aSearch;
      aSearch := aSearch^.Next;
    end;
    RemoveMyObject(aStartOfList, aBest);
    AppendMyObject(aSortedListStart, aBest);
  end;
  aStartOfList := aSortedListStart;
end;

procedure AppendMyObject(var aCurrentItem, aNewItem: TMyObjectPtr);
begin
  
{Recursive function that appends the new item to the end of the list}
  
if aCurrentItem = nil then
    
aCurrentItem := aNewItem
  else
    
AppendMyObject(aCurrentItem^.Next, aNewItem);
end;

procedure RemoveMyObject(var aStartOfList, aRemoveMe: TMyObjectPtr);
var
  
pTemp: TMyObjectPtr;
begin
  
{Removes a specific item from the list and collapses the empty spot.}
  
pTemp := aStartOfList;
  if pTemp = aRemoveMe then
    
aStartOfList := aStartOfList^.Next
  else
  begin
    while 
(pTemp^.Next <> aRemoveMe) and (pTemp^.Next <> nildo
      
pTemp := pTemp^.Next;
    if pTemp = nil then Exit; //Shouldn't ever happen
    
if pTemp^.Next = nil then Exit; //Shouldn't ever happen
    
pTemp^.Next := aRemoveMe^.Next;
  end;
  aRemoveMe^.Next := nil;
end;

function AreInAlphaOrder(aString1, aString2: String): Boolean;
var
  
i: Integer;
begin
  
{Returns True if aString1 should come before aString2 in an alphabetic ascending sort}
  
Result := True;

  while Length(aString2) < Length(aString1) do  aString2 := aString2 + '!';
  while Length(aString1) < Length(aString2) do  aString1 := aString1 + '!';

  for i := 1 to Length(aString1) do
  begin
    if 
aString1[i] > aString2[i] then Result := False;
    if aString1[i] <> aString2[i] then break;
  end;
end;

end.

 

printed from
www.swissdelphicenter.ch
developers knowledge base