labradtypetree.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:

  - Match function:
    - Make sure everything works
    - Raise errors

}

unit LabRADTypeTree;

interface

 uses
  Classes, LabRADUnitConversion;

 type
  TLabRADNodeType = (ntEmpty,    ntAnything,
                     ntBoolean,
                     ntInteger,  ntWord,
                     ntString,
                     ntValue,    ntComplex,
                     ntTimestamp,
                     ntCluster,  ntArray);

  PLabRADTypeTreeNode = ^TLabRADTypeTreeNode;
  TLabRADTypeTreeNode = record
    NodeType:   TLabRADNodeType;
    Dimensions: Integer;
    HasUnits:   Boolean;
    Units:      string;
    DataSize:   integer;
    Right:      PLabRADTypeTreeNode;
    Up:         PLabRADTypeTreeNode;
    Down:       PLabRADTypeTreeNode;
    NeedsAttn:  Boolean;
    UConverter: TLabRADUnitConversion;
  end;

  TLabRADNodePos = (npBelow, npRight);

  TLabRADTypeTree = class (TPersistent)
   private
    fTopNode:    PLabRADTypeTreeNode;

    function NewNode(NodeType: TLabRADNodeType; Dimensions: Integer): PLabRADTypeTreeNode; overload;
    function NewNode(Prototype: PLabRADTypeTreeNode): PLabRADTypeTreeNode; overload;
    function DupNode(Prototype: PLabRADTypeTreeNode): PLabRADTypeTreeNode;
    function Parse(const TypeTag: string; Link: PLabRADTypeTreeNode; Index: integer): integer;

   public
    constructor Create; reintroduce; overload;
    constructor Create(Prototype: TLabRADTypeTree); reintroduce; overload;
    constructor Create(const TypeTag: string); reintroduce; overload;
    destructor Destroy; override;

    procedure Clear;

    function AddNode(Link: PLabRADTypeTreeNode; Position: TLabRADNodePos; NodeType: TLabRADNodeType; const Units: string): PLabRADTypeTreeNode; overload;
    function AddNode(Link: PLabRADTypeTreeNode; Position: TLabRADNodePos; NodeType: TLabRADNodeType; Dimensions: Integer = -1): PLabRADTypeTreeNode; overload;

    function TypeTag(Node: PLabRADTypeTreeNode): string; overload;
    function TypeTag: string; overload;

    function Match(Candidate:           TLabRADTypeTree): TLabRADTypeTree; overload;
    function Match(Candidates: array of TLabRADTypeTree): TLabRADTypeTree; overload;

    property TopNode: PLabRADTypeTreeNode read fTopNode;
  end;

 const
  LabRADNodeTypeName: array[ntEmpty..ntArray] of string = ('Empty', 'Anything', 'Boolean', 'Integer', 'Word', 'String',
                                                           'Value', 'Complex Value', 'Timestamp', 'Cluster', 'Array');

implementation

uses
  SysUtils, LabRADExceptions;

constructor TLabRADTypeTree.Create;
begin
  // Create empty type tree
  inherited;
  fTopNode:=nil;
end;

constructor TLabRADTypeTree.Create(Prototype: TLabRADTypeTree);
begin
  // Create copy of given prototype tree
  inherited Create;
  if not assigned(Prototype) or not assigned(Prototype.TopNode) then begin
    fTopNode:=nil;
    exit;
  end;
  fTopNode:=DupNode(ProtoType.TopNode);
end;

constructor TLabRADTypeTree.Create(const TypeTag: string);
var Index:   integer;
    Payload: PLabRADTypeTreeNode;
    Node:    PLabRADTypeTreeNode;
    First:   boolean;
