////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// tgrng: Tag Range routines.                                                 //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20260729 - Created by A.K.                                                 //
////////////////////////////////////////////////////////////////////////////////

unit _crw_tgrng; // "Identify range" routines.

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math, graphics,
 _crw_alloc, _crw_fpu, _crw_ef, _crw_str, _crw_ee,
 _crw_colors, _crw_dbglog;

////////////////////////////////////////////////////////////////////////////////
// The Tag Range Index/Color Model support.
// Color model corresponds to CIE 1931 standard with some modifications:
// uses named color and sometimes more "light" (with some white component)
// to use all colors as background for black text.
////////////////////////////////////////////////////////////////////////////////

const
 tgrng_L4 = -4; // Lo Fatal      MediumPurple    Аварийное понижение
 tgrng_L3 = -3; // Lo Error      SteelBlue       Критичное понижение
 tgrng_L2 = -2; // Lo Alarm      CornflowerBlue  Тревожное понижение
 tgrng_L1 = -1; // Lo Warn       Aqua=Cyan       Заметное  понижение
 tgrng_M0 =  0; // Middle/Normal Lime            Среднее/Нормальное
 tgrng_H1 = +1; // Hi Warn       Yellow          Заметное  превышение
 tgrng_H2 = +2; // Hi Alarm      DarkOrange      Тревожное превышение
 tgrng_H3 = +3; // Hi Error      Tomato          Критичное превышение
 tgrng_H4 = +4; // Hi Fatal      Red             Аварийное превышение

const
 DefaultTagRangeColorsAsText = 'MediumPurple'   +EOL  // L4
                              +'SteelBlue'      +EOL  // L3
                              +'CornflowerBlue' +EOL  // L2
                              +'Cyan'           +EOL  // L1
                              +'Lime'           +EOL  // M0
                              +'Yellow'         +EOL  // H1
                              +'DarkOrange'     +EOL  // H2
                              +'Tomato'         +EOL  // H3
                              +'Red'            +EOL; // H4

type
 TTagRangeIndex = tgrng_L4..tgrng_H4;
 TTagRangeEdges = packed array[TTagRangeIndex] of Double;
 TTagRangeColors = packed array[TTagRangeIndex] of TColor;

