Sorting and Searching Demonstration

As promised earlier in the tutorial, we have a program to demonstrate sorting and searching methods working with arrays of records. It includes bubble sort, insertion sort, quicksort, linear search and binary search. Program SortSearchDemo needs Progs.txt, which you may have used already with programs ListDemo and LinkedListDemo in our Lists, Stacks and Queues tutorial. It is available for download here.

program SortSearchDemo;
  {$APPTYPE CONSOLE}
uses
  SysUtils,
  StrUtils;

type
  TProg = record
    ProgramID : integer;
    ProgName : string[15];
    ProgrammerID : integer;
    Dummy : integer;  //to make this compatible with LinkedListDemo
  end;
const
  FILENAME = 'Progs.txt';
  MAX = 20;
var
  LastRecord, FoundRecord,  Choice, SelectedID : integer;
  Programs : array[1 .. MAX] of TProg;

procedure InsertRecord(InsertID : integer);
var
  Inserted : Boolean;
  TempRecord : TProg;
  CurrentRecord : integer;
begin
  Inserted := False;
  TempRecord.ProgramID := InsertID;
  write('Program Name? ');
  readln(TempRecord.ProgName);
  write('Programmer ID? ');
  readln(TempRecord.ProgrammerID);

  if LastRecord = 0 then
    begin
      Programs[1] := TempRecord;
      LastRecord := 1;
      writeln('Record added.  No others in list.');
    end
  else
    begin
      CurrentRecord := LastRecord;
      inc(LastRecord);
      while (CurrentRecord > 0) and not Inserted do
        begin
          if TempRecord.ProgramID > Programs[CurrentRecord].ProgramID then
            begin
              Programs[CurrentRecord + 1] := TempRecord;   //No shift needed
              Inserted := True;
              writeln('Record inserted at position ', CurrentRecord + 1);
            end
          else
            begin
              //Shift record one place
              Programs[CurrentRecord + 1] := Programs[CurrentRecord];
              dec(CurrentRecord);
            end;
        end;
      if not Inserted then
        begin
          Programs[1] := TempRecord;
          writeln('Record inserted at position 1');
        end;
    end;
end;

procedure DisplayRecord(RecNo : integer);
begin
  writeln(' Program ID: ', Programs[RecNo].ProgramID,
          '   Name: ', Programs[RecNo].ProgName,
          DupeString(' ', 14 - Length(Programs[RecNo].ProgName)),
          'Programmer ID: ', Programs[RecNo].ProgrammerID);
end;

procedure DisplayRecords;
var
  Count : integer;
begin
  if LastRecord = 0 then
    writeln('No records to display')
  else
    begin
      for Count := 1 to LastRecord do
        DisplayRecord(Count);
    end;
end;

procedure Find(ProgID: integer; var FoundRecord : integer);
var
  CurrentRecord : integer;
  Found : Boolean;
begin
  Found := False;
  if LastRecord = 0 then
    writeln('No records to search')
  else
    begin
      CurrentRecord := 1;
      repeat
        if Programs[CurrentRecord].ProgramID = ProgID then
          begin
            Found := True;
            FoundRecord := CurrentRecord;
            DisplayRecord(FoundRecord);
          end
        else
          inc(CurrentRecord);
      until Found or (CurrentRecord = LastRecord + 1);
      if not Found then
        begin
          FoundRecord := 0;
          writeln('Not found');
        end;
    end;
end;

procedure BinarySearch(SearchNum, First, Last : integer);
var
  MidPoint: integer;
begin
  if First > Last then
    writeln('Search Failed')
  else
    begin
      writeln('Searching for ', SearchNum, ' between index ',First ,' and index ', Last);
      Midpoint := (First + Last) DIV 2;
      if Programs[MidPoint].ProgramID = SearchNum then
        writeln('Found at position ', MidPoint)
      else if Programs[MidPoint].ProgramID < SearchNum then
        BinarySearch(SearchNum, MidPoint + 1, Last)
      else
        BinarySearch(SearchNum, First, MidPoint - 1);
    end;
end;

procedure Delete(DeleteID : integer);
var
  Count : integer;