begin
  inherited Create;
  fTopNode:=nil;
  Index:=1;
  if TypeTag='' then begin
    AddNode(nil, npBelow, ntEmpty);
    exit;
  end;
  // Are we dealing with an error cluster?
  if TypeTag[1]='E' then begin
    // Parse out payload
    Index:=Parse(TypeTag, nil, 2);
    if not (Index>length(TypeTag)) then
      raise ELabRADTypeTagError.Create(TypeTag, 'Error tags must be of the form "E" or "E?"', Index);
    Payload:=fTopNode;
    fTopNode:=nil;
    // Create an (is) or (is(?)) structure
    AddNode(nil, npBelow, ntCluster);
    AddNode(fTopNode, npBelow, ntInteger);
    AddNode(fTopNode, npBelow, ntString);
    // Check if there was a payload
    if assigned(Payload) then begin
      // Add a placeholder node
      Node:=AddNode(fTopNode, npBelow, ntAnything);
      // Copy the payload into it
      Node^:=Payload^;
      Node.Up:=fTopNode;
      // Toss the old version
      dispose(Payload);
    end;
   end else begin
    // Keep parsing while there is stuff left in the type tag
    First:=True;
    while Index<=length(TypeTag) do begin
      // Did we find more than one thing?
      if assigned(fTopNode) and First then begin
        // If so, build a cluster around it
        Node:=NewNode(ntCluster, 1);
        Node.Down:=fTopNode;
        Node.DataSize:=fTopNode.DataSize;
        fTopNode.Up:=Node;
        fTopNode:=Node;
        // Only do this once, though
        First:=false;
      end;
      // Parse some more
      Index:=Parse(TypeTag, fTopNode, Index);
    end;  
  end;
end;

destructor TLabRADTypeTree.Destroy;
begin
  // Tear down tree
  Clear;
  // Free ourselves
  inherited;
end;

procedure TLabRADTypeTree.Clear;
var Node: PLabRADTypeTreeNode;
begin
  // Start at the top to tear down tree
  Node:=fTopNode;
  while assigned(Node) do begin
    if assigned(Node.Down) then begin
      // If the current node has nodes below it, tear them down first
      fTopNode:=Node.Down;
      Node.Down:=nil;
     end else begin
      // The current node does not have nodes below it, ...
      if assigned(Node.Right) and (Node.Right<>Node) then begin
        // ... but nodes to the right, so tear it down and walk right
        fTopNode:=Node.Right;
       end else begin
        // ... and no nodes to the right, so tear it down and walk back up
        fTopNode:=Node.Up;
      end;
      dispose(Node);
    end;
    Node:=fTopNode;
  end;
end;

function TLabRADTypeTree.NewNode(NodeType: TLabRADNodeType; Dimensions: Integer): PLabRADTypeTreeNode;
const Sizes: array[ntEmpty..ntArray] of integer = (0,0,1,4,4,4,8,16,16,0,4);
begin
  // Create a new empty node and fill in (default) values
  new(Result);
  Result.NodeType  :=NodeType;
  Result.Dimensions:=Dimensions;
  Result.HasUnits  :=False;
  Result.DataSize  :=Sizes[NodeType];
  Result.Units     :='';
  Result.Up        :=nil;
  Result.Right     :=nil;
  Result.Down      :=nil;
  Result.NeedsAttn :=False;
  Result.UConverter.Factor:=1;
  Result.UConverter.ToSI.Factor:=1;
  Result.UConverter.ToSI.Converter:=nil;
  Result.UConverter.FromSI.Factor:=1;
  Result.UConverter.FromSI.Converter:=nil;
end;

function TLabRADTypeTree.NewNode(Prototype: PLabRADTypeTreeNode): PLabRADTypeTreeNode;
begin
  // Create a new empty node and copy its values from the prototype node
  new(Result);
  Result.NodeType  :=Prototype.NodeType;
  Result.Dimensions:=Prototype.Dimensions;
  Result.HasUnits  :=Prototype.HasUnits;
  Result.DataSize  :=Prototype.DataSize;
  Result.Units     :=Prototype.Units;
  Result.Up        :=nil;
  Result.Right     :=nil;
  Result.Down      :=nil;
  Result.NeedsAttn :=Prototype.NeedsAttn;
  Result.UConverter:=Prototype.UConverter;
end;

