Форум на Исходниках.RU

{

Keywords: OOP, Collection, Database

Программа является базой данных на основе коллекций.

Используются операции добавления, редактирования, удаления, просмотра, поиска в коллекции,

сохранения и загрузки коллекции.

Примечание: программу несложно изменить для использования интерфейса Turbo Vision.

Romtek (c) May 2005

}

uses crt, objects, drivers, strings, StudObj;

const

db_file = 'stud_db.dat';

maxitems = 9;

OptionsList: array [1..maxitems] of string[30] = (

'Load collection from file',

'Save collection to file',

'View collection',

'Add record',

'Edit record',

'Delete record',

'Search record in collection',

'Best students',

'Quit from program'

);

var

Created,

Quit: boolean;

option: integer;

procedure AbortMsg (msg: string);

{ Вывести сообщение об ошибке и выйти из программы }

begin

writeln (msg);

halt;

end;

procedure LoadCollection;

{ Загрузка сохраненной ранее коллекции из бинарного файла коллекции }

var

FS: TBufStream;

begin

FS.Init (db_file, stOpen,1024);

if FS.Status <> stOK then

AbortMsg ('File not found.'); { Файл не найден }

PC := PStudentsColl (FS.Get); { Вставить коллекцию из файла }

FS.Done;

if FS.Status <> stOK then

AbortMsg ('Error of loading collection.');

{ Произошла ошибка чтения коллекции. Подробности искать в справке по 'stXXX' }

writeln;

writeln ('Collection is loaded successfully.'); { Сообщение об успешно загруженной коллекции }

readln;

end;

procedure SaveCollection;

{ Сохранить коллекцию в файл }

var

FS: TBufStream;

begin

FS.Init (db_file, stCreate,1024); { Открываем файл коллекции на создание }

FS.Put (PC); { Вставляем коллекцию в файл }

FS.Done; { Закрываем работу с потоком }

if FS.Status <> stOK then

AbortMsg ('Error while saving collection!'); { Произошла ошибка при сохранении коллекции }

writeln;

writeln ('Collection is stored successfully.'); { Сообщение об успешно сохраненной коллекции }

readln;

end;

procedure ViewCollection (C: PCollection);

procedure CallPrint (P : PStudentInfo); far;

{ Обязательно должна присутствовать директива FAR !

Кроме того, процедура должна быть вложенной, иначе возникнут проблемы. }

begin

P^.Print;

end;

begin { Print }

Writeln;

Writeln ('Student list:');

{ помощью итератора ForEach выводим информацию о каждом студенте }

C^.ForEach (@CallPrint);

readln;

end;

procedure PrintMatches (C: PCollection; _Mark: integer);

{ Подсчёт и вывод студентов, имеющих оценку свыше указанной _Mark }

var count: word;

procedure Match (P : PStudentInfo); far;

begin

if PStudentInfo(P)^.TransferRecord.Mark >= _Mark then

begin

P^.Print;

inc (count);

end;

begin { Print }

count:=0;

