:: Pascal Page :: Написание модулей обработки данных, не зависящих от их типа

Написание модулей обработки данных, не зависящих от их типа

Обработка пользовательских типов

Очень часто при написании программ используются уже готовые модули. Например, модуль, реализующий односвязный список TList:

Unit LU;
Interface

Const
  listOk = 0;
  listOverflow = 1;
  listUnderflow = 2;

Var
  ListError : Byte;
  
Type
  TType = Integer;
  
  NodePtr = ^Node;
  Node = Record
    Info : ^TType;
    Next : NodePtr;
  End;
  
  TList = Object
    Head, AtEnd : NodePtr;
    
    Constructor Create;
    Destructor Destroy;
    
    Procedure Insert(X : TType);
    Procedure Append(X : TType);
    
    Function isEmpty : Boolean;
    
  Private
    Procedure Clear;
  End;
  
Implementation

Var SaveHeapError : Pointer;

Function HeapFunc( Size : Word ) : Integer; Far;
Begin HeapFunc := 1 End;

Constructor TList.Create;
Begin
  SaveHeapError := HeapError;
  Head := nil; AtEnd := nil;
  ListError := listOk
End;

Destructor TList.Destroy;
Begin Clear End;

Procedure TList.Clear;
Var T, Buff : NodePtr;
Begin
  ListError := listOk;
  T := Head;
  While T <> nil Do Begin
    Buff := T; T := T^.Next;
    FreeMem( Buff^.Info, SizeOf(TType) );
    Dispose( Buff )
  End
End;

Procedure TList.Insert(X : TType);
Label Quit;
Var T : NodePtr;
Begin
  HeapError := @HeapFunc;
  ListError := listOverflow;
  T := New( NodePtr );
  If T = nil Then Goto Quit;
  
  T^.Next := Head;
  GetMem( T^.Info, SizeOf(TType) );
  If T^.Info = nil Then Goto Quit;
  Move( X, T^.Info^, SizeOf(TType) );
  
  If Head = nil Then AtEnd := T;
  Head := T;
  
  ListError := listOk;
Quit:
  HeapError := SaveHeapError
End;

Procedure TList.Append(X : TType);
Label Quit;
Var T : NodePtr;
Begin
  HeapError := @HeapFunc;
  ListError := listOverflow;
  T := New( NodePtr );
  If T = nil Then Goto Quit;
  
  GetMem( T^.Info, SizeOf(TType) );
  If T^.Info = nil Then Goto Quit;
  Move( X, T^.Info^, SizeOf(TType) );
  
  T^.Next := nil;
  If Head = nil Then Head := T
  Else AtEnd^.Next := T;
  
  AtEnd := T;
  ListError := listOk;
Quit:
  HeapError := SaveHeapError
End;

Function TList.isEmpty : Boolean;
Begin isEmpty := (Head = nil) End;
END.

Этот модуль затем используется в основной программе, например, так:

Uses LU;
Var
  myiL : TList;
  i : Integer;
  
BEGIN
  myiL.Create;
  ...
  myiL.Insert(10);
  myiL.Insert(20);
  ...
  myiL.Destroy;
END.

Но у такой схемы использования есть очень существенный недостаток... Что делать, если нам понадобится список для хранения данных типа Double? Решение напрашивается само собой:

TType = Double;

А что делать, если необходимо 2 списка, один для Integer, а второй - для Double? Можно, конечно, скопировать файл LU.PAS необходимое количество раз и в каждом из них поменять TType на необходимый тип... Но есть другое решение этой проблемы:

1. Разделяем секции модуля Interface и Implementation в два разных файла: LSTINTER.SCB(интерфейсная часть) и LSTIMPLM.SCB(все остальное):

LSTINTER.SCB имеет вид:

Const
  listOk = 0;
  listOverflow = 1;
  listUnderflow = 2;
  
Var
  ListError : Byte;
Type
  NodePtr = ^Node;
  Node = Record
    Info : ^_SCHABLON_;
    Next : NodePtr;
  End;
  
  TList = Object
    Head, AtEnd : NodePtr;
    
    Constructor Create;
    Destructor Destroy;
    
    Procedure Insert(X : _SCHABLON_);
    Procedure Append(X : _SCHABLON_);
    
    Function isEmpty : Boolean;
    
  Private
    Procedure Clear;
  End;