type
 TTagRange = class(TMasterObject)
 private
  myEdges:TTagRangeEdges;
  myColors:TTagRangeColors;
  function  GetEdges:TTagRangeEdges;
  procedure SetEdges(const X:TTagRangeEdges);
  function  GetEdge(i:Integer):Double;
  procedure SetEdge(i:Integer; const X:Double);
  function  GetColors:TTagRangeColors;
  procedure SetColors(const P:TTagRangeColors);
  function  GetColorsAsText:LongString;
  procedure SetColorsAsText(const P:LongString);
  function  GetL4:Double;
  procedure SetL4(const X:Double);
  function  GetL3:Double;
  procedure SetL3(const X:Double);
  function  GetL2:Double;
  procedure SetL2(const X:Double);
  function  GetL1:Double;
  procedure SetL1(const X:Double);
  function  GetM0:Double;
  procedure SetM0(const X:Double);
  function  GetH1:Double;
  procedure SetH1(const X:Double);
  function  GetH2:Double;
  procedure SetH2(const X:Double);
  function  GetH3:Double;
  procedure SetH3(const X:Double);
  function  GetH4:Double;
  procedure SetH4(const X:Double);
 public
  constructor Create;
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  property  Edge[i:Integer]:Double  read GetEdge         write SetEdge; default;
  property  Edges:TTagRangeEdges    read GetEdges        write SetEdges;
  property  Colors:TTagRangeColors  read GetColors       write SetColors;
  property  ColorsAsText:LongString read GetColorsAsText write SetColorsAsText;
  property  L4:Double               read GetL4           write SetL4;
  property  L3:Double               read GetL3           write SetL3;
  property  L2:Double               read GetL2           write SetL2;
  property  L1:Double               read GetL1           write SetL1;
  property  M0:Double               read GetM0           write SetM0;
  property  H1:Double               read GetH1           write SetH1;
  property  H2:Double               read GetH2           write SetH2;
  property  H3:Double               read GetH3           write SetH3;
  property  H4:Double               read GetH4           write SetH4;
 public
  function  ValidRanges:Boolean;
  function  RangeIndex(const X:Double):Integer;
  function  RangeColor(const X:Double; Def:TColor=clNone):TColor;
  function  AssignFromString(const args:LongString):Boolean;
  function  IndexToColor(i:Integer):TColor;
 private
  class var DefColors:TTagRangeColors;
 public
  class function  DefIndexToColor(i:Integer):TColor;
  class function  DefaultEdges:TTagRangeEdges;
  class function  DefaultColors:TTagRangeColors;
  class procedure ResetEdges(out aEdges:TTagRangeEdges);
  class function  ValidEdges(const aEdges:TTagRangeEdges):Boolean;
  class function  EdgesToExpress(const R:TTagRangeEdges):LongString;
  class function  EdgesToCookies(const R:TTagRangeEdges):LongString;
  class function  StringToEdges(const args:LongString):TTagRangeEdges;
  class function  ResetDefaultColors(Pal:LongString=''):Boolean;
  class function  ResetColors(out P:TTagRangeColors; Pal:LongString=''):Boolean;
  class function  ColorsToString(const P:TTagRangeColors; Sep:LongString=''):LongString;
  class function  ValidColors(const aColors:TTagRangeColors):Boolean; overload;
  class function  ValidColors(const aColors:LongString):Boolean; overload;
  class function  ValidColor(C:LongString):Boolean; overload;
  class function  ValidColor(C:TColor):Boolean; overload;
 end;

 {
 expr:='(L4=0)+(L3=5)+(L2=10)+(L1=15)+(M0=20)+(H1=60)+(H2=70)+(H3=90)+(H4=100)';
 expr:='L4=0|L3=5|L2=10|L1=15|M0=20|H1=60|H2=70|H3=90|H4=100';
 expr:='L4=0;L3=5;L2=10;L1=15;M0=20;H1=60;H2=70;H3=90;H4=100';
 tr:=NewTagRange(expr);
 }
function NewTagRange(const args:LongString=''):TTagRange;

procedure Kill(var TheObject:TTagRange); overload;

function dlc_TagRangeLog:Integer;
function dlc_TagRangeBug:Integer;

implementation

//////////////////
// Logger routines
//////////////////

function dlc_TagRangeLog:Integer;
const dlc:Integer=0;
begin
 if (dlc=0) then dlc:=RegisterDebugLogChannel('_TagRangeLog');
 Result:=dlc;
end;

function dlc_TagRangeBug:Integer;
const dlc:Integer=0;
begin
 if (dlc=0) then dlc:=RegisterDebugLogChannel('_TagRangeBug');
 Result:=dlc;
end;

////////////////////
// Service routines.
////////////////////

function IsNotNan(const x:Double):Boolean; inline;
begin
 Result:=not Math.IsNan(x);
end;

procedure Kill(var TheObject:TTagRange);
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end;
end;

function NewTagRange(const args:LongString=''):TTagRange;
begin
 Result:=nil;
 try
  Result:=TTagRange.Create;
  if IsNonEmptyStr(args) then begin
   if not Result.AssignFromString(args)
   then Kill(Result);
  end;
 except
  on E:Exception do BugReport(E,nil,'NewTagRange');
 end;
end;

///////////////////////////
// TTagRange implementation
///////////////////////////

constructor TTagRange.Create;
begin
 inherited Create;
end;

destructor TTagRange.Destroy;
begin
 inherited Destroy;
end;

procedure TTagRange.AfterConstruction;
begin
 inherited AfterConstruction;
 ResetColors(myColors);
 ResetEdges(myEdges);
