unit tbls;

interface

uses Windows, Classes, SysUtils,GlType,GlProc,MathObj;

type

{Таблица - базовый объект}
TCustomTable = class
 protected
  FFileName:  String;                      //Имя текстового файла с таблицей
  procedure   SetFileName(aFileName:String);
  procedure   find(ax:RealType;var Xa,Xb:RealType;var Ia,Ib:Integer;var aPx:array of RealType);
 public
  constructor Create(aFileName:String);virtual;
  destructor  Destroy;override;
  procedure   Active;
  procedure   FromString(S: string);virtual;abstract;
  procedure   OpenFromFile(aFileName:String);virtual;
  property    FileName:String read FFileName write SetFileName;
end;

TCustomTableClass = class of TCustomTable; //Класс - тип таблицы

{Ny таблично заданных функций одного аргумента}
TTable1 = class(TCustomTable)
 private
  nx,                                      //Число значений аргумента
  ny        : Integer;                     //Число функций одного аргумента
  procedure   SetArgCount(aN:Integer);
  procedure   SetFunsCount(aN:Integer);
 public
  px        : TExtArray;                   //Массив значений аргумента
  py        : TExtArray2;                  //Массив значений функций
  constructor Create(aFileName:String);override;
  destructor  Destroy;override;
  procedure   FromString(S: string);override;
  function    GetFunValue(ax:RealType;iy:Integer):RealType;
  procedure   GetFunValues(ax:RealType;ay:PExtArr);
  property    ArgCount:Integer read Nx write SetArgCount;
  property    FunsCount:Integer read Ny write SetFunsCount;
end;

 // Двумерная таблица - по столбцам - px2, по строкам - px1
 // px1\px2
 //         |
 //         |

TTable2 = class(TCustomTable)
 private
  nx1,                                     //Число строк (1-й аргумент)
  nx2:        Integer;                     //Число столбцов (2-й аргумент)
  procedure   SetArg1Count(aN:Integer);
  procedure   SetArg2Count(aN:Integer);
 public
  px1,                                     //Массив значений 1-го аргумента (строки)
  px2:        TExtArray;                   //Массив значений 2-го аргумента (столбцы)
  py:         TExtArray2;                  //Массив значений функции
  constructor Create(aFileName:String);override;
  destructor  Destroy;override;
  procedure   FromString(S: string);override;
  function    GetFunValue(arow,acol:RealType):RealType;
  function    FindByFunValue(value,Idem:RealType;wIdem:Byte):RealType;
  property    Arg1Count:Integer read Nx1 write SetArg1Count;
  property    Arg2Count:Integer read Nx2 write SetArg2Count;
end;

// Класс - пакет таблиц (сложная таблица), загружаемых из одного файла
// Перед вызовом OpenFromFile надо задать классы таблиц CreateTables
// Разделителем таблиц является строка, содержащая в начале символ #
TTabPack = class(TCustomTable)
private
  function    GetTable(Index: integer):TCustomTable;
  function    GetTabCount:integer;
public
  Tables:     TList;
  constructor Create(aFileName:String);
  destructor  Destroy;override;
  procedure   CreateTables(const TabClasses: array of TCustomTableClass);
  procedure   FromString(S: string);override;
  property    Table[Index: integer]:TCustomTable read GetTable;
  property    TableCount:integer read GetTabCount;
end;

// Объект - менеджер таблиц, нужен для их оптимальной загрузки
// Этот объект кэширует таблицы и позволяет не загружать несколько
// таблиц из одного и того же файла
TTableMenager = class
public
  TableList:  TList;
  constructor Create;
  destructor  Destroy;override;
  function    LoadTable(AFileName: string;       //Загрузить таблицу заданного типа
     TabClass: TCustomTableClass):TCustomTable;
  function    LoadPack(AFileName: string;        //Загрузить сложную таблицу
     const TabClasses: array of TCustomTableClass):TTabPack;
  procedure   UnLoad;                            //Выгрузить все таблицы
  procedure   ReLoad;                            //Перегрузить все таблицы
end;

var
  TableMenager: TTableMenager;

