Написание модулей обработки данных, не зависящих от их типа | |
Обработка пользовательских типов |
Очень часто при написании программ используются уже готовые модули. Например,
модуль, реализующий односвязный список 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.
TType = Double;
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;
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;
Unit List{имя типа}; Interface Type _SCHABLON_ = {имя типа}; {$I LstInter.SCB} Type T{имя типа}List = TList; Implementation {$I LstImplm.SCB} END.
Unit ListInt; Interface Type _SCHABLON_ = Integer; {$I LstInter.SCB} Type TIntegerList = TList; Implementation {$I LstImplm.SCB} END.
Обработка типов, определенных пользователем
Но предложенная выше схема работает не всегда. Не сработает она,
например, если пользователю понадобится не один из стандартных типов Паскаля, а
тип, определенный самим пользователем. Например, часть реализации массива с
переменным числом элементов может выглядеть так:
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;
Type TPoint = Record X, Y: Integer; End;
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;
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;
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;
Unit Arr_Int; interface type TType = Integer; {$i ar_inter.scb} type TArrayInt = TArray; implementation {$i ar_implm.scb} end.
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.