Автор: Vitaly Sergienko
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Класс для манипулирования списком вещественных чисел

Класс для манипулирования списком вещественных чисел
Класс TxFloatList позволяет оперировать динамическим списком вещественных
чисел (тип Double) двойной точности.

Применение аналогично использованию TStringList :-)

Ограничения
Проверенно на Delphi 6.0 + SP2.

Зависимости: Classes
Автор:       softland, softland@zmail.ru, Волгоград
Copyright:   Vitaly Sergienko (softland@zmail.ru)
Дата:        4 августа 2002 г.
***************************************************** }

(*
(c) Vitaly Sergienko (softland@zmail.ru)
created(10 Feb 1996)
lastmod(4 Aug 2002)

Базовая версия исходного кода взята из книги, название уже не помню :-( и обес-
печивала работу с целыми числами

ver 1.0.4

Класс для манипулирования списком вещественных чисел
  Класс TxFloatList позволяет оперировать динамическим списком вещественных
  чисел (тип Double) двойной точности.

Как можно применить
  Применение аналогично использованию TStringList :-)

Ограничения
  Проверенно на Delphi 6.0 + SP2.

Форматирование комментариев подготовлено для обработки исходников программой rjPasDoc
*)

unit floatlist;

interface

uses Classes;

const
  (* Минимальное значение для типа double *)
  _FLOAT_MIN_ = -1.1E4932;

  (* Максимальное значение для типа double *)
  _FLOAT_MAX_ = 1.1E4932;

  (* Точность в рабочих вычислениях *)
  _EPSILON_ = 0.00001;

  (* Константа возвращаемая при успешном завершении функции *)
  _OK_ = 1;

  (* Константа возвращаемая при неудачном завершении функции *)
  _ERROR_ = 0;

type

  (* Класс генерации exception при переполнении списка *)
  EOutOfRange = class(EListError);

  (* Класс обеспечивает создание, удаление, вставку и доступ к элементам динами-
     ческого списка вещественных чисел.
     Дополнительно поддерживается сортировка списка, поиск минимального и макси-
     мального значений в списке.
     Особенностью реализации списка является введение понятия несуществующего зна-
     чения "property Null". Данное свойство определяет значение, которое не участ-
     вует в операциях получения min и max списка.
     Второй особенностью списка является работа с определенной точностью, значение
     выведено в константу _EPSILON_.
     Поиск и сортировка осуществляются без использования свойства NULL и _EPSILON_
  *)
  TxFloatList = class(TPersistent)
  private
    FList: TList;
    FDuplicates: TDuplicates;
    FNULL: double;
    FMin: double;
    FMax: double;
    FSizeOfFloat: integer;
    FSorted: Boolean;
  protected
    procedure DefineProperties(Filer: TFiler); override;
    function GetCount(): integer;
    function GetItem(Index: integer): double;
    procedure SetItem(Index: integer; Value: double); virtual;
    procedure SetMin(Value: double);
    procedure SetMax(Value: double);
    procedure Sort(); virtual;
  public
    constructor Create();
    destructor Destroy(); override;
    procedure ReadMin(Reader: TReader);
    procedure WriteMin(Writer: TWriter);
    procedure ReadMax(Reader: TReader);
    procedure WriteMax(Writer: TWriter);
    procedure ReadFloats(Reader: TReader);
    procedure WriteFloats(Writer: TWriter);
    procedure SetSorted(Value: Boolean);
    procedure QuickSort(L, R: integer);
    function Find(N: double; var Index: integer): Boolean; virtual;
    function Add(Value: double): integer; virtual;
    procedure AddFloats(List: TxFloatList); virtual;
    procedure Assign(Source: TPersistent); override;
    procedure Clear(); virtual;
    procedure Delete(Index: integer); virtual;
    function Equals(List: TxFloatList): Boolean;
    procedure Exchange(Index1, Index2: integer); virtual;
    function IndexOf(N: double): integer; virtual;
    procedure Insert(Index: integer; Value: double); virtual;
    (* Помещает пустые значения в список начиная с позиции iFirst в количестве iCount *)
    function InsertNulls(iFirst, iCount: integer; _null: single): integer;
    procedure Move(CurIndex, NewIndex: integer); virtual;
    // определение max среди хранимых данных
    function FindMax(): double;
    // определение min среди хранимых данных
    function FindMin(): double;
    (* Заменяет все отрицательные значения на нулевое *)
    function ReplaceNegativeToNULL(): integer;
    (* Заменяет все значения ThisValue на ToValue, с точностью Prec *)
    function ReplaceValToVal(ThisValue, ToValue, Prec: double): integer;
    function ReplaceGreateToVal(ThisValue, ToValue, Prec: double): integer;
    function ReplaceLessToVal(ThisValue, ToValue, Prec: double): integer;
    (* Инвертирует знак всех значений*)
    function InvertValues(): integer;
    (* Меняет, инвертирует порядок всех элементов в списке *)
    function Reverse(): integer;
    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
    property Count: integer read GetCount;
    property Items[Index: integer]: double read GetItem write SetItem; default;
    property Min: double read FMin write SetMin;
    property Max: double read FMax write SetMax;
    property Null: double read FNULL write FNULL;
    property Sorted: Boolean read FSorted write SetSorted;
  end;

  (********************************************************************)