end;

procedure TTagRange.BeforeDestruction;
begin
 inherited BeforeDestruction;
end;

function TTagRange.ValidRanges:Boolean;
begin
 if Assigned(Self)
 then Result:=ValidEdges(myEdges)
 else Result:=False;
end;

function TTagRange.RangeIndex(const X:Double):Integer;
begin
 Result:=tgrng_M0;
 if IsNan(X) then Exit;
 if not Assigned(Self) then Exit;
 if IsNotNan(myEdges[tgrng_H4]) and (X>=myEdges[tgrng_H4]) then Exit(tgrng_H4);
 if IsNotNan(myEdges[tgrng_H3]) and (X>=myEdges[tgrng_H3]) then Exit(tgrng_H3);
 if IsNotNan(myEdges[tgrng_H2]) and (X>=myEdges[tgrng_H2]) then Exit(tgrng_H2);
 if IsNotNan(myEdges[tgrng_H1]) and (X>=myEdges[tgrng_H1]) then Exit(tgrng_H1);
 if IsNotNan(myEdges[tgrng_L4]) and (X<=myEdges[tgrng_L4]) then Exit(tgrng_L4);
 if IsNotNan(myEdges[tgrng_L3]) and (X<=myEdges[tgrng_L3]) then Exit(tgrng_L3);
 if IsNotNan(myEdges[tgrng_L2]) and (X<=myEdges[tgrng_L2]) then Exit(tgrng_L2);
 if IsNotNan(myEdges[tgrng_L1]) and (X<=myEdges[tgrng_L1]) then Exit(tgrng_L1);
end;

function TTagRange.RangeColor(const X:Double; Def:TColor=clNone):TColor;
begin
 if Assigned(Self)
 then Result:=IndexToColor(RangeIndex(X))
 else Result:=Def;
end;

function  TTagRange.GetColors:TTagRangeColors;
begin
 if Assigned(Self)
 then Result:=myColors
 else Result:=TTagRange.DefaultColors;
end;

procedure TTagRange.SetColors(const P:TTagRangeColors);
begin
 if Assigned(Self)
 then myColors:=P;
end;

function  TTagRange.GetColorsAsText:LongString;
begin
 if Assigned(Self)
 then Result:=ColorsToString(myColors,',')
 else Result:='';
end;

procedure TTagRange.SetColorsAsText(const P:LongString);
begin
 if Assigned(Self)
 then ResetColors(myColors,P);
end;

function TTagRange.GetEdges:TTagRangeEdges;
begin
 if Assigned(Self)
 then Result:=myEdges
 else TTagRange.ResetEdges(Result);
end;

procedure TTagRange.SetEdges(const X:TTagRangeEdges);
begin
 if Assigned(Self)
 then myEdges:=X;
end;

function TTagRange.GetEdge(i:Integer):Double;
begin
 if Assigned(Self) and InRange(i,Low(myEdges),High(myEdges))
 then Result:=myEdges[i]
 else Result:=_Nan;
end;

procedure TTagRange.SetEdge(i:Integer; const X:Double);
begin
 if Assigned(Self) and InRange(i,Low(myEdges),High(myEdges))
 then myEdges[i]:=X;
end;

function TTagRange.GetL4:Double;
begin
 if Assigned(Self)
 then Result:=myEdges[tgrng_L4]
 else Result:=_Nan;
end;

procedure TTagRange.SetL4(const X:Double);
begin
 if Assigned(Self)
 then myEdges[tgrng_L4]:=X;
end;

function TTagRange.GetL3:Double;
begin
 if Assigned(Self)
 then Result:=myEdges[tgrng_L3]
 else Result:=_Nan;
end;

procedure TTagRange.SetL3(const X:Double);
begin
 if Assigned(Self)
 then myEdges[tgrng_L3]:=X;
end;