Writeln (#13#10'Students who have mark above ', _Mark,': ');

C^.ForEach (@Match);

writeln;

Writeln ('Total: ', count);

readln;

end;

procedure BestStudents;

begin

PrintMatches (PC, 80); { Искать студентов, имеющих балл свыше 80 }

end;

procedure SearchRecord;

var

P: PStudentInfo;

i: integer;

who: string;

function Matches (Item: Pointer): Boolean; far;

begin

Matches := PStudentInfo (Item)^.TransferRecord.Name = Who;

end;

begin

write ('Look for student (name): '); readln (who);

{ Используйте итератор FirstThat, чтобы найти первую "карточку",

удовлетворяющую условию }

P := PC^.FirstThat (@Matches);

i := PC^.IndexOf (P);

if i >= 0 then

begin

writeln ('Student was found:');

PStudentInfo(PC^.At(i))^.Print;

end

else writeln ('"', Who ,'" was not found.');

readln;

end;

procedure AddRecord;

{ Добавление "карточки" в коллекцию }

var

SI: PStudentInfo;

Rec: TRecord;

begin

writeln('Enter some info about a student: ');

SI := New (PStudentInfo, Init); { Создаем "карточку" студента }

with SI^.TransferRecord do

begin

write ('Name: ' : 8); readln (Name); { Вводим новые фамилию }

write ('Mark: ' : 8); readln (Mark); { и оценку }

end;

PC^.Insert (SI); { Вставляем данные о студенте в коллекцию }

writeln;

writeln ('Record stored successfully.'); { Сообщение об успешно добавленной "карточке" }

readln;

end;

procedure EditRecord;

{ Редактировать заданную "карточку" студента }

var

SI: PStudentInfo;

Rec: TRecord;

num: integer;

begin

{ Прежде чем заменять данные в "карточке" студента, надо ввести его номер в коллекции.

Поэтому для начала нужно просмотреть список выбором 'View collection' }

write ('Enter number of student in list: '); readln (num);

SI := PC^.At (Pred (num)); { Присваиваем указатель на "карточку" студента под номером num-1.

Не забывайте, что нумерация в коллекциях идет с нуля! }

with SI^.TransferRecord do

begin

SI^.Print; { Показываем текущие данные из "карточки" студента }

writeln;

write ('Enter new name: '); readln (Name); { Вводим новые фамилию }

write ('Enter new mark: '); readln (Mark); { и оценку }

end;

writeln;

writeln ('Record stored successfully.'); { Сообщение об успешно измененной "карточке" }

readln;

end;

procedure DeleteRecord;

{ Удаление "карточки" из коллекции }

var

SI: PStudentInfo;

Rec: TRecord;

num: integer;

begin

{ Прежде чем удалять данные в "карточке" студента, надо ввести его номер в коллекции.

Поэтому для начала нужно просмотреть список выбором 'View collection' }

write ('Enter number of student in list: '); readln (num);

PC^.AtDelete (Pred (num));

writeln;

writeln ('Record deleted successfully.'); { Сообщение об успешно измененной "карточки" }

readln;

end;

procedure ShowMenu;

{ Построение меню и выбор операции }

var

i: integer;

begin

clrscr;

writeln ('-= Menu =-': 46);

for i := 1 to maxitems do

begin

writeln;

writeln (i: 26, '. ', OptionsList[i]); { Вывод элементов меню }

end;

writeln;

write ('Enter option: ': 43); readln (option);

end;

BEGIN

Created := true;

PC:=New(PStudentsColl,Init(50,10));

{ Создание коллекции в памяти из 50 объектов.

Цифра 10 говорит о том, что если попытаемся вставить в коллекцию больше чем 50 объектов,

то станем увеличивать начальный размер (50) на 10, пока не хватит места для всех объектов. }

if PC = Nil then { Увы, не хватило памяти... Выходим. }

exit;

repeat

ShowMenu;

{ Выбор опции }

case option of

1: if PC^.Count = 0 then { Коллекция пуста }

LoadCollection;

2: SaveCollection;

3: ViewCollection (PC);

4: AddRecord;

5: EditRecord;

6: DeleteRecord;

7: SearchRecord;

8: BestStudents;

9: Quit := true; { Получили команду выйти из программы }

end;

until Quit;

{ Освободить память от коллекции }

Dispose(PC, Done);

END.

Unit StudObj;

Interface

Uses Objects;

type

PRecord = ^TRecord;

TRecord = record

Name: String[12];

Mark: Integer;

end;

PStudentInfo=^TStudentInfo;

TStudentInfo=object(TObject)

TransferRecord: TRecord;

constructor Load(var S: TStream);

procedure Store(var S: TStream);

Procedure Print; Virtual;

end;

PStudentsColl=^TStudentsColl;

TStudentsColl=object(TSortedCollection)

function Compare(Key1, Key2: Pointer): Integer; virtual;

procedure Error(Code, Info: Integer); virtual;

end;

const

RStudentInfo: TStreamRec = (

ObjType: 55001;

VmtLink: Ofs(TypeOf(TStudentInfo)^);

Load: @TStudentInfo.Load;

Store: @TStudentInfo.Store

);

RStudentsColl: TStreamRec = (

ObjType: 55002;

VmtLink: Ofs(TypeOf(TStudentsColl)^);

Load: @TStudentsColl.Load;

Store: @TStudentsColl.Store);

var

PC: PStudentsColl;

Implementation

Uses Drivers;

type

TLinkRecord = record

PName: PString;

PMark: longint;

end;

constructor TStudentInfo.Load(var S: TStream);

begin

Inherited Init;

S.Read(TransferRecord, SizeOf(TransferRecord));

end;

procedure TStudentInfo.Store(var S: TStream);

begin

S.Write(TransferRecord, SizeOf(TransferRecord));

end;

Procedure TStudentInfo.Print;

var str: string;

LinkRecord: TLinkRecord;

Begin

with LinkRecord do

begin

PName := @TransferRecord.Name;

PMark := TransferRecord.Mark;

end;

FormatStr (str,' %-24s%-4d', LinkRecord);

writeln (str);

End;

procedure TStudentsColl.Error (Code, Info: Integer);

begin

write ('Error: ');

case Code of

coIndexError: writeln ('Index out of range.');

coOverflow : writeln ('Collection overflow.');

end;

{$i sortfunc.inc}

function TStudentsColl.Compare (Key1, Key2: Pointer): Integer;

begin

Compare:=StrICmp(PStudentInfo(Key1)^.TransferRecord.Name, PStudentInfo(Key2)^.TransferRecord.Name);

end;

begin

{ RegisterType (RSortedCollection);}

RegisterType (RStudentsColl);

RegisterType (RStudentInfo);

end.