implementation

uses WinTypes;

constructor TxFloatList.Create;
begin
  inherited Create;
  FList := TList.Create;
  FSizeOfFloat := SizeOf(double);
end;

destructor TxFloatList.Destroy;
begin
  Clear;
  FList.Free;
  inherited Destroy;
end;

procedure TxFloatList.Assign(Source: TPersistent);
begin
  if Source is TxFloatList then
  begin
    Clear;
    AddFloats(TxFloatList(Source));
  end
  else
    inherited Assign(Source);
end;

procedure TxFloatList.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('Min', ReadMin, WriteMin, min <> 0);
  Filer.DefineProperty('Max', ReadMax, WriteMax, FMax <> 0);
  Filer.DefineProperty('Floats', ReadFloats, WriteFloats, Count > 0);
end;

procedure TxFloatList.ReadMin(Reader: TReader);
begin
  FMin := Reader.ReadFloat;
end;

procedure TxFloatList.WriteMin(Writer: TWriter);
begin
  Writer.WriteFloat(FMin);
end;

procedure TxFloatList.ReadMax(Reader: TReader);
begin
  FMax := Reader.ReadFloat;
end;

procedure TxFloatList.WriteMax(Writer: TWriter);
begin
  Writer.WriteFloat(FMax);
end;

procedure TxFloatList.ReadFloats(Reader: TReader);
begin
  Reader.ReadListBegin(); (* Считывание маркера начала списка *)
  Clear; (* Очистка иекущего списка *)
  while not Reader.EndOfList do
    Add(Reader.ReadFloat()); (* Добавление к списку хранящихся чисед *)
  Reader.ReadListEnd(); (* Считывание маркера конца списка *)
end;

procedure TxFloatList.WriteFloats(Writer: TWriter);
var
  i: integer;
begin
  Writer.WriteListBegin(); (* Вписываем маркер начала списка *)
  for i := 0 to Count - 1 do
    Writer.WriteFloat(GetItem(I)); (* Запись всех чисел из списка в Writer *)
  Writer.WriteListEnd(); (* Вписываем маркер конца списка *)
end;

procedure TxFloatList.SetSorted(Value: Boolean);
begin
  if FSorted <> Value then
  begin
    if Value then
      Sort();
    FSorted := Value;
  end;
end;

function TxFloatList.GetCount: integer;
begin
  Result := FList.Count;
end;

function TxFloatList.GetItem(Index: integer): double;
begin
  Result := PDouble(FList.Items[Index])^;
end;

