Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Класс для манипулирования списком вещественных чисел

Автор: 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.
Проект Delphi World © Выпуск 2002 - 2024
Автор проекта: USU Software
Вы можете выкупить этот проект.