LSTIMPLM.SCB становится таким:

Var
  SaveHeapError : Pointer;
  
Function HeapFunc( Size : Word ) : Integer; Far;
Begin HeapFunc := 1 End;

Constructor TList.Create;
Begin
  SaveHeapError := HeapError;
  Head := nil; AtEnd := nil;
  ListError := listOk
End;

Destructor TList.Destroy;
Begin Clear; End;

Procedure TList.Clear;
Var T, Buff : NodePtr;
Begin
  ListError := listOk;
  T := Head;
  While T <> nil Do Begin
    Buff := T; T := T^.Next;
    FreeMem( Buff^.Info, SizeOf(_SCHABLON_) );
    Dispose( Buff )
  End
End;

Procedure TList.Insert(X : _SCHABLON_);
Label Quit;
Var T : NodePtr;
Begin
  HeapError := @HeapFunc;
  ListError := listOverflow;
  T := New( NodePtr );
  If T = nil Then Goto Quit;
  
  T^.Next := Head;
  GetMem( T^.Info, SizeOf(_SCHABLON_) );
  If T^.Info = nil Then Goto Quit;
  Move( X, T^.Info^, SizeOf(_SCHABLON_) );
  
  If Head = nil Then AtEnd := T;
  Head := T;
  
  ListError := listOk;
Quit:
  HeapError := SaveHeapError
End;

Procedure TList.Append(X : _SCHABLON_);
Label Quit;
Var T : NodePtr;
Begin
  HeapError := @HeapFunc;
  ListError := listOverflow;
  T := New( NodePtr );
  If T = nil Then Goto Quit;
  
  GetMem( T^.Info, SizeOf(_SCHABLON_) );
  If T^.Info = nil Then Goto Quit;
  Move( X, T^.Info^, SizeOf(_SCHABLON_) );
  
  T^.Next := nil;
  If Head = nil Then Head := T
  Else AtEnd^.Next := T;
  
  AtEnd := T;
  ListError := listOk;
Quit:
  HeapError := SaveHeapError
End;

Function TList.isEmpty : Boolean;
Begin isEmpty := (Head = nil) End;

2. Для того, чтобы использовать список для хранения данных любого типа нужно просто создать новый PAS файл вида

Unit List{имя типа};
Interface

Type
  _SCHABLON_ = {имя типа};
{$I LstInter.SCB}
  
Type
  T{имя типа}List = TList;

Implementation
{$I LstImplm.SCB}
END.

и подключить его к программе. Например, для использования списка целых - LISTINT.PAS примет вид:

Unit ListInt;
Interface

Type
  _SCHABLON_ = Integer;
{$I LstInter.SCB}

Type
  TIntegerList = TList;
  
Implementation
{$I LstImplm.SCB}
END.

Таким образом нет необходимости копировать исходный файл (который может быть гораздо более длинным, чем приведенный для примера LU.PAS). Копируется лишь каркас модуля. В файлы SCB изменения вносить не нужно...

Обработка типов, определенных пользователем

Но предложенная выше схема работает не всегда. Не сработает она, например, если пользователю понадобится не один из стандартных типов Паскаля, а тип, определенный самим пользователем. Например, часть реализации массива с переменным числом элементов может выглядеть так:

Type
  TType = Integer;
  TArray = Object
    ...
    Function max: TType;
    Procedure PrintAll;
    ...
  End;
  
Function TArray.max: TType;
Var maxValue: TType; i: Word;
Begin
  maxValue := arr^[1];
  For i := 2 To SizeOfArray Do Begin
    If arr^[i] > maxValue
    Then maxValue := arr^[i];
  End;
  max := maxValue
End;

Procedure TArray.PrintAll;
Begin
  For i := 1 To SizeOfArray Do
    Write(arr^[i], ' ' );
  End;

В такую реализацию TArray можно подставить Word, Real, Double, Char... Но если у пользователя определен тип:

Type
  TPoint = Record
    X, Y: Integer;
  End;

то подставить его в качестве типа элементов TArray не удастся по нескольким причинам.

