labraddatastructures.pas

As science advances, novel experiments are becoming more and more complex, requiring a zoo of contro

{ Copyright (C) 2007 Markus Ansmann
 
  This program is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 2 of the License, or
  (at your option) any later version.
 
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
 
  You should have received a copy of the GNU General Public License
  along with this program.  If not, see <http://www.gnu.org/licenses/>.  }

{
 TODO:

  - Verify type casting and unit conversion

  - Document

  - Error checking

  - Maybe add quick-locate for node only (for typetag, gettype, getunits, and isblah functions)
}

unit LabRADDataStructures;

interface

 uses
  Classes, LabRADTypeTree, LabRADUnflattener;

 type
  TLabRADDataType = (dtEmpty,    dtAnything,
                     dtBoolean,
                     dtInteger,  dtWord,
                     dtString,
                     dtValue,    dtComplex,
                     dtTimestamp,
                     dtCluster,  dtArray);

  TLabRADID = longword;

  TLabRADContext = packed record
    High, Low: TLabRADID;
  end;

  TLabRADRequestID = integer;

  TLabRADSizeArray = array of integer;

  TLabRADEndianness = (enLittleEndian, enBigEndian, enUnknown);

  TLabRADComplex = packed record
    Real: double;
    Imag: double;
  end;

  TLRDInfo = record
    Node:    PLabRADTypeTreeNode;
    Data:    PByte;
  end;

  TLabRADData = class(TPersistent)
   private
    fTypeTag:     string;
    fTypeTree:    TLabRADTypeTree;
    fDataBuffer:  PByte;
    fUnflattener: TLabRADUnflattener;
    fResultText:  TStringList;

    function Locate(const Indices: array of integer; RequiredTypeTag: TLabRADNodeType = ntAnything): TLRDInfo;
    procedure DoConversion(TypeTree: TLabRADTypeTree);

   public
    constructor Create;                                                 reintroduce; overload;
    constructor Create(TypeTag: string);                                reintroduce; overload;
    constructor Create(Code: integer; Error: string);                   reintroduce; overload;
    constructor Create(TypeTag: string; Endianness: TLabRADEndianness); reintroduce; overload;
    destructor  Destroy; override;

    function  Flatten  (Endianness: TLabRADEndianness = enLittleEndian): string;
    function  Unflatten(var BufferPtr: PByte; var Size: integer): Boolean;

    function  Pretty(                           ShowTypes: Boolean=False): string; overload;
    function  Pretty(Index: integer;            ShowTypes: Boolean=False): string; overload;
    function  Pretty(Indices: array of integer; ShowTypes: Boolean=False): string; overload;

    function  TypeTag:                            string; overload;
    function  TypeTag(Index: integer):            string; overload;
    function  TypeTag(Indices: array of integer): string; overload;

    function  GetType:                                       TLabRADDataType; overload;
    function  GetType     (Index:            integer):       TLabRADDataType; overload;
    function  GetType     (Indices: array of integer):       TLabRADDataType; overload;

    function  IsEmpty:                                       boolean;
    function  IsError:                                       boolean;

    function  IsBoolean:                                     boolean;         overload;
    function  IsBoolean   (Index:            integer):       boolean;         overload;
    function  IsBoolean   (Indices: array of integer):       boolean;         overload;
    function  GetBoolean:                                    boolean;         overload;
    function  GetBoolean  (Index:            integer):       boolean;         overload;
    function  GetBoolean  (Indices: array of integer):       boolean;         overload;
    procedure SetBoolean  (                           Value: boolean);        overload;
    procedure SetBoolean  (Index:            integer; Value: boolean);        overload;
    procedure SetBoolean  (Indices: array of integer; Value: boolean);        overload;

    function  IsInteger:                                     boolean;         overload;
    function  IsInteger   (Index:            integer):       boolean;         overload;
    function  IsInteger   (Indices: array of integer):       boolean;         overload;
    function  GetInteger:                                    integer;         overload;
    function  GetInteger  (Index:            integer):       integer;         overload;
    function  GetInteger  (Indices: array of integer):       integer;         overload;
    procedure SetInteger  (                           Value: integer);        overload;
    procedure SetInteger  (Index,                     Value: integer);        overload;
    procedure SetInteger  (Indices: array of integer; Value: integer);        overload;

    function  IsWord:                                        boolean;         overload;
    function  IsWord      (Index:            integer):       boolean;         overload;
    function  IsWord      (Indices: array of integer):       boolean;         overload;
    function  GetWord:                                       longword;        overload;
    function  GetWord     (Index:            integer):       longword;        overload;
    function  GetWord     (Indices: array of integer):       longword;        overload;
    procedure SetWord     (                           Value: longword);       overload;
    procedure SetWord     (Index:            integer; Value: longword);       overload;
    procedure SetWord     (Indices: array of integer; Value: longword);       overload;

    function  IsString:                                      boolean;         overload;
    function  IsString    (Index:            integer):       boolean;         overload;
    function  IsString    (Indices: array of integer):       boolean;         overload;
    function  GetString:                                     string;          overload;
    function  GetString   (Index:            integer):       string;          overload;
    function  GetString   (Indices: array of integer):       string;          overload;
    procedure SetString   (                           Value: string);         overload;
    procedure SetString   (Index:            integer; Value: string);         overload;
    procedure SetString   (Indices: array of integer; Value: string);         overload;

    function  IsValue:                                       boolean;         overload;
    function  IsValue     (Index:            integer):       boolean;         overload;
    function  IsValue     (Indices: array of integer):       boolean;         overload;
    function  GetValue:                                      double;          overload;
    function  GetValue    (Index:            integer):       double;          overload;
    function  GetValue    (Indices: array of integer):       double;          overload;
    procedure SetValue    (                           Value: double);         overload;
    procedure SetValue    (Index:            integer; Value: double);         overload;
    procedure SetValue    (Indices: array of integer; Value: double);         overload;

    function  IsComplex:                                     boolean;         overload;
    function  IsComplex   (Index:            integer):       boolean;         overload;
    function  IsComplex   (Indices: array of integer):       boolean;         overload;
    function  GetComplex:                                    TLabRADComplex;  overload;
    function  GetComplex  (Index:            integer):       TLabRADComplex;  overload;
    function  GetComplex  (Indices: array of integer):       TLabRADComplex;  overload;
    procedure SetComplex  (                           Value: TLabRADComplex); overload;
    procedure SetComplex  (Index:            integer; Value: TLabRADComplex); overload;
    procedure SetComplex  (Indices: array of integer; Value: TLabRADComplex); overload;
    procedure SetComplex  (                           Real, Imag: double);    overload;
    procedure SetComplex  (Index:            integer; Real, Imag: double);    overload;
    procedure SetComplex  (Indices: array of integer; Real, Imag: double);    overload;

    function  GetUnits:                                      string;          overload;
    function  GetUnits    (Index: integer):                  string;          overload;
    function  GetUnits    (Indices: array of integer):       string;          overload;
    function  HasUnits:                                      boolean;         overload;
    function  HasUnits    (Index: integer):                  boolean;         overload;
    function  HasUnits    (Indices: array of integer):       boolean;         overload;

    function  IsTimeStamp:                                   boolean;         overload;
    function  IsTimeStamp (Index:            integer):       boolean;         overload;
    function  IsTimeStamp (Indices: array of integer):       boolean;         overload;
    function  GetTimeStamp:                                  TDateTime;       overload;
    function  GetTimeStamp(Index:            integer):       TDateTime;       overload;
    function  GetTimeStamp(Indices: array of integer):       TDateTime;       overload;
    procedure SetTimeStamp(                           Value: TDateTime);      overload;
    procedure SetTimeStamp(Index:            integer; Value: TDateTime);      overload;
    procedure SetTimeStamp(Indices: array of integer; Value: TDateTime);      overload;

    function  IsArray:                                       boolean;         overload;
    function  IsArray     (Index:            integer):       boolean;         overload;
    function  IsArray     (Indices: array of integer):       boolean;         overload;
    function  GetArraySize:                            TLabRADSizeArray;        overload;
    function  GetArraySize(Index:            integer): TLabRADSizeArray;        overload;
    function  GetArraySize(Indices: array of integer): TLabRADSizeArray;        overload;
    procedure SetArraySize(                           Size:           integer); overload;
    procedure SetArraySize(Index:            integer; Size:           integer); overload;
    procedure SetArraySize(Indices: array of integer; Size:           integer); overload;
    procedure SetArraySize(                           Sizes: array of integer); overload;
    procedure SetArraySize(Index:            integer; Sizes: array of integer); overload;
    procedure SetArraySize(Indices: array of integer; Sizes: array of integer); overload;

    function  IsCluster:                                     boolean;         overload;
    function  IsCluster   (Index:            integer):       boolean;         overload;
    function  IsCluster   (Indices: array of integer):       boolean;         overload;

    procedure Convert(TypeTree:  TLabRADTypeTree); overload;
    procedure Convert(TypeTrees: array of TLabRADTypeTree); overload;
  end;



  TLabRADRecord = class(TPersistent)
   private
    fStatus:    (rsDone, rsUnflattenInfo, rsUnflattenData);
    fSetting:    TLabRADID;
    fData:       TLabRADData;
    fDataLeft:   integer;
    fEndianness: TLabRADEndianness;

   public
    constructor Create(Setting: TLabRADID; TypeTag: string);       reintroduce; overload;
    constructor Create(Setting: TLabRADID; Data: TLabRADData=nil); reintroduce; overload;
    constructor Create(Endianness: TLabRADEndianness);             reintroduce; overload;
    destructor  Destroy; override;

    function    Flatten  (Endianness: TLabRADEndianness = enLittleEndian): string;
    function    Unflatten(var BufferPtr: PByte; var Size: integer): Boolean;

    function    Pretty(ShowTypes: Boolean=False): string;

    property    Setting:   TLabRADID   read fSetting write fSetting;
    property    Data:      TLabRADData read fData;
  end;



  TLabRADPacket = class(TPersistent)
   private
    fStatus:    (psDone, psUnflattenInfo, psUnflattenData);
    fContext:    TLabRADContext;
    fRequest:    TLabRADRequestID;
    fSrcTgt:     TLabRADID;
    fData:       TLabRADData;
    fRecords:    array of TLabRADRecord;
    fDataLeft:   integer;
    fEndianness: TLabRADEndianness;
    fRefCount:   integer;

    function    GetRecord(Index: integer): TLabRADRecord;

   public
    constructor Create(Context: TLabRADContext;            Request: TLabRADRequestID; SourceTarget: TLabRADID); reintroduce; overload;
    constructor Create(ContextHigh, ContextLow: TLabRADID; Request: TLabRADRequestID; SourceTarget: TLabRADID); reintroduce; overload;
    constructor Create(Endianness: TLabRADEndianness);                                                          reintroduce; overload;
    destructor  Destroy; override;
    procedure   Free; reintroduce;
    procedure   Keep;

    function    Flatten  (Endianness: TLabRADEndianness = enLittleEndian): string;
    function    Unflatten(var BufferPtr: PByte; var Size: integer): Boolean;

    function    Pretty(ShowTypes: Boolean=False): string;

    function    AddRecord(Setting: TLabRADID; TypeTag: string):              TLabRADRecord; overload;
    function    AddRecord(Setting: TLabRADID; Data: TLabRADData=nil):        TLabRADRecord; overload;
    function    AddRecord(Setting: TLabRADID; Code: integer; Error: string): TLabRADRecord; overload;

    function    Count: integer;

    procedure   SetContextHigh(Value: TLabRADID);

    property    Context:                 TLabRADContext   read fContext;
    property    Request:                 TLabRADRequestID read fRequest write fRequest;
    property    Source:                  TLabRADID        read fSrcTgt  write fSrcTgt;
    property    Target:                  TLabRADID        read fSrcTgt  write fSrcTgt;
    property    Records[Index: integer]: TLabRADRecord    read GetRecord; default;
  end;

  TLabRADComponent = class(TComponent);

implementation

uses
  SysUtils, LabRADTimeStamps, LabRADFlattener, LabRADPrettyPrinter, LabRADExceptions, LabRADMemoryTools, LabRADDataConverter;


constructor TLabRADData.Create;
begin
  inherited Create;
  fTypeTag:=TypeTag;
  fTypeTree:=TLabRADTypeTree.Create('');
  GetMem(fDataBuffer, fTypeTree.TopNode.DataSize);
  fUnflattener:=nil;
  fResultText:=TStringList.Create;
  LabRADZeroData(fDataBuffer, fTypeTree.TopNode);
end;

constructor TLabRADData.Create(TypeTag: string);
begin
  inherited Create;
  fTypeTag:=TypeTag;
  fTypeTree:=TLabRADTypeTree.Create(TypeTag);
  GetMem(fDataBuffer, fTypeTree.TopNode.DataSize);
  fUnflattener:=nil;
  fResultText:= TStringList.Create;
  LabRADZeroData(fDataBuffer, fTypeTree.TopNode);
end;

constructor TLabRADData.Create(Code: integer; Error: string);
begin
  Create('E');
  SetInteger(0, Code);
  SetString (1, Error);
end;

constructor TLabRADData.Create(TypeTag: string; Endianness: TLabRADEndianness);
begin
  inherited Create;
  fTypeTag:=    TypeTag;
  fTypeTree:=   TLabRADTypeTree.Create(TypeTag);
  fDataBuffer:= nil;
  fUnflattener:=TLabRADUnflattener.Create(fTypeTree.TopNode, fDataBuffer, Endianness=enBigEndian);
  fResultText:= TStringList.Create;
end;

destructor TLabRADData.Destroy;
begin
  if assigned(fDataBuffer) and assigned(fTypeTree.TopNode) then
    LabRADFreeData(fDataBuffer, fTypeTree.TopNode);
  if assigned(fUnflattener) then fUnflattener.Free;
  fTypeTree.Free;
  fResultText.Free;
  inherited;
end;

function TLabRADData.Locate(const Indices: array of integer; RequiredTypeTag: TLabRADNodeType = ntAnything): TLRDInfo;
var DataPtr:  PByte;
    TypeNode: PLabRADTypeTreeNode;
    a, b, c:  integer;
    Size:     integer;
    SkipCnt:  integer;
begin
  // Start at the beginning
  DataPtr:=fDataBuffer;
  TypeNode:=fTypeTree.TopNode;
  if not assigned(TypeNode) then
    raise ELabRADIndexError.Create('No data found', Indices, 0);
  for a:=1 to length(Indices) do
    if Indices[a-1]<0 then
      raise ELabRADIndexError.Create('Negative indices are not allowed', Indices, a);
  a:=0;
  while a<length(Indices) do begin
    // Traverse into container (if it is one)
    case TypeNode.NodeType of
     ntCluster:
      begin
        // Grab index into cluster
        b:=Indices[a];
        // Step down the type tree
        TypeNode:=TypeNode.Down;
        // Start stepping across
        while (b>0) and assigned(TypeNode) do begin
          // Skip over element data
          inc(DataPtr,  TypeNode.DataSize);
          // Traverse the type tree sideways
          TypeNode:=TypeNode.Right;
          dec(b);
        end;
        // Did we walk off the edge of the cluster?
        if not assigned(TypeNode) then