////////////////////////////////////////////////////////////////////////////////
// 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:                                                                   //
// Библиотека функций для поддержки термопарных таблиц и других таблиц        //
// зависимостией. Зависимости должны быть монотонными (это необходимо         //
// для обратимости) и заданными по возрастающей сетке x.                      //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20011225 - Creation (uses CRW16)                                           //
// 2001226  - Test ok.                                                        //
// 20230529 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_couple; // Thermocouples and relationships (using splines).

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math,
 _crw_alloc, _crw_fpu, _crw_zm, _crw_ef, _crw_spline,
 _crw_str, _crw_fio, _crw_dynar, _crw_plut;

 {
 *******************************************************************************
 Thermocouple и Relashionship реализуют табличные калибровки со сглаживающим
 сплайном, заданнные в конфигурационном файле. Поддерживаются прямые и обратные
 калибровки (например, перевод милливольт в градусы и градусов в милливольты).
 *******************************************************************************
 База данных описана в секции [DataBase] основного конфигфайла CRW32.INI.
 *******************************************************************************
 ThermoCoupleСount      Число проинициализированных термопар
 ThermoCoupleName       Имя термопары типа CoupleID
 ThermoCoupleRange      Диапазон термопары типа CoupleID
 ThermoCouple           Значение термопары типа CoupleID
                        при Inverted=false:
                         Argument=Температура(X) ThermoCouple=ТермоЭДС(Y)
                        при Inverted=true:
                         Argument=ТермоЭДС(Y)    ThermoCouple=Температура(X)
 FindThermoCouple       Найти термопару по имени
 InitCouples            Инициализация термопарных таблиц из основного ini-файла
 ReadThermoCoupleList   Чтение списка термопар
 *******************************************************************************
 Пример файла описания термопар:
 [ThermoCoupleList]
 ThermoCouple = HrAl
 ThermoCouple = HrCp
 [HrAl]
 FitMethod = Spline
 Smooth = 20
 Data Celsius     mV  RelErr
         -270 -6.458       1
         -269 -6.457       1
         -268 -6.456       1
 End Data
 [HrCp]
 FitMethod = Spline
 Smooth = 20
 Data Celsius     mV  RelErr
         -270 -6.458       1
         -269 -6.457       1
         -268 -6.456       1
 End Data
 *******************************************************************************
 }
function  ThermoCoupleCount:Integer;
function  ThermoCoupleName(CoupleID:Integer):LongString;
function  ThermoCoupleRange(CoupleID:Integer):TRect2D;
function  ThermoCouple(CoupleID:Integer; Argument:Double; Inverted:Boolean):Double;
function  FindThermoCouple(const CoupleName:LongString):Integer;
procedure InitCouples(const IniFile,Section,Name:LongString; DebugId:Integer=-1);
procedure ReadThermoCoupleList(const IniFile:LongString; DebugId:Integer=-1);

 {
 *******************************************************************************
 Cовершенно аналогично с зависимостями (Relationship).
 Отличаются в основном имена в конфигурационном файле.
 *******************************************************************************
 Пример файла описания зависимостей:
 [RelationshipList]
 Relationship = R1
 Relationship = R2
 [R1]
 FitMethod = Spline
 Smooth = 20
 Data       X      Y  RelErr
         -270 -6.458       1
         -269 -6.457       1
         -268 -6.456       1
 End Data
 [R2]
 FitMethod = Spline
 Smooth = 20
 Data       X      Y  RelErr
         -270 -6.458       1
         -269 -6.457       1
         -268 -6.456       1
 End Data
 *******************************************************************************
 }
function  RelationshipCount:Integer;
function  RelationshipName(RelationID:Integer):LongString;
function  RelationshipRange(RelationID:Integer):TRect2D;
function  Relationship(RelationID:Integer; Argument:Double; Inverted:Boolean):Double;
function  FindRelationship(const RelationName:LongString):Integer;
procedure InitRelationships(const IniFile,Section,Name:LongString; DebugId:Integer=-1);
procedure ReadRelationshipList(const IniFile:LongString; DebugId:Integer=-1);

