labradtypetree.pas

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

  // If there is no node, the type tag is empty
  if not assigned(Node) then begin
    Result:='';
    exit;
  end;
  // Read type tag from constant list above
  Result:=TypeTags[Node.NodeType];
  // Add units, if needed
  if Node.HasUnits then Result:=Result+'['+Node.Units+']';
  if Node.NodeType=ntArray then begin
    // For arrays, add the dimensionality and the type tag of the element
    Result:=TypeTag(Node.Down);
    if Result='' then Result:='_';
    if Node.Dimensions<>1 then Result:='*'+inttostr(Node.Dimensions)+Result
                          else Result:='*'+Result;
  end;
  if Node.NodeType=ntCluster then begin
    // For clusters, add the type tags of the elements
    Node:=Node.Down;
    while assigned(Node) do begin
      Result:=Result+TypeTag(Node);
      Node:=Node.Right;
    end;
    Result:=Result+')';
  end;
end;

function TLabRADTypeTree.TypeTag: string;
begin
  // Type tag is simply the type tag of the top node
  Result:=TypeTag(fTopNode);
end;

function TLabRADTypeTree.Parse(const TypeTag: string; Link: PLabRADTypeTreeNode; Index: integer): integer;
const HCs: array[0..15] of Char = '0123456789ABCDEF';
var OldIndex:   integer;
    Units:      string;
    Dimensions: integer;