Функции в Паскале не могут возвращать результат типа Record.
В функции нахождения макс. элемента используется сравнение элементов, но для Record-ов эта операция не определена.
При выводе всего массива на экран используется процедура Write, которая не умеет работать с типами, определенными пользователем.

Но все эти причины можно устранить...

Если функция не может вернуть результат нужного пользователю типа, она должна возвращать указатель на результат.
Для того, чтобы решить эту проблему, необходимо для пользовательского типа определить операцию сравнения. Например, так:
```
type
  cmType = (cmLow, cmEqual, cmHigh);
const
  cmLowEq = [cmLow, cmEqual];
  cmHighEq = [cmHigh, cmEqual];
function _compare_(var a, b: ttype): cmtype;
begin
  _compare_ := cmEqual;
  if a.X < b.X then _compare_ := cmLow
  else
    if a.X > b.X then _compare_ := cmHigh
end;
```
Теперь вместо того, чтобы записывать операцию сравнения в обычном виде, достаточно вызвать функцию _compare_ и проверить результат (обратите внимание, функция _compare_ вызывается только тогда, когда сравниваются элементы невстроенных типов; при сравнении стандартных типов языка мы по-прежнему пользуемся обычной операцией сравнения):
```
Var a, b: TPoint;
  ...
  { вместо }
  If a > b Then ...
  { пишем так }
  If _compare_(a, b) = cmHigh Then ...
  
  { Теперь функция поиска макс. элемента запишется так: }
  Function TArray.max: PTType;
  Var max_ix, i: Word;
  Begin
    max_ix := 1;
    For i := 2 To GetSize Do
      If
        {$ifdef user_type}
          _compare_(arr^[i], arr^[max_ix]) = cmHigh
        {$else}
          arr^[i] > arr^[max_ix]
        {$endif}
      Then max_ix := i;
    max := @(arr^[max_ix])
  End;
```
Для того, чтобы эта функция работала, нужно при описании пользовательского типа отределить ключевое слово user_type при помощи директивы {$define}. То есть тип будет задаваться вот так:
```
type
  TPoint =
  {$define user_type}
  record
    x, y: Integer;
  end;
  TType = TPoint;
```
Эта причина кажется самой сложной для устранения... Но так же, как пользователь определил функцию сравнения для элементов своего типа, он может определить процедуру для вывода этого типа на экран, а вызываться эта процедура будет так (опять используем условную компиляцию для того, чтобы вызывать разные функции для встроенных и НЕвстроенных типов):
```
procedure _print_(var f: text; var t: ttype);
begin
  {$ifdef user_type}
    _out_(f, t)
  {$else}
    write(f, t)
  {$endif}
end;

{ Сама же процедура вывода может быть вот такой:}
procedure _out_(var f: text; var t: ttype);
begin
  write(f, 'X:', t.X, ';Y:', t.Y, ' ')
end;
```

Теперь, когда все препятствия устранены, мы можем заставить объект TArray работать не только со встроенными, но и с пользовательскими типами... Если для встроенных типов каркас модуля имеет вид:

Unit Arr_Int;
interface

type
  TType = Integer;
{$i ar_inter.scb}

type
  TArrayInt = TArray;
  
implementation

{$i ar_implm.scb}
end.

то для типов пользователя нужно всего лишь описать функции _compare_ (для сравнения), _in_ (для ввода пользовательского типа), и _out_ (для его вывода):

Unit Arr_Rec;
interface

type
  TPoint =
  {$define user_type}
  record
    x, y: Integer;
  end;
  TType = TPoint;
  
{$i ar_inter.scb}

type
  TArrayPoint = TArray;

implementation

procedure _out_(var f: text; var t: ttype);
begin
  write(f, 'X:', t.X, ';Y:', t.Y, ' ')
end;
procedure _in_(var f: text; var t: ttype);
begin
  write('X:'); readln(f, t.X);
  write('Y:'); readLn(f, t.Y)
end;

function _compare_(var a, b: ttype): cmtype;
begin
  _compare_ := cmEqual;
  if a.X < b.X then _compare_ := cmLow
  else
    if a.X > b.X then _compare_ := cmHigh
end;

{$i ar_implm.scb}
end.

Если какая-либо из указанных процедур не будет описана, программа компилироваться не будет.

Реализация для FPC