begin
  Find(DeleteID, FoundRecord);
  if FoundRecord <> 0 then
    begin
      dec(LastRecord);
      for Count := FoundRecord to LastRecord do
        Programs[Count] := Programs[Count + 1];
      writeln('Deleted');
    end;
end;

procedure Edit(EditID : integer);
var
  Response : char;
begin
  Find(EditID, FoundRecord);
  if FoundRecord <> 0 then
    begin
      write('Would you like to change the name y/n? ');
      readln(Response);
      if Response in ['Y', 'y'] then
        begin
          writeln('What should the name be? ');
          readln(Programs[FoundRecord].ProgName);
          writeln('New name entered');
        end;
      write('Would you like to change the programmer ID y/n? ');
      readln(Response);
      if Response in ['Y', 'y'] then
        begin
          writeln('What should the ID be? ');
          readln(Programs[FoundRecord].ProgrammerID);
          writeln('New ID entered');
        end;
    end;
end;

procedure BubbleSort(ChosenField : integer);
var
  NoSwaps, SwapNeeded : Boolean;
  Count, LastCompare : integer;
  TempRecord : TProg;
begin
  if LastRecord = 0 then
    begin
      writeln('No records to sort');
    end
  else
    begin
      if LastRecord = 1 then
        begin
          writeln('Cannot sort 1 record.')
        end
      else
        begin
          NoSwaps := False;
          LastCompare := LastRecord;
          while NoSwaps = False do
            begin  //start of loop comparing pairs of names
              NoSwaps := True;
              Count := 1;
              while (Count < LastCompare) do
                begin
                  case ChosenField of
                    1: SwapNeeded := Programs[Count].ProgName > Programs[Count + 1].ProgName;
                    2: SwapNeeded := Programs[Count].ProgramID > Programs[Count + 1].ProgramID;
                  end;
                  if SwapNeeded then
                    begin
                      NoSwaps := False;
                      TempRecord := Programs[Count + 1];
                      Programs[Count + 1] := Programs[Count];
                      Programs[Count] := TempRecord;
                      writeln('Swapping ', Count,' with ', Count + 1);
                    end
                  else  //No swap
                    begin
                      inc(Count);
                    end;
              end;//while
              dec(LastCompare);
            end; //while NoSwaps = False;
        end;
    end;
end;

procedure InsertionSort;
var
  Inserted : Boolean;
  Current, Insert : integer;
  ProgTemp : TProg;
begin
  DisplayRecords;
  if LastRecord < 2 then
    begin
      writeln('No sorting possible');
    end
  else
    begin
      for Insert := 2 to LastRecord do
        begin
          Inserted := False;
          Current := Insert;
          ProgTemp := Programs[Insert];
          while not inserted do
            begin
                if ProgTemp.ProgramID > Programs[Current - 1].ProgramID then
                  begin
                    Inserted := True; //Position found;
                    Programs[Current] := ProgTemp;
                    writeln('Record inserted at position ', Current);
                    DisplayRecords;
                  end
               else
                 begin
                   //Shift up record one place
                   Programs[Current] := Programs[Current - 1];
                   dec(Current);
                   if Current = 1 then
                     begin
                       Programs[1] := ProgTemp;
                       writeln('Inserted at position 1');
                       Inserted := True;
                       DisplayRecords;
                     end;
                 end;
            end;
        end;//for
  end;
end;

procedure Quicksort(Left, Right: integer);
var
  ptrLeft, ptrRight : integer;
  Temp, Pivot : TProg;