function TTagRange.GetL2:Double;
begin
 if Assigned(Self)
 then Result:=myEdges[tgrng_L2]
 else Result:=_Nan;
end;

procedure TTagRange.SetL2(const X:Double);
begin
 if Assigned(Self)
 then myEdges[tgrng_L2]:=X;
end;

function TTagRange.GetL1:Double;
begin
 if Assigned(Self)
 then Result:=myEdges[tgrng_L1]
 else Result:=_Nan;
end;

procedure TTagRange.SetL1(const X:Double);
begin
 if Assigned(Self)
 then myEdges[tgrng_L1]:=X;
end;

function TTagRange.GetM0:Double;
begin
 if Assigned(Self)
 then Result:=myEdges[tgrng_M0]
 else Result:=_Nan;
end;

procedure TTagRange.SetM0(const X:Double);
begin
 if Assigned(Self)
 then myEdges[tgrng_M0]:=X;
end;

function TTagRange.GetH1:Double;
begin
 if Assigned(Self)
 then Result:=myEdges[tgrng_H1]
 else Result:=_Nan;
end;

procedure TTagRange.SetH1(const X:Double);
begin
 if Assigned(Self)
 then myEdges[tgrng_H1]:=X;
end;

function TTagRange.GetH2:Double;
begin
 if Assigned(Self)
 then Result:=myEdges[tgrng_H2]
 else Result:=_Nan;
end;

procedure TTagRange.SetH2(const X:Double);
begin
 if Assigned(Self)
 then myEdges[tgrng_H2]:=X;
end;

function TTagRange.GetH3:Double;
begin
 if Assigned(Self)
 then Result:=myEdges[tgrng_H3]
 else Result:=_Nan;
end;

procedure TTagRange.SetH3(const X:Double);
begin
 if Assigned(Self)
 then myEdges[tgrng_H3]:=X;
end;

function TTagRange.GetH4:Double;
begin
 if Assigned(Self)
 then Result:=myEdges[tgrng_H4]
 else Result:=_Nan;
end;

procedure TTagRange.SetH4(const X:Double);
begin
 if Assigned(Self)
 then myEdges[tgrng_H4]:=X;
end;

class function TTagRange.ResetColors(out P:TTagRangeColors; Pal:LongString=''):Boolean;
var i,n,ner:Integer; cn:LongString; cl:TColor;
begin
 Result:=False;
 if (Pal='') and (@P<>@DefColors) and ValidColors(DefColors) then begin
  P:=DefColors;
  Exit(True);
 end;
 n:=1; cn:=''; cl:=0; ner:=0;
 P:=Default(TTagRangeColors);
 Pal:=TrimDef(Pal,DefaultTagRangeColorsAsText);
 for i:=Low(P) to High(P) do begin
  cn:=ExtractWord(n,Pal,ScanSpaces);
  cl:=StringToColor(cn,clNone);
  if (cl=clNone) then Inc(ner);
  P[i]:=cl;
  Inc(n);
 end;
 Result:=(ner=0);
end;

class function TTagRange.ResetDefaultColors(Pal:LongString=''):Boolean;
var P:TTagRangeColors;
begin
 Result:=False;
 if ResetColors(P,Pal) then begin
  DefColors:=P;
  Result:=True;
 end;
end;

function TTagRange.IndexToColor(i:Integer):TColor;
var il,ih:Integer;
begin
 Result:=clNone;
 if Assigned(Self) then begin
  il:=Low(TTagRangeIndex);
  ih:=High(TTagRangeIndex);
  i:=EnsureRange(i,il,ih);
  Result:=myColors[i];
 end;
end;

class function TTagRange.DefIndexToColor(i:Integer):TColor;
var il,ih:Integer;
begin
 Result:=clNone;
 il:=Low(TTagRangeIndex);
 ih:=High(TTagRangeIndex);
 i:=EnsureRange(i,il,ih);
 if not ValidColors(DefColors)
 then ResetColors(DefColors);
 Result:=DefColors[i];