procedure TxFloatList.SetItem(Index: integer; Value: double);
begin
  { if ( FMin <> FMax ) and ( ( Value < Fmin ) or ( Value > FMax ) ) then
      raise EOutOfRange.CreateFmt( 'Value must be within %d..%d', [FMin, FMax]);}
  PDouble(FList.Items[Index])^ := Value;
end;

procedure TxFloatList.SetMin(Value: double);
var
  i: integer;
begin
  if Value <> FMin then
  begin
    for i := 0 to Count - 1 do
      if GetItem(i) < Value then
        raise EOutOfRange.CreateFmt('Unable to set new minimum value. ' + #13 +
          'List contains values below %d', [Value]);
    FMin := Value;
    if FMin > FMax then
      FMax := FMin;
  end;
end;

procedure TxFloatList.SetMax(Value: double);
var
  i: integer;
begin
  if Value <> FMax then
  begin
    for i := 0 to Count - 1 do
      if GetItem(i) > Value then
        raise EOutOfRange.CreateFmt('Unable to set new maximum value. '#13 +
          'List contains values above %d', [Value]);
    FMax := Value;
    if FMax < FMin then
      FMin := FMax;
  end;
end;

procedure TxFloatList.AddFloats(List: TxFloatList);
var
  i: integer;
begin
  for i := 0 to Pred(List.Count) do
    Add(List[i]);
end;

function TxFloatList.Add(Value: double): integer;
begin
  Insert(Count, Value);
  result := Count;
end;

procedure TxFloatList.Clear;
var
  i: integer;
begin
  for i := 0 to Pred(FList.Count) do
    Dispose(PDouble(FList.Items[i]));
  FList.Clear;
end;

procedure TxFloatList.Delete(Index: integer);
begin
  Dispose(PDouble(FList.Items[Index]));
  FList.Delete(Index);
end;

function TxFloatList.Equals(List: TxFloatList): Boolean;
var
  i, Count: integer;
begin
  Count := GetCount;
  if Count <> List.GetCount then
    Result := False
  else
  begin
    i := 0;
    while (i < Count) and (GetItem(i) = List.GetItem(i)) do
      INC(i);
    Result := i = Count;
  end;
end;

procedure TxFloatList.Exchange(Index1, Index2: integer);
begin
  FList.Exchange(Index1, Index2);
end;

function TxFloatList.Find(N: double; var Index: integer): Boolean;
var
  l, h, i: integer;
begin
  Result := False;
  l := 0;
  h := Count - 1;
  while l <= h do
  begin
    i := (l + h) shr 1;
    if PDouble(FList[i])^ < N then
      l := i + 1
    else
    begin
      h := i - 1;
      if PDouble(FList[i])^ = N then
      begin
        Result := True;
        if Duplicates <> dupAccept then
          l := i;
      end;
    end;
  end;
  Index := l;
end;

function TxFloatList.IndexOf(N: double): integer;
var
  i: integer;
begin
  Result := -1;
  if not Sorted then
  begin
    for i := 0 to Pred(GetCount) do
      if GetItem(i) = N then
      begin
        Result := i;
        exit;
      end;
  end
  else if Find(N, i) then
    Result := i;
end;

procedure TxFloatList.Insert(Index: integer; Value: double);
var
  P: PDouble;
begin
  //comment ad 12.04.2001 softland
  // if (FMin <> FMax) and (( Value < FMin ) or (Value > FMax )) then
  // raise EOutOfRange.CreateFmt( 'Value must be within %f..%f', [FMin, FMax ]);
  NEW(p);
  p^ := Value;
  FList.Insert(Index, P);
end;

procedure TxFloatList.Move(CurIndex, NewIndex: integer);
begin
  FList.Move(CurIndex, NewIndex);
end;

procedure TxFloatList.QuickSort(L, R: integer);
var
  i, j: integer;
  p: PDouble;
begin
  i := L;
  j := R;
  P := PDouble(FList[(L + R) shr i]);
  repeat
    while PDouble(FList[i])^ < P^ do
      INC(i);
    while PDouble(FList[j])^ > P^ do
      DEC(j);
    if i <= j then
    begin
      FList.Exchange(i, j);
      INC(i);
      DEC(j);
    end;
  until i > l;
  if L < j then
    QuickSort(L, j);
  if i < R then
    Quicksort(i, R);