implementation

const
 CoupleList   : TObjectStorage = nil; { Список термопар }
 RelationList : TObjectStorage = nil; { Список зависимостей }

 {
 Термопара описывается сплайном на интервале [ax,bx].
 За пределами интервала используется линейная экстраполяция.
 }
function ExpandSpline(ax,bx:Double; Spline:TReinschSpline; x:Double):Double;
begin
 Result:=0;
 if Spline.Ok then
 if x<ax then Result:=Spline.Get(ax)+(x-ax)*Spline.Get(ax,1) else
 if x>bx then Result:=Spline.Get(bx)+(x-bx)*Spline.Get(bx,1) else
 Result:=Spline.Get(x);
end;

 {
 Внутренняя функция для решения уравнения F(x)=Y при обращении таблицы.
 }
type
 TFRec=record
  S : TReinschSpline;
  Y : Double;
 end;

function F(x:Double; Custom:Pointer):Double;
begin
 with TFRec(Custom^) do Result:=S.Get(x)-Y;
end;

 {
 Функция x=InvertSpline(ax,bx,Spline,y) вычисляет решение x уравнения
  ExpandSpline(ax,bx,Spline,x)=y (см. ExpandSpline)
 Spline должен быть монотонным на [ax,bx].
 }
function InvertSpline(ax,bx:Double; Spline:TReinschSpline; y:Double):Double;
var ay,by:Double; FRec:TFRec;
begin
 Result:=0;
 if Spline.Ok then begin
  FRec.S:=Spline;
  FRec.Y:=y;
  ay:=Spline.Get(ax);
  by:=Spline.Get(bx);
  if ay<by then begin
   if y<ay then Result:=ax+(y-ay)/Spline.Get(ax,1) else
   if y>by then Result:=bx+(y-by)/Spline.Get(bx,1) else
   Result:=FindZero(F,ax,bx,MachEps*10,@FRec);
  end else begin
   if y<by then Result:=bx+(y-by)/Spline.Get(bx,1) else
   if y>ay then Result:=ax+(y-ay)/Spline.Get(ax,1) else
   Result:=FindZero(F,ax,bx,MachEps*10,@FRec);
  end;
 end;
end;

 {
 Тип описывает зависимость y(x)
 }
type
 TRelation=class(TMasterObject)
 private
  myName      : LongString;     {имя зависимости}
  myRange     : TRect2D;        {диапазоны}
  mySpline    : TReinschSpline; {сглаживающий сплайн ТермоЭДС(Температура)}
 protected
  function    CheckOk:Boolean; override;
  function    GetName:LongString;
  function    GetRange:TRect2D;
  function    GetSpline:TReinschSpline;
 public
  constructor Create(const IniFile,SectionName,xName,yName,wName:LongString);
  destructor  Destroy; override;
  function    Get(Argument:Double; Inverted:Boolean):Double;
 public
  property    Name   : LongString     read GetName;
  property    Range  : TRect2D        read GetRange;
  property    Spline : TReinschSpline read GetSpline;
 end;

function TRelation.CheckOk:Boolean;
begin
 Result:=mySpline.Ok and IsNonEmptyStr(myName);
end;

function TRelation.GetName:LongString;
begin
 if Assigned(Self) then Result:=myName else Result:='';
end;

function TRelation.GetRange:TRect2D;
begin
 if Assigned(Self) then Result:=myRange else Result:=Rect2D(0,0,0,0);
end;

function TRelation.GetSpline:TReinschSpline;
begin
 if Assigned(Self) then Result:=mySpline else Result:=nil;
end;

constructor TRelation.Create(const IniFile,SectionName,xName,yName,wName:LongString);
var x,y,w:PDoubleArray; Smooth,rx,ry,rw:Double; i,ix,iy,iw,NumPoints:Integer;
var s,aIniFile,Section:LongString; P:PChar;
label Ok,Fault;
 function CheckMem(var v:PDoubleArray; N:Integer):Boolean;
 begin
  if AllocSize(v)<(N+1)*sizeof(Double)
  then Result:=Reallocate(Pointer(v),AdjustBufferSize(N+1,4096)*sizeof(Double))
  else Result:=true;
 end;