begin
  //writeln('Quicksort procedure for index ', Left,  ' to ', Right);
  ptrLeft := Left;
  ptrRight := Right;
  Pivot := Programs[(Left + Right) div 2];
  repeat
    {Increment left pointer while  it has not reached upper
     index of array segment and ProgramID of record pointed to by
     left pointer remains less than pivot ProgramID.}
    while (ptrLeft < Right) and (Programs[ptrLeft].ProgramID < Pivot.ProgramID) do
      inc(ptrLeft);
    {Decrement left pointer while it has not reached lower
     index of array segment and ProgramID of record pointed to by
     right pointer remains greater than pivot ProgramID.}
    while (ptrRight > Left) and (Programs[ptrRight].ProgramID > Pivot.ProgramID) do
      dec(ptrRight);

    if ptrLeft <= ptrRight then  //if left pointer and right pointer have not crossed
      begin
        //Swap records at left and right pointers if pointers are not equal
        if ptrLeft < ptrRight then
          begin
            //writeln('Swapping ', Programs[ptrLeft].ProgramID, ' with ',Programs[ptrRight].ProgramID);
            Temp := Programs[ptrLeft];
            Programs[ptrLeft] := Programs[ptrRight];
            Programs[ptrRight] := Temp;
            //DisplayRecords;
          end;
       //Move pointers one place (left pointer moves right and right pointer moves left).
       inc(ptrLeft);
       dec(ptrRight);
     end;
  until ptrLeft > ptrRight;  //Until pointers have crossed
  //Sort the left segment of the partition if there is more than one item in it.
  if ptrRight > Left then
    Quicksort(Left, ptrRight);
  //Sort the right segment of the partition if there is more than one item in it.
  if ptrLeft < Right then
    Quicksort(ptrLeft, Right);
end;


procedure Init;
begin
  LastRecord := 0;
end;

procedure SaveRecords;
var
  ProgFile : file of TProg;
  Count : integer;
begin
  if LastRecord = 0 then
    writeln('No records to save')
  else
    begin
      assignFile(ProgFile, Filename);
      rewrite(ProgFile);
      for Count := 1 to LastRecord do
        write(ProgFile, Programs[Count]);
      closeFile(ProgFile);
    end;
end;

procedure LoadRecords;
var
  ProgFile : file of TProg;
begin
  assignFile(ProgFile, FILENAME);
  reset(ProgFile);
  LastRecord := 0;
  while not eof(Progfile) do
    begin
      inc(LastRecord);
      read(ProgFile, Programs[LastRecord]);
    end;
  closeFile(ProgFile);
end;

begin
  Init;
  repeat
    writeln(#13#10'Please type the number of your choice.');
    writeln('1 - Insert a record');
    writeln('2 - Save records');
    writeln('3 - Load records  (requires Progs.txt)');
    writeln('4 - Display records');
    writeln('5 - Bubble sort on program ID');
    writeln('6 - Bubble sort on program name');
    writeln('7 - Insertion Sort on program ID');
    writeln('8 - Quicksort on program ID');
    writeln('9 - Find a record by linear/sequential search using Program ID');
    writeln('    (You need to sort the file using option 5, 7 or 8 first).');
    writeln('10 - Find a record by binary search on Program ID');
    writeln('11 - Edit a record');
    writeln('12 - Delete a record');
    writeln('13 - Quit');
    readln(Choice);
    case choice of
      1 : begin
            write('Which program ID would you like to insert? ');
            readln(SelectedID);
            InsertRecord(SelectedID);
          end;
      2 : begin
            writeln('Saving records');
            SaveRecords;
          end;
      3 : begin
            writeln('Loading records');
            LoadRecords;
          end;
      4 : DisplayRecords;
      5 : begin
            writeln('Bubble sort on program ID');
            BubbleSort(1);
          end;
      6 : begin
            writeln('Bubble sort on program Name');
            BubbleSort(2);
          end;

      7 : begin
            writeln('Insertion sort on program ID');
            InsertionSort;
          end;
      8 : begin
            writeln('Quicksort on program ID');
            QuickSort(1, LastRecord);
          end;
      9 : begin
            write('What is the ID of the record to find? ');
            readln(SelectedID);
            Find (SelectedID, FoundRecord );
          end;
      10 : begin
            write('What is the ID of the record to find? ');
            readln(SelectedID);
            BinarySearch (SelectedID, 1, LastRecord);
          end;
      11 : begin
             write('What is the ID of the record to edit? ');
             readln(SelectedID);
             Edit(SelectedID);
           end;
      12 : begin
            write('What is the ID of the record to delete? ');
            readln(SelectedID);
            Delete(SelectedID);
          end;
    end;//case
  until Choice = 13;
end.