begin
  // Trim type tag
  while (Index<=length(TypeTag)) and (TypeTag[Index] in [' ',',',';',#9,'{']) do begin
    // Strip whitespace and commas
    while (Index<=length(TypeTag)) and (TypeTag[Index] in [' ',',',';',#9]) do inc(Index);
    // Strip comment
    if (Index<=length(TypeTag)) and (TypeTag[Index]='{') then begin
      inc(Index);
      while (Index<=length(TypeTag)) and (TypeTag[Index]<>'}') do inc(Index);
      if Index>length(TypeTag) then raise ELabRADTypeTagError.Create(TypeTag, 'Unterminated comment', Index);
      inc(Index);
    end;
  end;
  // Check if rest of type tag is a comment
  if (Index>length(TypeTag)) or (TypeTag[Index]=':') then Index:=length(TypeTag)+1;
  // If type tag is empty, make sure it's not inside a cluster
  if (Index>length(TypeTag)) or (TypeTag[Index]='_') then begin
    if assigned(Link) then begin
      if Link.NodeType=ntCluster then begin
        if Index>length(TypeTag) then raise ELabRADTypeTagError.Create(TypeTag, 'Unterminated cluster', Index);
        raise ELabRADTypeTagError.Create(TypeTag, 'Clusters must not be empty', Index);
      end;
      if Index>length(TypeTag) then raise ELabRADTypeTagError.Create(TypeTag, 'Empty arrays must be indicated by "_"', Index);
      AddNode(Link, npBelow, ntEmpty, 0);
     end else begin
      fTopNode:=NewNode(ntEmpty, 0);
    end;
    Result:=Index+1;
    exit;
  end;
  // Find node type in type tags constant above
  case TypeTag[Index] of
    '?': AddNode(Link, npBelow, ntAnything);
    'b': AddNode(Link, npBelow, ntBoolean);
    'i': AddNode(Link, npBelow, ntInteger);
    'w': AddNode(Link, npBelow, ntWord);
    's': AddNode(Link, npBelow, ntString);
    't': AddNode(Link, npBelow, ntTimestamp);
    'v','c': begin
               // Do we have units specified
               if (Index<length(TypeTag)) and (TypeTag[Index+1]='[') then begin
                 // Skip 'v[' or 'c['
                 inc(Index, 2);
                 OldIndex:=Index;
                 // Search for ']'
                 while (Index<=length(TypeTag)) and (TypeTag[Index]<>']') do inc(Index);
                 if Index>length(TypeTag) then raise ELabRADTypeTagError.Create(TypeTag, 'Unterminated units', Index);
                 // Copy unit string
                 setlength(Units, Index-OldIndex);
                 move(TypeTag[OldIndex], Units[1], Index-OldIndex);
                 if TypeTag[OldIndex-2]='v' then AddNode(Link, npBelow, ntValue, Units)
                                            else AddNode(Link, npBelow, ntComplex, Units);
                end else begin
                 if TypeTag[Index]='v' then AddNode(Link, npBelow, ntValue)
                                       else AddNode(Link, npBelow, ntComplex);
               end;
             end;
    '*': begin
           // Skip '*'
           inc(Index);
           // Do we have dimensions specified
           if (Index<=length(TypeTag)) and (TypeTag[Index] in ['0'..'9']) then begin
             // Read number of dimensions
             Dimensions:=0;
             while (Index<=length(TypeTag)) and (TypeTag[Index] in ['0'..'9']) do begin
               Dimensions:=Dimensions*10 + Ord(TypeTag[Index]) - Ord('0');
               inc(Index);
             end;
             // Make sure we have at least one dimension
             if Dimensions=0 then raise ELabRADTypeTagError.Create(TypeTag, 'Zero-dimensional arrays are not allowed', Index);
            end else begin
             Dimensions:=1;
           end;
           // Add array node
           Link:=AddNode(Link, npBelow, ntArray, Dimensions);
           // Add contents
           Index:=Parse(TypeTag, Link, Index)-1;
         end;
    '(': begin
           // Skip '('
           inc(Index);
           // Add cluster node
           Link:=AddNode(Link, npBelow, ntCluster);
           // Add elements until we find ')'
           repeat
             Index:=Parse(TypeTag, Link, Index);
           until (Index>length(TypeTag)) or (TypeTag[Index]=')');
           if Index>length(TypeTag) then raise ELabRADTypeTagError.Create(TypeTag, 'Unterminated cluster', Index);
         end;
   else
    // If we didn't recognize the type type tag, try to give an intelligent error message
    // End of a cluster?
    if (TypeTag[Index]=')') then begin
      // Empty cluster?
      if assigned(Link) and (Link.NodeType=ntCluster) and not assigned(Link.Down) then
        raise ELabRADTypeTagError.Create(TypeTag, 'Clusters must not be empty', Index);
      // Other cluster problem
      raise ELabRADTypeTagError.Create(TypeTag, '")" found without matching "("', Index);
    end;
    // Out of place units?
    if (TypeTag[Index]='[') then
      raise ELabRADTypeTagError.Create(TypeTag, 'Only (Complex) Values can have units; units must immediately follow type tag', Index);
    // Out of place end of units?
    if (TypeTag[Index]=']') then
      raise ELabRADTypeTagError.Create(TypeTag, '"]" found without matching "["', Index);
    // Out of place end of comment?
    if (TypeTag[Index]='}') then
      raise ELabRADTypeTagError.Create(TypeTag, '"}" found without matching "{"', Index);
    // Out of place numbers?
    if (TypeTag[Index] in ['0'..'9']) then
      raise ELabRADTypeTagError.Create(TypeTag, 'Array dimensions must immediately follow the type tag', Index);
    // Out of place error?
    if (TypeTag[Index]='E') then
      raise ELabRADTypeTagError.Create(TypeTag, 'Error tags must be the very first character of the type tag', Index);
    // All others
    if (TypeTag[Index] in [' '..#126]) then Units:='"'+TypeTag[Index]+'"'
                                       else Units:='0x'+HCs[ord(TypeTag[Index]) shr 4]+HCs[ord(TypeTag[Index]) and $F];
    raise ELabRADTypeTagError.Create(TypeTag, Units+' is not a recognized type tag', Index);
  end;
  inc(Index);
  // Trim type tag again
  while (Index<=length(TypeTag)) and (TypeTag[Index] in [' ',',',';',#9,'{']) do begin
    // Strip whitespace and commas
    while (Index<=length(TypeTag)) and (TypeTag[Index] in [' ',',',';',#9]) do inc(Index);
    // Strip comment
    if (Index<=length(TypeTag)) and (TypeTag[Index]='{') then begin
      inc(Index);
      while (Index<=length(TypeTag)) and (TypeTag[Index]<>'}') do inc(Index);
      if Index>length(TypeTag) then raise ELabRADTypeTagError.Create(TypeTag, 'Unterminated comment', Index);
      inc(Index);
    end;
  end;
  // Check if rest of type tag is a comment
  if (Index>length(TypeTag)) or (TypeTag[Index]=':') then Index:=length(TypeTag)+1;
  Result:=Index;
end;

function TLabRADTypeTree.Match(Candidates: array of TLabRADTypeTree): TLabRADTypeTree;
var cur: integer;
begin
  if not assigned(TopNode) then raise ELabRADTypeConversionError.Create('Invalid source type tag');
  case length(Candidates) of
   0: // No candidates means anything is ok. Return own type
    Result:=TLabRADTypeTree.Create(self);
   1: // Treat one only one candidate separately without catching errors
    Result:=Match(Candidates[0]);
   else
    cur:=0;
    Result:=nil;
    while (cur<length(Candidates)) and not assigned(Result) do begin
      try
        // Try to convert to candidate type and exit, if successful
        Result:=Match(Candidates[cur]);
        exit;
       except
      end;
      inc(cur);
    end;
    // If none of the conversions completed, raise exception
    if not assigned(Result) then
      raise ELabRADTypeConversionError.Create(''''+TypeTag+''' is not compatible with any of the accepted types');
  end;
end;

function TLabRADTypeTree.Match(Candidate: TLabRADTypeTree): TLabRADTypeTree;
var Mine, Theirs, Output: PLabRADTypeTreeNode;
    TIn, TOut:            string;
    UnitConversion:       TLabRADUnitConversion;
    AttNode:              PLabRADTypeTreeNode;
begin
  // Is one of the trees empty?
  if not assigned(TopNode) then
    raise ELabRADTypeConversionError.Create('Invalid source type tag');
  if not assigned(Candidate) or not assigned(Candidate.TopNode) then
    raise ELabRADTypeConversionError.Create('Invalid target type tag');
  TIn:=TypeTag;
  TOut:=Candidate.TypeTag;
  Mine:=TopNode;
  Theirs:=Candidate.TopNode;
  // Are the node types compatible?
  if (Mine.NodeType<>Theirs.NodeType) and
     (Mine.NodeType<>ntAnything)      and
     (Theirs.NodeType<>ntAnything) then
      raise ELabRADTypeConversionError.Create(TIn, TOut, Mine.NodeType, Theirs.NodeType);
  // Create most strongly typed node
  if Mine.NodeType=ntAnything then begin
    Result:=TLabRADTypeTree.Create(Candidate);
    exit;
  end;
  if Theirs.NodeType=ntAnything then begin
    Result:=TLabRADTypeTree.Create(self);
    exit;
  end;
  // Create tree
  Result:=TLabRADTypeTree.Create;
  try
    Output:=NewNode(Theirs);
    Result.fTopNode:=Output;
    if Mine.HasUnits then begin
      if Theirs.HasUnits then begin
        UnitConversion:=LabRADConvertUnits(Mine.Units, Theirs.Units);
        if UnitConversion.Factor<>1 then begin
          Output.NeedsAttn:=True;
          Output.UConverter:=UnitConversion;
        end;
       end else begin
        Output.HasUnits:=true;
        Output.Units:=Mine.Units;
      end;  
    end;
    // Run depth-first through both trees
    while assigned(Output) do begin
      // Check if links down and to the right are the same
      if ((  Mine.NodeType<>ntEmpty) and (  Mine.NodeType<>ntAnything) and
          (Theirs.NodeType<>ntEmpty) and (Theirs.NodeType<>ntAnything) and
          (assigned(Theirs.Down ) xor assigned(Mine.Down ))) or
          (assigned(Theirs.Right) xor assigned(Mine.Right))  or
          ((Theirs.Right=Theirs)  xor (Mine.Right=Mine)) then
          raise ELabRADTypeConversionError.Create(TIn, TOut, 'Element structure does not match');
      if assigned(Theirs.Down) and not assigned(Output.Down) then begin
        // If there is a node below, duplicate and walk down
        Mine:=Mine.Down;
        Theirs:=Theirs.Down;
        // Are the node types compatible?
        if (Mine.NodeType<>Theirs.NodeType) and
           (Mine.NodeType<>ntAnything)      and
           (Mine.NodeType<>ntEmpty)         and
           (Theirs.NodeType<>ntAnything)    and
           (Theirs.NodeType<>ntEmpty) then
            raise ELabRADTypeConversionError.Create(TIn, TOut, Mine.NodeType, Theirs.NodeType);
        // Create most strongly typed node
        if Mine.NodeType in [ntAnything, ntEmpty] then begin
          // If mine is not specified, copy their structure
          Output.Down:=DupNode(Theirs)
         end else if Theirs.NodeType in [ntAnything, ntEmpty] then begin
          // If theirs is not specified, copy my structure
          Output.Down:=DupNode(Mine);
         end else begin
          Output.Down:=NewNode(Theirs);
          if Mine.HasUnits then begin
            if Theirs.HasUnits then begin
              UnitConversion:=LabRADConvertUnits(Mine.Units, Theirs.Units);
              if UnitConversion.Factor<>1 then begin
                AttNode:=Output;
                while assigned(AttNode) and not(AttNode.NeedsAttn) do begin
                  AttNode.NeedsAttn:=True;
                  AttNode:=AttNode.Up;
                end;
                Output.Down.NeedsAttn:=True;
                Output.Down.UConverter:=UnitConversion;
              end;
             end else begin
              Output.Down.HasUnits:=true;
              Output.Down.Units:=Mine.Units;
            end;
          end;
        end;
        Output.Down.Up:=Output;
        Output:=Output.Down;
       end else if assigned(Theirs.Right) and not assigned(Output.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
          Output.Right:=Output;
         end else begin
          // If not, process right
          Mine:=Mine.Right;
          Theirs:=Theirs.Right;
          // Are the node types compatible?
          if (Mine.NodeType<>Theirs.NodeType) and
             (Mine.NodeType<>ntAnything)      and
             (Mine.NodeType<>ntEmpty)         and
             (Theirs.NodeType<>ntAnything)    and
             (Theirs.NodeType<>ntEmpty) then
              raise ELabRADTypeConversionError.Create(TIn, TOut, Mine.NodeType, Theirs.NodeType);
          // Create most strongly typed node
          if Mine.NodeType in [ntAnything, ntEmpty] then begin
            // If mine is not specified, copy their structure
            Output.Right:=DupNode(Theirs)
           end else if Theirs.NodeType in [ntAnything, ntEmpty] then begin
            // If theirs is not specified, copy my structure
            Output.Right:=DupNode(Mine);
           end else begin
            Output.Right:=NewNode(Theirs);
            if Mine.HasUnits then begin
              if Theirs.HasUnits then begin
                UnitConversion:=LabRADConvertUnits(Mine.Units, Theirs.Units);
                if UnitConversion.Factor<>1 then begin
                  AttNode:=Output;
                  while assigned(AttNode) and not(AttNode.NeedsAttn) do begin
                    AttNode.NeedsAttn:=True;
                    AttNode:=AttNode.Up;
                  end;
                  Output.Right.NeedsAttn:=True;
                  Output.Right.UConverter:=UnitConversion;
                end;
               end else begin
                Output.Right.HasUnits:=true;
                Output.Right.Units:=Mine.Units;
              end;
            end;
          end;
          Output.Right.Up:=Output.Up;
          Output:=Output.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;
        Output:=Output.Up;
      end;
    end;
   except
    // Free memory
    Result.Free;
    raise;
  end;
end;

end.