begin
 inherited Create;
 myName:='';
 myRange:=Rect2D(0,0,1,1);
 mySpline:=nil;
 x:=nil;
 y:=nil;
 w:=nil;
 NumPoints:=0;
 Section:='';
 Smooth:=0; s:='';
 aIniFile:=UnifyFileAlias(IniFile);
 if not FileExists(aIniFile) then goto Fault;
 Section:=ExtractTextSection(aIniFile,SectionName,efConfig);
 if Section='' then goto Fault;
 if ScanVarDouble(svConfig,PChar(Section),'Smooth%f',Smooth)=nil then goto Fault;
 P:=StrPass(ScanVarString(svConfig,PChar(Section),'Data%s',s),[ASCII_CR,ASCII_LF]);
 if P=nil then goto Fault;
 ix:=0;
 iy:=0;
 iw:=0;
 for i:=1 to WordCount(s,[' ']) do begin
  if IsSameText(UnifyAlias(ExtractWord(i,s,[' '])),UnifyAlias(xName)) then ix:=i;
  if IsSameText(UnifyAlias(ExtractWord(i,s,[' '])),UnifyAlias(yName)) then iy:=i;
  if IsSameText(UnifyAlias(ExtractWord(i,s,[' '])),UnifyAlias(wName)) then iw:=i;
 end;
 if (ix<1) or (iy<1) then goto Fault;
 while P<>nil do begin
  P:=StrPass(ScanVarString(svAsIs,P,'%s',s),[ASCII_CR,ASCII_LF]);
  if P<>nil then begin
   if Pos('END DATA',UpcaseStr(s))>0 then break;
   rx:=0;
   ry:=0;
   rw:=1;
   if (ix>0) and not Str2Real(ExtractWord(ix,s,[' ']),rx) then continue;
   if (iy>0) and not Str2Real(ExtractWord(iy,s,[' ']),ry) then continue;
   if (iw>0) and not Str2Real(ExtractWord(iw,s,[' ']),rw) then continue;
   if not CheckMem(x,NumPoints) then goto Fault;
   if not CheckMem(y,NumPoints) then goto Fault;
   if not CheckMem(w,NumPoints) then goto Fault;
   x[NumPoints]:=rx;
   y[NumPoints]:=ry;
   w[NumPoints]:=rw*Smooth;
   inc(NumPoints);
  end;
 end;
 if NumPoints<3 then goto Fault;
 for i:=1 to NumPoints-1 do if x[i-1]>=x[i] then goto Fault;
 myName:=UpCaseStr(UnifyAlias(TrimChars(SectionName,['['],[']'])));
 mySpline:=NewReinschSpline(x^,y^,w^,NumPoints,2,0,2,0);
 if not mySpline.Ok then goto Fault;
 if mySpline.N<NumPoints then goto Fault;
 with myRange do begin
  a.x:=x[0];
  b.x:=x[NumPoints-1];
  a.y:=min(mySpline.Get(a.x),mySpline.Get(b.x));
  b.y:=max(mySpline.Get(a.x),mySpline.Get(b.x));
 end;
Ok:
 Deallocate(Pointer(x));
 Deallocate(Pointer(y));
 Deallocate(Pointer(w));
 Section:='';
 exit;
Fault:
 Deallocate(Pointer(x));
 Deallocate(Pointer(y));
 Deallocate(Pointer(w));
 Section:='';
 myName:='';
 myRange:=Rect2D(0,0,1,1);
 Kill(mySpline);
end;

destructor TRelation.Destroy;
begin
 myName:='';
 myRange:=Rect2D(0,0,1,1);
 Kill(mySpline);
 inherited Destroy;
end;