end;

class function TTagRange.DefaultColors:TTagRangeColors;
begin
 if not ValidColors(DefColors)
 then ResetColors(DefColors);
 Result:=DefColors;
end;

class function TTagRange.DefaultEdges:TTagRangeEdges;
begin
 ResetEdges(Result);
end;

class procedure TTagRange.ResetEdges(out aEdges:TTagRangeEdges);
var i:Integer;
begin
 aEdges:=Default(TTagRangeEdges);
 for i:=Low(aEdges) to High(aEdges) do begin
  //aEdges[i]:=Sign(i)*HugeRealValue;
  aEdges[i]:=_Nan;
 end;
end;

class function TTagRange.ValidEdges(const aEdges:TTagRangeEdges):Boolean;
var i:Integer; a,b,x:Double;
begin
 Result:=False; a:=_Nan; b:=_Nan;
 for i:=Low(aEdges) to High(aEdges) do begin
  x:=aEdges[i]; if IsNotNan(x) then b:=x;
  if IsNotNan(a) and IsNotNan(b) and (a>b) then Exit;
  if IsNotNan(b) then a:=b;
 end;
 Result:=True;
end;

class function TTagRange.EdgesToExpress(const R:TTagRangeEdges):LongString;
begin
 Result:=Format('(L4=%g)+(L3=%g)+(L2=%g)+(L1=%g)+(M0=%g)+'
               +'(H1=%g)+(H2=%g)+(H3=%g)+(H4=%g)',
         [R[tgrng_L4],R[tgrng_L3],R[tgrng_L2],R[tgrng_L1],R[tgrng_M0],
          R[tgrng_H1],R[tgrng_H2],R[tgrng_H3],R[tgrng_H4]]);
end;

class function TTagRange.EdgesToCookies(const R:TTagRangeEdges):LongString;
begin
 Result:=Format('L4=%g;L3=%g;L2=%g;L1=%g;M0=%g;H1=%g;H2=%g;H3=%g;H4=%g',
         [R[tgrng_L4],R[tgrng_L3],R[tgrng_L2],R[tgrng_L1],R[tgrng_M0],
          R[tgrng_H1],R[tgrng_H2],R[tgrng_H3],R[tgrng_H4]]);
end;

class function TTagRange.StringToEdges(const args:LongString):TTagRangeEdges;
var R:TTagRangeEdges; ee:TExpressionEvaluator; ec:Integer; x:Double;
var arg:LongString;
begin
 ResetEdges(Result);
 try
  ResetEdges(R);
  arg:=Trim(args); x:=0; ec:=0;
  if (Pos('|',arg)>0) then arg:=StringReplace(arg,'|',';',[rfReplaceAll]);
  if HasChars(arg,';'+EOL) and HasChars(arg,'=') and not HasChars(arg,'()') then begin
   if Str2Real(CookieScan(arg,'L4',Ord(';')),x) then R[tgrng_L4]:=x;
   if Str2Real(CookieScan(arg,'L3',Ord(';')),x) then R[tgrng_L3]:=x;
   if Str2Real(CookieScan(arg,'L2',Ord(';')),x) then R[tgrng_L2]:=x;
   if Str2Real(CookieScan(arg,'L1',Ord(';')),x) then R[tgrng_L1]:=x;
   if Str2Real(CookieScan(arg,'M0',Ord(';')),x) then R[tgrng_M0]:=x;
   if Str2Real(CookieScan(arg,'H1',Ord(';')),x) then R[tgrng_H1]:=x;
   if Str2Real(CookieScan(arg,'H2',Ord(';')),x) then R[tgrng_H2]:=x;
   if Str2Real(CookieScan(arg,'H3',Ord(';')),x) then R[tgrng_H3]:=x;
   if Str2Real(CookieScan(arg,'H4',Ord(';')),x) then R[tgrng_H4]:=x;
  end else begin
   ee:=NewExpressionEvaluator;
   if Assigned(ee) then
   try
    ec:=ee.EvaluateExpression(PChar(arg));
    if (ec=ee_Ok) then begin
     if ee.GetValue('L4',x) then R[tgrng_L4]:=x;
     if ee.GetValue('L3',x) then R[tgrng_L3]:=x;
     if ee.GetValue('L2',x) then R[tgrng_L2]:=x;
     if ee.GetValue('L1',x) then R[tgrng_L1]:=x;
     if ee.GetValue('M0',x) then R[tgrng_M0]:=x;
     if ee.GetValue('H1',x) then R[tgrng_H1]:=x;
     if ee.GetValue('H2',x) then R[tgrng_H2]:=x;
     if ee.GetValue('H3',x) then R[tgrng_H3]:=x;
     if ee.GetValue('H4',x) then R[tgrng_H4]:=x;
    end else begin
     if DebugLogEnabled(dlc_TagRangeBug) then begin
      DebugLog(dlc_TagRangeBug,'Invalid Expression '+arg);
      DebugLog(dlc_TagRangeBug,'Error '+IntToStr(ec)+', '
                              +QArg(ee_ErrorMessage(ec))
                              +' at Pos '+IntToStr(ee.ErrorPos)
                              +' in token '+QArg(StrPas(ee.ErrorToken)));
     end;
    end;
   finally
    Kill(ee);
   end;
  end;
  if ValidEdges(R) then Result:=R;
 except
  on E:Exception do BugReport(E,nil,'StringToEdges');
 end;