{##############################################################################}

                         IMPLEMENTATION

{##############################################################################}

function Str2Args(const S:String;var Index: integer;var Value: double):Boolean;
var i      : Integer;
    err    : Integer;
    S1: string;

begin
 Result:=False;
 i:=index;
 while (i <= Length(S)) and (S[i] in [' ',';',':']) do inc(i);
 index:=i;
 while (index <= Length(S)) and not (S[index] in [' ',';',':']) do inc(index);
 S1:=Copy(S,i,index - i);
 val(S1,Value,err);
 Result:=err = 0;
end;

//------------------------------------------------------------------------------
constructor TCustomTable.Create;
begin
 inherited Create;
 FFileName:='';
 FileName:=aFileName
end;
//------------------------------------------------------------------------------
destructor TCustomTable.Destroy;
begin
 inherited
end;
//------------------------------------------------------------------------------
procedure TCustomTable.SetFileName;
begin
 aFileName:=Trim(aFileName);
 if FFileName <> aFileName then FFileName:=aFileName;
end;
//------------------------------------------------------------------------------
//Поиск методом деления пополам двух соседних узлов в массиве aPx,
//между которыми расположено значение аргумента xx.
//Функция возвращает:
//1 - Индексы Ia, Ib соседних узлов, между которыми расположено значение ax
//2 - Значения Xa, Xb в соседних узлах
//Требования:
//Массив aPx должен быть отсортирован по возрастанию или убыванию значений аргумента
procedure TCustomTable.find(ax:RealType;var Xa,Xb:RealType;var Ia,Ib:Integer;var aPx:array of RealType);
var Ic,k : integer;
begin
 k:=1;
 if aPx[Ia] > aPx[Ib] then begin
  Ic:=Ia;
  Ia:=Ib;
  Ib:=Ic;
  k:=-1;
 end;

 if (ax <= aPx[Ia]) then Ib:=Ia+k else if (ax >= aPx[Ib]) then Ia:=Ib-k;

 while abs(Ib-Ia) > 1 do begin
  Ic:=(Ia+Ib) div 2 ;
  if ax < aPx[ic] then Ib:=Ic else Ia:=Ic
 end;
 Xa:=aPx[Ia];
 Xb:=aPx[Ib]
end;

procedure TCustomTable.Active;
begin
  OpenFromFile(FileName);
end;

procedure TCustomTable.OpenFromFile;
var S:   String;
    FS:  TFileStream;
begin
   FileName:=aFileName;
   if not FileExists(ExpandFileName(FileName)) then begin
      //Файл не найден. Установить код ошибки
     Exception.Create('Файл не найден '+ExpandFileName(FileName));
     exit
   end;
   try
     //Файл должен быть открыт с произвольным доступом
     FS:=TFileStream.Create(ExpandFileName(FileName),fmOpenRead or fmShareDenyNone);
     //Загрузка строки из файла
     SetLength(S,FS.Size);
     FS.ReadBuffer(Pointer(S)^,Length(S));
     //Считывание текста из строки
     FromString(S);
   finally
     FS.Free;
   end;
end;

//******************************************************************************
//
// Таблично заданная функция одного аргумента
//
//******************************************************************************
constructor TTable1.Create;
begin
 inherited;
 Px:=TExtArray.Create(0);
 Py:=TExtArray2.Create(1,1);
 ArgCount:=0;
 FunsCount:=1;//По умолчанию - одна функция
end;
//------------------------------------------------------------------------------
destructor TTable1.Destroy;
begin
 Px.Free;
 Py.Free;
 inherited;
end;
//------------------------------------------------------------------------------
procedure TTable1.SetFunsCount;
begin
 ny:=aN;
 Py.ChangeCount(ny,nx);
end;
//------------------------------------------------------------------------------
procedure TTable1.SetArgCount;
begin
 nx:=aN;
 Px.ChangeCount(nx)
end;
//------------------------------------------------------------------------------
procedure TTable1.FromString;
 var SL: TStringList;
     i,j,k:integer;
     x:  RealType;
begin
 SL:=TStringLIst.Create;
 //  Заменяем символы табуляции и др. разделители на пробелы
 for i:=1 to Length(S) do if (S[i] = #9) or (S[i] = ';') or (S[i] = '|') then S[i]:=' ';
 SL.Text:=S;
 //  Отрезаем от текста лишние символы
 for i:=0 to SL.Count - 1 do SL[i]:=Trim(SL[i]);
 //  Удаляем пустые строки и комментарии
 //  Комментарии помечаются как в C++
 i:=0;
 while i < SL.Count do
   if (SL[i] = '') or (SL[i][1] in ['/','\','{','*']) then
     SL.Delete(i)
   else
     inc(i);
 if SL.Count > 0 then begin
   //  Устанавливаем размерности таблицы
   nx:=SL.Count;
   i:=0;
   k:=1;
   while Str2Args(SL[0],k,x) do inc(i);
   ny:=i-1;
   px.ChangeCount(nx);
   py.ChangeCount(ny,nx);
   //  Заполняем значения таблиц
   for i:=0 to SL.Count - 1 do begin
     k:=1;
     Str2Args(SL[i],k,x);
     Px.arr^[i]:=x;
     j:=0;
     while (j < FunsCount) and Str2Args(SL[i],k,x) do begin
       Py.arr^[j].arr^[i]:=x;
       inc(j);
     end
   end
 end
 else
   Exception.Create('Неправильная таблица  '+ExpandFileName(FFileName));
 SL.Free;
end;
//------------------------------------------------------------------------------
function TTable1.GetFunValue;
var  Ia,Ib   : Integer;
     Xa,Xb,x : RealType;
begin
 if nx = 1 then begin
  Result:=Py.arr^[Iy].arr^[0];
  exit
 end;

 Ia:=0;Ib:=nx-1;

 if Ia = Ib then begin
  Result:=Py.arr^[Iy].arr^[ia];
  exit
 end;

 find(ax,Xa,Xb,Ia,Ib,Px.arr^);
 x:=(ax-Xa)/(Xb-Xa);
 Result:=Py.arr^[Iy].arr^[ia]+x*(Py.arr^[Iy].arr^[ib]-Py.arr^[Iy].arr^[ia]);
end;
//------------------------------------------------------------------------------
procedure TTable1.GetFunValues;
var  Ia,Ib,i : Integer;
     Xa,Xb,x : RealType;
begin
 if nx = 1 then begin
  for i:=0 to ny-1 do ay^[i]:=Py.arr^[i].arr^[0];
  exit
 end;

 Ia:=0;Ib:=nx-1;

 if Ia = Ib then begin
  for i:=0 to ny-1 do ay^[i]:=Py.arr^[i].arr^[ia];
  exit
 end;

 find(ax,Xa,Xb,Ia,Ib,Px.arr^);
 x:=(ax-Xa)/(Xb-Xa);
 for i:=0 to ny-1 do
  ay^[i]:=Py.arr^[i].arr^[ia]+x*(Py.arr^[i].arr^[ib]-Py.arr^[i].arr^[ia]);
end;
//******************************************************************************
//
// Таблично заданная функция двух аргументов
//
//******************************************************************************
constructor TTable2.Create;
begin
 inherited;
 Px1:=TExtArray.Create(0);
 Px2:=TExtArray.Create(0);
 Py:=TExtArray2.Create(1,1);
 Py.ChangeCount(0,0);
 Arg1Count:=0;
 Arg2Count:=0;
end;
//------------------------------------------------------------------------------
destructor TTable2.Destroy;
begin
 Px1.Free;
 Px2.Free;
 Py.Free;
 inherited;
end;
//------------------------------------------------------------------------------
procedure TTable2.SetArg1Count;
begin
  Nx1:=aN;
  Px1.ChangeCount(Nx1);
end;
//------------------------------------------------------------------------------
procedure TTable2.SetArg2Count;
begin
  Nx2:=aN;
  Px2.ChangeCount(Nx2);
end;
//------------------------------------------------------------------------------
procedure TTable2.FromString;
 var SL: TStringList;
     i,j,k:integer;
     x:  RealType;
begin
 SL:=TStringLIst.Create;
 //  Заменяем символы табуляции и др. разделители на пробелы
 for i:=1 to Length(S) do if (S[i] = #9) or (S[i] = ';') or (S[i] = '|') then S[i]:=' ';
 SL.Text:=S;
 //  Отрезаем от текста лишние символы
 for i:=0 to SL.Count - 1 do SL[i]:=Trim(SL[i]);
 //  Удаляем пустые строки и комментарии
 //  Комментарии помечаются как в C++ или при помощи скобки
 i:=0;
 while i < SL.Count do
   if (SL[i] = '') or (SL[i][1] in ['/','\','{','*']) then
     SL.Delete(i)
   else
     inc(i);
 if SL.Count > 1 then begin
   //  Присваиваем количество строк таблицы
   nx1:=SL.Count - 1;
   Px1.ChangeCount(nx1);
   //  Заполняем массив второго аргумента (х) (столбцы)
   k:=1;
   Px2.ChangeCount(0);
   while Str2Args(SL[0],k,x) do Px2.Add(x);
   nx2:=Px2.Count;
   Py.ChangeCount(Nx1,Nx2);
   //  Заполняем значения таблицы из текста
   for i:=0 to Nx1 - 1 do begin
     k:=1;
     Str2Args(SL[i + 1],k,x);
     Px1.arr^[i]:=x;
     j:=0;
     while (j < Nx2) and Str2Args(SL[i + 1],k,x) do begin
       Py.arr^[i].arr^[j]:=x;
       inc(j);
     end
   end;
 end
 else
   Exception.Create('Неправильная таблица  '+ExpandFileName(FFileName));
 SL.Free;
end;

//------------------------------------------------------------------------------
function TTable2.GetFunValue;
var  Ia1,Ib1,
     Ia2,Ib2 : Integer;
     a,b,c,d,
     x0,x1,
     y0,y1 : RealType;
begin
 Ia1:=0;
 Ib1:=Nx1-1;
 find(arow,x0,x1,Ia1,Ib1,Px1.arr^);

 Ia2:=0;
 Ib2:=Nx2-1;
 find(acol,y0,y1,Ia2,Ib2,Px2.arr^);

 a:=Py.arr^[ia1].arr^[ia2];

 if Ia2 = Ib2 then c:=0
  else c:=(Py.arr^[ia1].arr^[ib2]-Py.arr^[ia1].arr^[ia2])/(y1-y0);

 if (Ia1 = Ib1)then d:=0
  else d:=(Py.arr^[ib1].arr^[ib2]-Py.arr^[ib1].arr^[ia2]-c*(y1-y0))/((x1-x0)*(y1-y0));

 if Ia1 = Ib1 then b:=0
  else b:=(Py.arr^[ib1].arr^[ia2]-a)/(x1-x0);

 Result:=a+b*(arow-x0)+c*(acol-y0)+d*(arow-x0)*(acol-y0);
end;
//------------------------------------------------------------------------------
function TTable2.FindByFunValue(value,Idem:RealType;wIdem:Byte):RealType;
var  xa,xb,xc : RealType;
     fa,fb,fc : RealType;
begin
 if wIdem = 1 then begin //Не меняется первый аргумент
  xa:=Px2.arr^[0];
  xb:=Px2.arr^[nx2-1];
  fa:=GetFunValue(Idem,xa)-value;
  fb:=GetFunValue(Idem,xb)-value;
  repeat
   xc:=(xa+xb)/2;
   fc:=GetFunValue(Idem,xc)-value;
   if fa*fc > 0 then xa:=xc else xb:=xc;
  until (abs(xb-xa) < 0.001)or(abs(fc) < 0.001);
 end else begin          //Не меняется второй аргумент
  xa:=Px1.arr^[0];
  xb:=Px1.arr^[nx1-1];
  fa:=GetFunValue(xa,Idem)-value;
  fb:=GetFunValue(xb,Idem)-value;
  repeat
   xc:=(xa+xb)/2;
   fc:=GetFunValue(xc,Idem)-value;
   if fa*fc > 0 then xa:=xc else xb:=xc;
  until (abs(xb-xa) < 0.001)or(abs(fc) < 0.001);
 end;

 Result:=xc;
end;


//****************************************************************************//
//       Сложная таблица - контейнер разнотипных таблиц                       //
//****************************************************************************//
constructor TTabPack.Create;
begin
 inherited;
 Tables:=TList.Create;
end;

destructor  TTabPack.Destroy;
 var i: integer;
begin
 for i:=0 to Tables.Count - 1 do TCustomTable(Tables[i]).Free;
 Tables.Free;
 inherited;
end;

procedure   TTabPack.CreateTables;
 var i: integer;
begin
  //Создание группы таблиц из одного файла
 for i:=0 to Tables.Count - 1 do TCustomTable(Tables[i]).Free;
 Tables.Clear;
 Tables.Count:=Length(TabClasses);
 for i:=0 to Tables.Count - 1 do Tables[i]:=TabClasses[i].Create(FileName);
end;

function    TTabPack.GetTabCount;
begin
  Result:=Tables.Count;
end;

function    TTabPack.GetTable;
begin
  if (Index >= 0) and (Index < Tables.Count) then Result:=TCustomTable(Tables.List^[Index]) else Result:=nil;
end;

procedure   TTabPack.FromString;
 var ss: string;
     SL: TStringList;
     i,j:integer;
begin
  SL:=TStringList.Create;
  //  Заменяем символы табуляции и др. разделители на пробелы
  for i:=1 to Length(S) do if (S[i] = #9) or (S[i] = ';') or (S[i] = '|') then S[i]:=' ';
  SL.Text:=S;
  //  Отрезаем от текста лишние символы
  for i:=0 to SL.Count - 1 do SL[i]:=Trim(SL[i]);
  //  Удаляем пустые строки и комментарии
  //  Комментарии помечаются как в C++
  i:=0;
  while i < SL.Count do
   if (SL[i] = '') or (Copy(SL[i],1,2) = '//') then
     SL.Delete(i)
   else
     inc(i);
  //  Разделяем  текст на участки, разделителем является строка
  //  начинающаяся с символа #
  SL.Add('#');
  ss:='';
  j:=0;
  for i:=0 to SL.Count - 1 do begin
    S:=SL[i];
   if (S <> '') then
    if (S[1] = '#') or (S[1] = '$') then begin
      //Загружаем новую таблицу из строки
       if (ss <> '') and (j < Tables.Count) then begin
         Table[j].FromString(ss);
         inc(j);
       end;
       ss:='';
    end
    else
      ss:=ss + S + #13#10;
  end;
  SL.Free;
end;

//****************************************************************************//
//                Менеджер таблиц                                             //
//****************************************************************************//
constructor TTableMenager.Create;
begin
  TableList:=TList.Create;
end;

destructor  TTableMenager.Destroy;
begin
  UnLoad;
  TableList.Free;
end;

procedure   TTableMenager.UnLoad;
 var i: integer;
begin
  for i:=0 to TableList.Count - 1 do TCustomTable(TableList[i]).Free;
  TableList.Clear;
end;

procedure   TTableMenager.ReLoad;
 var i: integer;
begin
  for i:=0 to TableList.Count - 1 do with TCustomTable(TableList[i]) do OpenFromFile(FileName);
end;

function    TTableMenager.LoadTable;
 var i: integer;
begin
  Result:=nil;
  AFileName:=LowerCase(AFileName);
  for i:=0 to TableList.Count - 1 do with TCustomTable(TableList[i]) do
    if (AFileName = LowerCase(FileName)) and (TObject(TableList[i]) is TabClass) then begin
      Result:=TableList[i];
      exit;
    end;
  if FileExists(AFileName) then begin
    Result:=TabClass.Create(AFileName);
    Result.OpenFromFile(AFileName);
    TableList.Add(Result);
  end
end;

function   TTableMenager.LoadPack;
  var i: integer;

  function  CheckTypes(Table: TTabPack):boolean;
    var i: integer;
  begin
    // Проверка классов таблиц, принадлежащих данной сложной таблице
    Result:=True;
    if Length(TabClasses) > Table.Tables.Count then
      Result:=False
    else
      for i:=0 to Table.Tables.Count - 1 do
        if not ((Table.Tables[i] <> nil) and (TObject(Table.Tables[i]) is TabClasses[i])) then begin
          Result:=False;
          exit;
        end;
  end;

begin
  Result:=nil;
  AFileName:=LowerCase(AFileName);
  for i:=0 to TableList.Count - 1 do with TCustomTable(TableList[i]) do
    if (AFileName = LowerCase(FileName)) and (TObject(TableList[i]) is TTabPack) and CheckTypes(TableList[i]) then begin
      Result:=TableList[i];
      exit;
    end;
  if FileExists(AFileName) then begin
    Result:=TTabPack.Create(AFileName);
    Result.CreateTables(TabClasses);
    Result.OpenFromFile(AFileName);
    TableList.Add(Result);
  end
end;

initialization
  TableMenager:=TTableMenager.Create;
finalization
  TableMenager.Free;
END.