function TRelation.Get(Argument:Double; Inverted:Boolean):Double;
begin
 if Assigned(Self) then with myRange do begin
  if Inverted
  then Result:=InvertSpline(a.x,b.x,mySpline,Argument)
  else Result:=ExpandSpline(a.x,b.x,mySpline,Argument);
 end else Result:=0;
end;

 {
 *******************************************************************************
 Утилиты работы с термопарными зависимостями
 *******************************************************************************
 }
function ThermoCoupleCount:Integer;
begin
 Result:=CoupleList.Count;
end;

function ThermoCoupleName(CoupleID:Integer):LongString;
begin
 Result:=UnifyAlias(TRelation(CoupleList[CoupleID]).Name);
end;

function ThermoCoupleRange(CoupleID:Integer):TRect2D;
begin
 Result:=RectValidate(TRelation(CoupleList[CoupleID]).Range);
end;

function ThermoCouple(CoupleID:Integer; Argument:Double; Inverted:Boolean):Double;
begin
 Result:=TRelation(CoupleList[CoupleID]).Get(Argument,Inverted);
end;

function FindThermoCouple(const CoupleName:LongString):Integer;
var i:Integer;
begin
 Result:=-1;
 if UnifyAlias(CoupleName)<>'' then
 for i:=0 to ThermoCoupleCount-1 do
 if IsSameText(UnifyAlias(ThermoCoupleName(i)),UnifyAlias(CoupleName)) then begin
  Result:=i;
  break;
 end;
end;

procedure InitCouples(const IniFile,Section,Name:LongString; DebugId:Integer=-1);
var Path:LongString; aIniFile:LongString;
begin
 Path:='';
 aIniFile:=UnifyFileAlias(IniFile);
 if ReadIniFilePath(aIniFile,Section,Name,ExtractFilePath(aIniFile),Path) then begin
  if DebugID>=0 then DebugOut(DebugID,RusEng('Читаем термопарные таблицы из ',
                                             'Reading thermocouple database ')+Path);
  ReadThermoCoupleList(Path,DebugID);
  if ThermoCoupleCount=0 then
  if DebugID>=0 then DebugOut(DebugID,RusEng('Нет термопарных таблиц в ',
                                             'Not found thermocouple database in ')+Path);
 end else begin
  if DebugID>=0 then DebugOut(DebugID,RusEng('Не могу найти таблицы в ',
                                             'Not found database ')+aIniFile+' '+Section+' '+Name);
 end;
end;

procedure ReadThermoCoupleList(const IniFile:LongString; DebugID:Integer=-1);
var aIniFile,Section,CoupleName:LongString; P:PChar; Couple:TRelation;
label Ok,Fault;
begin
 Section:='';
 CoupleName:='';
 CoupleList.Count:=0;
 aIniFile:=UnifyFileAlias(IniFile);
 if not FileExists(aIniFile) then goto Fault;
 Section:=ExtractTextSection(aIniFile,'[ThermoCoupleList]',efConfig);
 if (Section='') then goto Fault;
 P:=StrPass(ScanVarAlpha(svConfig,PChar(Section),'ThermoCouple%a',CoupleName),[ASCII_CR,ASCII_LF]);
 while Assigned(P) do begin
  Couple:=TRelation.Create(aIniFile,UnifySection(CoupleName),'Celsius','mV','RelErr');
  if Couple.Ok then begin
   CoupleList.Add(Couple);
   if DebugID>=0 then DebugOut(DebugID,RusEng('Успешно прочитали термопарную таблицу ',
                                              'Read Ok thermocouple ')+CoupleName);
  end else begin
   if DebugID>=0 then DebugOut(DebugID,RusEng('Не удалось прочитать термопарную таблицу ',
                                              'Read fail thermocouple ')+CoupleName);
   Kill(TObject(Couple));
  end;
  P:=StrPass(ScanVarAlpha(svConfig,P,'ThermoCouple%a',CoupleName),[ASCII_CR,ASCII_LF]);
 end;
Ok:
 Section:='';
 exit;