function TLabRADTypeTree.DupNode(Prototype: PLabRADTypeTreeNode): PLabRADTypeTreeNode;
var Mine, Theirs: PLabRADTypeTreeNode;
begin
  // Create top node
  Theirs:=ProtoType;
  Mine:=NewNode(Theirs);
  Result:=Mine;
  // Run depth-first through the prototype tree until we completed the copy
  while (Theirs<>Prototype.Up) and ((Prototype=Prototype.Right) or (Theirs<>Prototype.Right)) do begin
    if assigned(Theirs.Down) and not assigned(Mine.Down) then begin
      // If there is a node below, duplicate and walk down
      Theirs:=Theirs.Down;
      Mine.Down:=NewNode(Theirs);
      Mine.Down.Up:=Mine;
      Mine:=Mine.Down;
     end else if assigned(Theirs.Right) and not assigned(Mine.Right) then begin
      // If there is a node to the right, check if it is a circular reference (array)
      if Theirs.Right=Theirs then begin
        // If so, create circular reference
        Mine.Right:=Mine;
       end else begin
        // If not, duplicate node and move right
        Theirs:=Theirs.Right;
        Mine.Right:=NewNode(Theirs);
        Mine.Right.Up:=Mine.Up;
        Mine:=Mine.Right;
      end;
     end else begin
      // If there are no more nodes missing below or to the right, move back up
      Mine:=Mine.Up;
      Theirs:=Theirs.Up;
    end;
  end;
end;

function TLabRADTypeTree.AddNode(Link: PLabRADTypeTreeNode; Position: TLabRADNodePos; NodeType: TLabRADNodeType; Dimensions: Integer = -1): PLabRADTypeTreeNode;
begin
  Result:=nil;

  // If no dimensions are given, use 0 for non-containers and 1 for containers
  if Dimensions=-1 then begin
    if NodeType in [ntArray, ntCluster] then Dimensions:=1
                                        else Dimensions:=0;
  end;

  // Verify that arrays have at least 1 dimension, clusters have exactly 1 and all others 0
  case NodeType of
    ntArray:   if Dimensions<1  then exit;
    ntCluster: if Dimensions<>1 then exit;
   else
    if Dimensions<>0 then exit;
  end;

  // If no link is given, we are creating the tree from scratch
  if not assigned(Link) then begin
    // If there already is a tree, fail
    if assigned(fTopNode) then exit;
    // Otherwise, this node will be the tree
    Result:=NewNode(NodeType, Dimensions);
    fTopNode:=Result;
    exit;
  end;

  if Position = npBelow then begin
    // We can only add nodes below clusters or arrays
    if not (Link.NodeType in [ntCluster, ntArray]) then exit;
    // Check if there are already nodes below the link
    if assigned(Link.Down) then begin
      // For an array, there can only be one node below
      if Link.NodeType=ntArray then exit;
      // Walk down and all the way to the right
      Link:=Link.Down;
      while assigned(Link.Right) do Link:=Link.Right;
      // New insert position is to the right!
      Position:=npRight;
     end else begin
      // We are the first below the link, insert
      Result:=NewNode(NodeType, Dimensions);
      Result.Up:=Link;
      if Link.NodeType=ntArray then Result.Right:=Result;
      Link.Down:=Result;
    end;
  end;

  if Position = npRight then begin
    // We can't add a second node below an array or if we aren't below another node
    if (Link.Right=Link) or not assigned(Link.Up) then exit;
    // Insert node
    Result:=NewNode(NodeType, Dimensions);
    Result.Up:=Link.Up;
    Result.Right:=Link.Right;
    Link.Right:=Result;
  end;

  if not assigned(Result) then exit;
  // Adjust element size for containing clusters
  Link:=Result.Up;
  while assigned(Link) and (Link.NodeType=ntCluster) do begin
    Link.DataSize:=Link.DataSize+Result.DataSize;
    Link:=Link.Up;
  end;  
end;

function TLabRADTypeTree.AddNode(Link: PLabRADTypeTreeNode; Position: TLabRADNodePos; NodeType: TLabRADNodeType; const Units: string): PLabRADTypeTreeNode;
begin
  if NodeType in [ntValue, ntComplex] then begin
    // Add a unit-less node in the desired spot
    Result:=AddNode(Link, Position, NodeType);
    // Quit if that failed
    if not assigned(Result) then exit;
    // Otherwise add units
    Result.HasUnits:=True;
    Result.Units:=Units;
   end else begin
    // Only values and complex values can have units
    Result:=nil;
  end;
end;

function TLabRADTypeTree.TypeTag(Node: PLabRADTypeTreeNode): string;
const TypeTags: array[ntEmpty..ntArray] of Char = '_?biwsvct(*';
begin