end;

procedure TxFloatList.Sort();
begin
  if not Sorted and (FList.Count > 1) then
    QuickSort(0, FList.Count - 1);
end;

function TxFloatList.FindMax(): double; // определение max среди хранимых данных
var
  i: integer;
  v: double;
begin
  FMax := _FLOAT_MIN_;
  for i := 0 to Count - 1 do
  begin
    v := GetItem(i);
    if abs(v - FNULL) > _EPSILON_ then
      if v > FMax then
        FMax := v;
  end;
  if abs(FMax - _FLOAT_MIN_) < _EPSILON_ then
    FMax := FNULL;
  result := FMax;
end;

function TxFloatList.FindMin: double; //определение min среди хранимых данных
var
  i: integer;
  v: double;
begin
  { for i := 0 to Count-1 do
      if GetItem(i) <> FNULL then begin
        FMin := GetItem(i);
        break;
      end;}
  FMin := _FLOAT_MAX_;
  for i := 0 to Count - 1 do
  begin
    v := GetItem(i);
    if abs(v - FNULL) > _EPSILON_ then
      if v < FMin then
        FMin := v;
  end;
  if abs(FMin - _FLOAT_MAX_) < _EPSILON_ then
    FMin := FNULL;
  result := FMin;
end;

(* Заменяет все отрицательные значения на нулевое *)

function TxFloatList.ReplaceNegativeToNULL: integer;
var
  i: integer;
begin
  result := 0;
  for i := 0 to Count - 1 do
  begin
    if Items[i] < 0 then
    begin
      Items[i] := self.Null;
      inc(result);
    end;
  end;
end;

function TxFloatList.ReplaceValToVal(ThisValue, ToValue, Prec: double): integer;
var
  i: integer;
begin
  result := 0;
  for i := 0 to Count - 1 do
  begin
    if abs(Items[i] - ThisValue) < Prec then
    begin
      Items[i] := ToValue;
      inc(result);
    end;
  end;
end;

function TxFloatList.ReplaceLessToVal(ThisValue, ToValue, Prec: double):
  integer;
var
  i: integer;
begin
  result := 0;
  for i := 0 to Count - 1 do
  begin
    if Items[i] < ThisValue then
    begin
      Items[i] := ToValue;
      inc(result);
    end;
  end;
end;

function TxFloatList.ReplaceGreateToVal(ThisValue, ToValue, Prec: double):
  integer;
var
  i: integer;
begin
  result := 0;
  for i := 0 to Count - 1 do
  begin
    if Items[i] > ThisValue then
    begin
      Items[i] := ToValue;
      inc(result);
    end;
  end;
end;

function TxFloatList.InvertValues(): integer;
var
  i: integer;
begin
  result := _OK_;
  for i := 0 to Count - 1 do
    items[i] := -items[i];
end;

function TxFloatList.Reverse(): integer;
var
  i, j: integer;
begin
  result := _OK_;
  i := 0;
  j := Count - 1;
  repeat
    self.Exchange(i, j);
    inc(i);
    dec(j);
  until i >= j;
end;

(* Заполнение в заданных пределах значениями NULL
   Подразумевается положительное и возрастающее поведение глубины, т.е.
   0<STRT<STOP
   Еи _strt > текущего min или _stop < текущего максимума содержащегося в
   списке, то функция возвращает _ERROR_
   Еи _null не совпадает со значением принятым за NULL в списке, то это игнорируется
   Заполнение ведется с текущим шагом списка *)

function TxFloatList.InsertNulls(iFirst, iCount: integer; _null: single):
  integer;
var
  k: integer;
begin
  for k := 1 to iCount do
  begin
    Insert(iFirst, _null);
    inc(iFirst);
  end;
  result := _OK_;
end;

end.