Fault:
 Section:='';
 CoupleList.Count:=0;
end;

 {
 *******************************************************************************
 Утилиты работы с простыми зависимостями
 *******************************************************************************
 }
function RelationshipCount:Integer;
begin
 RelationshipCount:=RelationList.Count;
end;

function RelationshipName(RelationID:Integer):LongString;
begin
 Result:=UnifyAlias(TRelation(RelationList[RelationID]).Name);
end;

function RelationshipRange(RelationID:Integer):TRect2D;
begin
 Result:=RectValidate(TRelation(RelationList[RelationID]).Range);
end;

function Relationship(RelationID:Integer; Argument:Double; Inverted:Boolean):Double;
begin
 Result:=TRelation(RelationList[RelationID]).Get(Argument,Inverted);
end;

function FindRelationship(const RelationName:LongString):Integer;
var i:Integer;
begin
 Result:=-1;
 if UnifyAlias(RelationName)<>'' then
 for i:=0 to RelationshipCount-1 do
 if IsSameText(UnifyAlias(RelationshipName(i)),UnifyAlias(RelationName)) then begin
  Result:=i;
  break;
 end;
end;

procedure InitRelationships(const IniFile,Section,Name:LongString; DebugID:Integer=-1);
var Path,aIniFile:LongString;
begin
 Path:='';
 aIniFile:=UnifyFileAlias(IniFile);
 if ReadIniFilePath(aIniFile,Section,Name,ExtractFilePath(aIniFile),Path) then begin
  if DebugID>=0 then DebugOut(DebugID,RusEng('Читаем таблицы зависимостей из ',
                                             'Reading relationship database ')+Path);
  ReadRelationshipList(Path,DebugID);
  if RelationshipCount=0 then
  if DebugID>=0 then DebugOut(DebugID,RusEng('Нет таблиц зависимостей в ',
                                             'Not found relationship database in ')+Path);
 end else begin
  if DebugID>=0 then DebugOut(DebugID,RusEng('Не могу найти таблицы зависимостей в ',
                                             'Not found relationship database ')+aIniFile+' '+Section+' '+Name);
 end;
end;

procedure ReadRelationshipList(const IniFile:LongString; DebugID:Integer=-1);
var aIniFile,Section,RelationName:LongString; P:PChar; Relation:TRelation;
label Ok,Fault;
begin
 Section:='';
 RelationName:='';
 RelationList.Count:=0;
 aIniFile:=UnifyFileAlias(IniFile);
 if not FileExists(aIniFile) then goto Fault;
 Section:=ExtractTextSection(aIniFile,'[RelationshipList]',efConfig);
 if Section='' then goto fault;
 P:=StrPass(ScanVarAlpha(svConfig,PChar(Section),'Relationship%a',RelationName),[ASCII_CR,ASCII_LF]);
 while Assigned(P) do begin
  Relation:=TRelation.Create(aIniFile,UnifySection(RelationName),'X','Y','RelErr');
  if Relation.Ok then begin
   RelationList.Add(Relation);
   if DebugID>=0 then DebugOut(DebugID,RusEng('Успешно прочитали таблицу зависимости ',
                                              'Read Ok Relation ')+RelationName);
  end else begin
   if DebugID>=0 then DebugOut(DebugID,RusEng('Не удалось прочитать таблицу зависимости ',
                                              'Read fail Relation ')+RelationName);
   Kill(TObject(Relation));
  end;
  P:=StrPass(ScanVarAlpha(svConfig,P,'Relationship%a',RelationName),[ASCII_CR,ASCII_LF]);
 end;
Ok:
  Section:='';
  exit;
Fault:
 Section:='';
 RelationList.Count:=0;
end;

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

procedure Init_crw_couple;
begin
 CoupleList:=NewObjectStorage;
 RelationList:=NewObjectStorage;
end;

procedure Free_crw_couple;
begin
 Kill(CoupleList);
 Kill(RelationList);
end;

initialization

 Init_crw_couple;

finalization

 Free_crw_couple;

end.

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

