Chip 2001 December/Chip_2001-12_cd1.bin/zkuste/delphi/kolekce/d56/DM2KVCL.ZIP/DATA.PAS

Pascal/Delphi Source File | 2000-12-31 | 21KB | 569 lines

{****************************************************************************}
{                            Data Master 2000                                }
{****************************************************************************}
unit Data;
{$I+,B-,X+}
interface

uses
  Windows, Messages, Classes, SysUtils, Controls, Forms, Dialogs, Common;

type

{--- Data elements ---}

  TData=class                               {abstract class for data elements}
  protected
    function GetData: string; virtual; abstract;           {for Data property}
    procedure SetData(S: string); virtual; abstract;
    procedure FreeData; virtual;            {disposes off occupied heap space}
    procedure LoadData(var F: text); virtual;              {text file support}
    procedure SaveData(var F: text); virtual;
    procedure ReadData(S: TStream); virtual; abstract;        {stream support}
    procedure WriteData(S: TStream); virtual; abstract;
  public
    property Data: string read GetData write SetData;   {string image of data}
    destructor Destroy; override;
    procedure Copy(D: TData); virtual;    // copies data from D w/o conversion
  end;

  TStringData=class(TData)           {represents dynamically allocated string}
  private                            {this class is similar to old DM object!}
    FData: PString;
  protected
    function GetData: string; override;
    procedure SetData(S: string); override;
    procedure FreeData; override;
    procedure ReadData(S: TStream);  override;
    procedure WriteData(S: TStream); override;
  end;

  TFunction=class(TData)                       {represents Y(X) (2D) function}
  protected
    function GetData: string; override;
    procedure SetData(S: string); override;
    procedure LoadData(var F: text); override;        {use direct file access}
    procedure SaveData(var F: text); override;
    procedure ReadData(S: TStream);  override;
    procedure WriteData(S: TStream); override;
  public
    X,Y:TReal;
  end;

  ERealDataError=class(Exception);      {raised when data access error occurs}

  TRealData=class(TData)             {similar to according DM/DMW data object}
  private
    FNumCol: integer;
    FData: PRealArray;
  protected
    function GetData: string; override;
    procedure SetData(S: string); override;
    procedure FreeData; override;
    procedure ReadData(S: TStream);  override;
    procedure WriteData(S: TStream); override;
  public
    Format: PFormatArray;                    {points to window's format array}
    class function GetClipboardFormat: word;
    function GetItemText(N: integer): string;     {returns text of n-th value}
    function GetRData(var R: TRealArray): integer;  {returns number of values}
    procedure SetRData(N: integer; R: TRealArray);                 {set array}
    function GetItem(N: integer): TReal;                  {returns n-th value}
    procedure SetItem(N: integer; R: TReal);                       {set --#--}
    procedure DelItem(N: integer);                              {delete --#--}
    procedure InsItem(R: TReal);                                   {add value}
    procedure Copy(D: TData); override; // copy data w/o truncation and format
    property Size: integer read FNumCol;
    property RData[N:integer]: TReal read GetItem write SetItem; default;
  end;

  T3DFunction=class(TRealData) {introduce 3D function without additional code}
  public
    property X: TReal index 1 read GetItem write SetItem;
    property Y: TReal index 2 read GetItem write SetItem;
    property Z: TReal index 3 read GetItem write SetItem;
  end;

{--- Data container ---}

  TDataType=(dtCustom, dtStringData, dtFunction, dtRealData);
  TCompareResult=(crGreater, crLess, crEqual);
  TCompareEvent=function(Sender: TObject;
                I1,I2: TData): TCompareResult of object;
  TInitItemEvent=function(Sender: TObject): TData of object;
  TProgressEvent=procedure(Sender: TObject; P: integer) of object;
  TDataClass=class of TData;

  TContainer=class(TComponent)                     {container component class}
  private
    FFileName: string;
    FDataClass: TDataClass;
    FUpdateCaption: boolean;
    FAutoLoad: boolean;
    FList: TList;
    FInitItem: TInitItemEvent;
    FProgress: TProgressEvent;
    FModified: boolean;
    FChanged: TNotifyEvent;                     {used for "changed" indicator}
    FCompare: TCompareEvent;
    DataCache: TReal;                     {buffers for Calibrate: value cache}
    RowCache: TRealArray;                                    {table row cache}
    procedure SetDataType(T: TDataType);                 {simulate data field}
    function GetDataType: TDataType;
    procedure SetFileName(FN: string);
    procedure SetModified(M: boolean);
  protected
    procedure DefineProperties(Filer: TFiler); override;      {for store data}
  public
    property Items: TList read FList;
    property Modified: boolean read FModified write SetModified;
    property DataClass: TDataClass read FDataClass write FDataClass;
    procedure ShowProgress(P: integer); virtual;  {these 2 may be overridden!}
    function InitItem: TData; virtual;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear;
    procedure LoadFromFile;                                {text file support}
    procedure SaveToFile(Backup: boolean); {when true, save will cause backup}
    procedure LoadFromStream(S: TStream);                     {stream support}
    procedure SaveToStream(S: TStream);
    procedure Sort(BegLine,EndLine: integer; Descend: boolean);
    procedure Assign(Source: TPersistent); override;    {container or strings}
    function Calibrate(R:TReal; Index,Key: integer): TReal;{table calibration}
  published
    property FileName: string read FFileName write SetFileName;
    property DataType: TDataType read GetDataType write SetDataType;
    property UpdateCaption: boolean read FUpdateCaption write FUpdateCaption;
    property AutoLoad: boolean read FAutoLoad write FAutoLoad;
    property OnInitItem: TInitItemEvent read FInitItem write FInitItem;
    property OnProgress: TProgressEvent read FProgress write FProgress;
    property OnChanged: TNotifyEvent read FChanged write FChanged;
    property OnCompare: TCompareEvent read FCompare write FCompare;
  end;

procedure Register;

resourcestring
  errDelItem='Cannot delete item!';
  errSetItem='Cannot set item!';
  errGetItem='Cannot get item!';
  errInsItem='Cannot insert item!';
  errInitItem='Cannot initialize item!';
  msgSetCustom='You need to define %s.OnInitItem or DataClass!';
  errSort='Unable to sort lines!';

implementation

{--- TData ---}

procedure TData.LoadData(var F: text);
var S: string;
begin readln(F, S); Data:=S; end;

procedure TData.SaveData(var F: text);
begin writeln(F, Data); end;

destructor TData.Destroy;      {in addition, disposes off occupied heap space}
begin FreeData; inherited Destroy; end;

procedure TData.FreeData;
begin end;       {does nothing, but not abstract - called in all descendants!}

procedure TData.Copy(D: TData);
begin Data:=D.Data end;                    // by default, simply copies string

{--- TStringData ---}

procedure TStringData.FreeData;
begin if assigned(FData) then DisposeStr(FData); FData:=nil; end;

function TStringData.GetData: string;
begin if assigned(FData) then result:=FData^ else result:=''; end;

procedure TStringData.SetData(S: string);
begin FreeData; if S<>'' then FData:=NewStr(S); end;

procedure TStringData.ReadData(S: TStream);
var D: shortstring;
begin S.ReadBuffer(D[0],1); S.ReadBuffer(D[1],byte(D[0])); Data:=D; end;

procedure TStringData.WriteData(S: TStream);
var D: shortstring;
begin D:=Data; S.WriteBuffer(D[0], length(D)+1); end;

{--- TFunction ---}

{constructor TFunction.Create(xx,yy: TReal);
begin inherited Create; X:=xx; Y:=yy; end;}

function TFunction.GetData: string;
begin Result:=FloatToStr(X)+' '+FloatToStr(y); end;

procedure TFunction.SetData(S: string);
var R: TRealArray; N: integer;
begin N:=Str2Real(S, R); if N>0 then X:=R[1]; if N>1 then Y:=R[2]; end;

procedure TFunction.LoadData(var F: text);
begin readln(F, X, Y); end;

procedure TFunction.SaveData(var F: text);
begin writeln(F, X, Y); end;

procedure TFunction.ReadData(S: TStream);
begin S.ReadBuffer(X, Sizeof(X)); S.ReadBuffer(Y, Sizeof(Y)); end;

procedure TFunction.WriteData(S: TStream);
begin S.WriteBuffer(X, Sizeof(X)); S.WriteBuffer(Y, Sizeof(Y)); end;

{--- TRealData ---}

const RealDataFormat: word=0;

function TRealData.GetData: string;
var I: integer;
begin
  result:=''; for I:=1 to FNumCol do result:=result+GetItemText(I)+' ';
end;

procedure TRealData.SetData(S: string);
var R: TRealArray; N: integer;
begin  N:=Str2Real(S, R); SetRData(N,R); end;

procedure TRealData.FreeData;
begin
  if assigned(FData) then FreeMem(FData, FNumCol*SizeOf(TReal));
  FNumCol:=0; FData:=nil;
end;

function TRealData.GetItemText(N: integer): string;
var W, D: integer; F: TFloatFormat;
begin
  if N>FNumCol then begin result:=''; Exit; end;               {no such item!}
  if assigned(Format) then with Format^[N] do                     {get format}
  begin W:=Width; D:=Decimals; F:=FType; end
  else begin W:=15; D:=7; F:=ffGeneral; end;
  result:=FloatToStrF(GetItem(N), F, W, D);                 {make item's text}
end;

function TRealData.GetRData(var R: TRealArray): integer;
var I: integer;
begin for I:=1 to FNumCol do R[I]:=FData^[I]; GetRData:=FNumCol; end;

procedure TRealData.SetRData(N: integer; R: TRealArray);
var I: integer;
begin
  FreeData; if N<1 then Exit; FNumCol:=N;
  GetMem(FData, N*SizeOf(TReal)); for I:=1 to N do FData^[I]:=R[I];
end;

function TRealData.GetItem(N: integer): TReal;
begin
  if (N<1) or (N>FNumCol) then raise ERealDataError.Create(errGetItem)
  else result:=FData^[N];
end;

procedure TRealData.SetItem(N: integer; R: TReal);
begin
  if (N<1) or (N>FNumCol) then raise ERealDataError.Create(errSetItem)
  else FData^[N]:=R;
end;

procedure TRealData.DelItem(N: integer);
var I,J,K: integer; R: TRealArray;
begin
  if (N<1) or (N>FNumCol) then
  begin raise ERealDataError.Create(errDelItem); Exit; end;
  K:=FNumCol; for I:=1 to K do R[I]:=FData^[I]; FreeData;          {save data}
  GetMem(FData, (K-1)*SizeOf(TReal)); FNumCol:=K-1;               {del column}
  J:=1; for I:=1 to K do if I<>N then begin FData^[J]:=R[I]; Inc(J); end;
end;

procedure TRealData.InsItem(R: TReal);
var I,N: integer; Rr: TRealArray;
begin
  if FNumCol=MaxCols then raise ERealDataError.Create(errInsItem)
  else begin
    N:=FNumCol; for I:=1 to N do Rr[I]:=FData^[I]; FreeData;       {save data}
    GetMem(FData, (N+1)*SizeOf(TReal)); FNumCol:=N+1;             {add column}
    for I:=1 to N do FData^[I]:=Rr[I]; FData^[N+1]:=R;            {ins to end}
  end;
end;

procedure TRealData.ReadData(S: TStream);             {2.0 change: N=BYTE!!!!}
var I,N: byte; R: TRealArray;
begin
  N:=FNumCol; S.ReadBuffer(N, SizeOf(N));
  for I:=1 to N do S.ReadBuffer(R[I], SizeOf(TReal));
  SetRData(N,R);
end;

procedure TRealData.WriteData(S: TStream);
var I,N: byte;
begin
  N:=FNumCol; S.WriteBuffer(N, SizeOf(N));
  for I:=1 to N do S.WriteBuffer(FData^[I], SizeOf(TReal));
end;

procedure TRealData.Copy(D: TData);
var R: TRealArray; N: byte;
begin
  if D is TRealData then
  begin
    N:=(D as TRealData).GetRData(R); Format:=(D as TRealData).Format;
    SetRData(N,R);
  end else inherited;
end;

class function TRealData.GetClipboardFormat: word;
begin
  if RealDataFormat=0 then Result:=RegisterClipboardFormat('TRealData Array')
  else Result:=RealDataFormat;
end;

{--- TContainer ---}

constructor TContainer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFileName:='NONAME';
  FUpdateCaption:=false;
  FAutoLoad:=false;
  FDataClass:=TStringData;
  FList:=TList.Create;
  FModified:=false;
end;

destructor TContainer.Destroy;                    {clears & disposes off list}
begin Clear; if Assigned(FList) then Flist.Free; inherited Destroy; end;

function TContainer.InitItem: TData;       {inits data element when load file}
begin                                                         {NOTE: virtual!}
  if Assigned(FInitItem) then Result:=FInitItem(Self)
  else if Assigned(FDataClass) then Result:=FDataClass.Create else
  begin
    MessageDlg(errInitItem, mtError, [mbCancel], 0); Result:=nil;
  end;
end;

{NOTE! CUSTOM TYPE MEANS THAT YOU NEED EITHER DEFINE ONINITITEM OR SET
DATACLASS PROPERTY(AT RUNTIME)! ELSE INITITEM WILL FAIL.}

procedure TContainer.ShowProgress(P: integer);                {NOTE: virtual!}
begin if Assigned(FProgress) then FProgress(Self, P); end;

procedure TContainer.SetDataType(T: TDataType);
begin
  case T of
    dtCustom: begin
                if csDesigning in ComponentState then          {warn designer}
                MessageDlg(Format(msgSetCustom,[Name]), mtWarning, [mbOk], 0);
                FDataClass:=nil;
              end;
    dtStringData: FDataClass:=TStringData;                    {set class type}
    dtFunction: FDataClass:=TFunction;
    dtRealData: FDataClass:=TRealData;
  end;
end;

function TContainer.GetDataType: TDataType;       {NOTE! ALL derivative types}
begin                                                      {denotes dtCUSTOM!}
  Result:=dtCustom;{default}                                       {=}
  if FDataClass=TStringData then Result:=dtStringData;
  if FDataClass=TFunction then Result:=dtFunction;
  if FDataClass=TRealData then Result:=dtRealData;
end;

procedure TContainer.SetFileName(FN: string);
begin
  if FUpdateCaption and (Owner is TForm)
  then (Owner as TForm).Caption:=ExtractFileName(FN);
  if FAutoLoad and (FFileName<>FN) then   {if name changed-try to reload data}
  begin FFileName:=FN; LoadFromFile; end else FFileName:=FN;
end;

procedure TContainer.Clear;               {delets & disposes off all elements}
var I: integer; P: TData;
begin
  if not Assigned(FList) or (FList.Count=0) then Exit;
  for I:=0 to FList.Count-1 do begin P:=FList[I]; P.Free; end;
  FList.Clear;                                {^       can't use AS operator!}
  Modified:=true;
end;

procedure TContainer.LoadFromFile;                      {loads data from file}
var F: system.text; P: TData;
begin
  try
    Screen.Cursor:=crHourGlass; Clear;                   {prepare for loading}
    system.Assign(F, FileName); system.Reset(F);       {open file for reading}
    try
      while not eof(F) do                           {read all lines in cycle:}
      begin
        P:=InitItem; if not assigned(P) then Break; P.LoadData(F); {!!! <>nil}
        FList.Add(P); ShowProgress(FList.Count);
      end;
    finally
      system.Close(F);               {Note: close only if open successfully!!}
      Modified:=false;
    end;
  finally
    Screen.Cursor:=crDefault;                       {restore cursor (always!)}
  end;
end;

procedure TContainer.SaveToFile(Backup: boolean);         {saves data to file}
var F: system.text; I: integer; P: TData; BakName: string;
begin
  try
    Screen.Cursor:=crHourGlass;
    if Backup then                 {if old version exists, rename it to *.BAK}
    begin
      BakName:=ChangeFileExt(FileName, '.BAK');     {make name of backup copy}
      if FileExists(BakName) then DeleteFile(BakName); {del old bak if exists}
      RenameFile(FileName, BakName);                    {must be successfull!}
    end;
    system.Assign(F, FileName); system.ReWrite(F);     {open file for writing}
    try
      for I:=0 to FList.Count-1 do                                  {write...}
      begin
        P:=FList[I]; P.SaveData(F);
        if FList.Count>1 then ShowProgress(Round(I/(FList.Count-1)*100.0));
      end;                                    {^HERE may be integer overflow!}
    finally
      system.Close(F);
      Modified:=false;
    end;
  finally
    Screen.Cursor:=crDefault;                                        {restore}
  end;
end;

procedure TContainer.LoadFromStream(S: TStream);
var I,N: longint; P: TData; T: TDataType;
begin
  Screen.Cursor:=crHourGlass;
  S.ReadBuffer(T, SizeOf(T)); DataType:=T;                    {read data type}
  S.ReadBuffer(N,SizeOf(N));                              {number of elements}
  Clear;                                                          {clear list}
  for I:=1 to N do                                             {read elements}
  begin
    P:=InitItem; if not Assigned(P) then Break;                    {!!! <>nil}
    P.ReadData(S); FList.Add(P); if N<>0 then ShowProgress(Round(I/N*100.0));
  end;
  Modified:=false;
  Screen.Cursor:=crDefault;
end;

procedure TContainer.SaveToStream(S: TStream);
var I: longint; P: TData; D: TDataType;
begin
  Screen.Cursor:=crHourGlass;
  D:=DataType; S.WriteBuffer(D, SizeOf(TDataType));     {save type and number}
  {S.WriteBuffer(FList.Count, SizeOf(integer));                  {of elements}
                 {^ This doesn't work with Delphi16!}
  I:=FList.Count; S.WriteBuffer(I, SizeOf(I));
  for I:=0 to FList.Count-1 do                    {and elements themselves...}
  begin
    P:=FList[I]; P.WriteData(S);
    if FList.Count>1 then ShowProgress(Round(I/(FList.Count-1)*100.0));
  end;
  Modified:=false;
  Screen.Cursor:=crDefault;
end;

procedure TContainer.SetModified(M: boolean);
begin
  FModified:=M;
  if Assigned(FChanged) and not (csDestroying in ComponentState)
  then FChanged(Self);      {^ prevent call when some comp-s have destroyed  }
end;

procedure TContainer.Sort(BegLine,EndLine: integer; Descend: boolean);
  procedure DoSort(BegLine,EndLine: integer; Descend: boolean);
  var I,J: Integer; D: TData;
  begin
    I:=BegLine; J:=EndLine; D:=FList[(BegLine+EndLine) shr 1];
    repeat
      if Descend then                           {recoursive sorting algorithm}
      begin
        while FCompare(Self, FList[I], D)=crGreater do Inc(I);
        while FCompare(Self, FList[J], D)=crLess do Dec(J);
      end else
      begin
        while FCompare(Self, FList[I], D)=crLess do Inc(I);
        while FCompare(Self, FList[J], D)=crGreater do Dec(J);
      end;
      if I<=J then begin Flist.Exchange(I, J); Inc(I); Dec(J); end;
    until I>J;
    if BegLine<J then DoSort(BegLine, J, Descend);
    if I<EndLine then DoSort(I, EndLine, Descend);
  end;
begin
  if (BegLine>=EndLine) or (not Assigned(FCompare)) then              {error!}
  begin MessageDlg(errSort, mtError, [mbCancel], 0); Exit; end;
  Screen.Cursor:=crHourglass;
  DoSort(BegLine,EndLine,Descend);
  Screen.Cursor:=crDefault;
  Modified:=true;
end;

procedure TContainer.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('Data', LoadFromStream, SaveToStream, True);
end;

function TContainer.Calibrate(R: TReal; Index,Key: integer): TReal;
var D1,D2: TRealData; I,J,K: integer;
begin
  if R=DataCache then begin Result:=RowCache[Index]; Exit; end;
  Result:=R; {default!!!}                           {^  value found in cache!}
  if Items.Count<6 then Exit;                             {too short table!!!}
  {main search}
  D1:=Items.First; D2:=Items.Last;                               {check range}
  if R<D1.RData[Key] then
  begin Result:=D1.RData[Index]; Exit; end;       {Bad range! NOTE: no error!}
  if R>D2.RData[Key] then
  begin Result:=D2.RData[Index]; Exit; end;
  I:=0; J:=Items.Count-1;
  repeat                                   {find Xk with half division method}
    D1:=Items[I+((J-I) div 2)];
    if R<D1.RData[Key] then J:=I+(J-I) div 2 else I:=I+(J-I) div 2;
  until J-I<2;
  D1:=Items[I]; D2:=Items[J];
  if D1.Size=D2.Size then for K:=1 to D1.Size do             {fill data cache}
  RowCache[K]:=LineInterpolate(D1.RData[Key], D2.RData[Key],
                               D1.RData[K], D2.RData[K], R);
  Result:=RowCache[Index]; DataCache:=R;
end;

procedure TContainer.Assign(Source: TPersistent);
var I,N: integer; D: TData;
begin
  if not Assigned(FList) then Exit;// ???
  if (Source is TContainer) or (Source is TStrings) then
  begin
    {Clear;} Screen.Cursor:=crHourglass;
    try        // not Clear() - else OnChanged called twice (what is not good)
      for I:=0 to Items.Count-1 do begin D:=Items[I]; D.Free; end;Items.Clear;
      if Source is TContainer then N:=(Source as TContainer).Items.Count-1
      else N:=(Source as TStrings).Count-1;
      for I:=0 to N do
      begin
        D:=InitItem; if Assigned(D) then if Source is TContainer then
        begin D.Copy((Source as TContainer).Items[I]); Items.Add(D); end
        else begin D.Data:=(Source as TStrings)[I]; Items.Add(D); end;
        if N<>0 then ShowProgress(Round(I/N*100.0));
      end;
    finally
      Modified:=true; Screen.Cursor:=crDefault;   // modified - after changes!
    end;
  end else inherited;
end;

{component registration - this unit may be used separately from dm2000}
procedure Register;
begin RegisterComponents('DM2000', [TContainer]); end;

end.