end;

class function TTagRange.ColorsToString(const P:TTagRangeColors; Sep:LongString=''):LongString;
var i:Integer;
begin
 Result:='';
 for i:=Low(P) to High(P) do begin
  Result+=(ColorToString(P[i])+EOL);
 end;
 if (Result<>'') and (Sep<>'') and (Sep<>EOL)
 then Result:=StringReplace(Trim(Result),EOL,Sep,[rfReplaceAll]);
end;

function TTagRange.AssignFromString(const args:LongString):Boolean;
var R:TTagRangeEdges;
begin
 Result:=False;
 if Assigned(Self) then
 try
  R:=StringToEdges(args);
  if ValidEdges(R) then begin
   Result:=True;
   Edges:=R;
  end;
  if Result then begin
   if DebugLogEnabled(dlc_TagRangeLog) then begin
    DebugLog(dlc_TagRangeLog,'Valid SetTagRange '+args);
   end;
  end else begin
   if DebugLogEnabled(dlc_TagRangeBug) then begin
    DebugLog(dlc_TagRangeBug,'Invalid SetTagRange '+args);
   end;
  end;
 except
  on E:Exception do BugReport(E,Self,'AssignFromString');
 end;
end;

class function TTagRange.ValidColor(C:TColor):Boolean;
begin
 if (C=clNone)  then Exit(False);
 if (C=clBlack) then Exit(False);
 Result:=True;
end;

class function TTagRange.ValidColor(C:LongString):Boolean;
begin
 if not ValidColor(StringToColor(C,clNone)) then Exit(False);
 Result:=True;
end;

class function TTagRange.ValidColors(const aColors:TTagRangeColors):Boolean;
var i:Integer;
begin
 for i:=Low(aColors) to High(aColors) do
 if not ValidColor(aColors[i]) then Exit(False);
 Result:=True;
end;

class function TTagRange.ValidColors(const aColors:LongString):Boolean;
var C:TTagRangeColors;
begin
 if not ResetColors(C,aColors) then Exit(False);
 if not ValidColors(C) then Exit(False);
 Result:=True;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_tgrng;
begin
 dlc_TagRangeLog;
 dlc_TagRangeBug;
end;

procedure Free_crw_tgrng;
begin
end;

initialization

 Init_crw_tgrng;

finalization

 Free_crw_tgrng;

end.

//////////////
// END OF FILE
//////////////

