 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2001, <kouriakine@mail.ru>
 Procedures to solve general nonlinear unconstraint Least SQuares problem:
    X = arg min F(X), where F(X) = sum of squares = sum(sqr(Chi(i,X)),i=0..M-1)
 To find least squares, may use GenMin (9 classic methods of unconstraint
 minimization) or use LSQGauss - solve with linear least squares iterations
 for Tailor decomposition. LeastSquares contains all this methods.
 Modifications:
 20011214 - Creation (uses CRW16) & test
 ****************************************************************************
 }
unit _lsqmin; { Least SQuares MINimization }

{$I _sysdef}

interface

uses
 windows,
 math,
 _alloc,
 _ef,
 _zm,
 _svd,
 _funmin;

 {
 Squares basis: objective function for minimization is sum of
 squares of this basis function
 }
type
 TSquaresBasis=function(
                    i      : Integer;         { 0..M-1 - index in basis }
                var X      : array of Double; { argument }
                var F      : Double;          { value }
                var G      : array of Double; { gradient }
                    Custom : Pointer;         { user data }
                    M      : Integer;         { number of squares in sum }
                    N      : Integer          { argument dimension }
                         ) : Integer;         { 0 or error code }
const
 mGauss = 9; {GS}

 {
 function solves general nonlinear unconstraint least squares problem
 by any Method.
 }
function LeastSquares(
              Chi      : TSquaresBasis;   { squares to minimize }
              Report   : TMinReport;      { report about iterations }
              m        : Integer;         { number of squares in sum }
              n        : Integer;         { argument dimension }
          var X        : array of Double; { argument }
          var F        : Double;          { value = sum of sqr(Chi(i,X)) }
          var G        : array of Double; { gradient }
              Custom   : Pointer;         { user data }
          var Count    : Integer;         { function calls counter }
              MaxCount : Integer;         { limit for Count }
              Method   : Integer;         { algorithm switch, 0..9 }
              tolx     : Double;          { x tolerance }
              tolf     : Double;          { f tolerance }
              tolg     : Double;          { g tolerance }
              Inf      : Double;          { user-defined infimum, >=0 }
              Size     : Double;          { start simplex; NM algorithm }
              Step     : Double;          { start step; S algorithm }
              EvalTol  : Double;          { function evaluation precision }
          var a        : array of Double  { work array[(n+10)*(n+1)] }
                     ) : Integer;
 {
 function solves general nonlinear unconstraint least squares problem
 by any Method.
 Use this procedure when some variables must be be fixed.
 Fix[i] must be false for free variables and true for fixed.
 }
function LeastSquaresFix(
              Chi      : TSquaresBasis;   { squares to minimize }
              Report   : TMinReport;      { report about iterations }
              m        : Integer;         { number of squares in sum }
              n        : Integer;         { argument dimension }
          var X        : array of Double; { argument }
          var F        : Double;          { value = sum of sqr(Chi(i,X)) }
          var G        : array of Double; { gradient }
              Custom   : Pointer;         { user data }
          var Count    : Integer;         { function calls counter }
              MaxCount : Integer;         { limit for Count }
              Method   : Integer;         { algorithm switch, 0..9 }
              tolx     : Double;          { x tolerance }
              tolf     : Double;          { f tolerance }
              tolg     : Double;          { g tolerance }
              Inf      : Double;          { user-defined infimum, >=0 }
              Size     : Double;          { start simplex; NM algorithm }
              Step     : Double;          { start step; S algorithm }
              EvalTol  : Double;          { function evaluation precision }
          var a        : array of Double; { work array[(n+10)*(n+1)] }
          var Fix      : array of Boolean {true for fixed variables}
                     ) : Integer;

 {
 function solves general nonlinear unconstraint least squares problem
 by Gauss method ( iterate linear least squares problem for linear term
 of Tailor decomposition of squares sum ).
 }
function  LSQGauss(Chi      : TSquaresBasis;    { squares to minimize }
                   Report   : TMinReport;       { report about iterations }
                   m        : Integer;          { number of squares in sum }
                   n        : Integer;          { argument dimension }
               var X        : array of Double;  { argument }
               var F        : Double;           { value = sum(0..M-1) of sqr(}
               var G        : array of Double;  { gradient }
                   Custom   : Pointer;          { user data }
               var Count    : Integer;          { function calls counter }
                   MaxCount : Integer;          { limit for Count }
                   tolx     : Double;           { x tolerance }
                   tolf     : Double;           { f tolerance }
                   tolg     : Double;           { g tolerance }
               var a        : array of Double   { work array[n*n+n+n] }
                          ) : Integer;

implementation

 {
 function evaluates, as argument x given, a value f of sum of m squares
 Chi(i,x), i=0..m-1, a gradient g of this sum, normal equations matrix
 a and right side of normal equations y; gi is internally use array;
 na is declared column dimension of matrix a
 }
function EvaluateFunGradAndNormalEquations(
               m      : Integer;          { number of squares in sum }
               n      : Integer;          { dimension of argument }
               Chi    : TSquaresBasis;    { squares basis 0..M-1 }
           var x      : array of Double;  { argument[n] }
           var f      : Double;           { value of sum of squares }
           var g      : array of Double;  { gradient[n] }
               Custom : Pointer;          { user data }
           var a      : array of Double;  { matrix of normal equations >=[n*na] }
               na     : Integer;          { declared dimension of matrix A >=n }
           var y      : array of Double;  { right side of normal equations [n] }
           var gi     : array of Double   { work array[n] }
                    ) : Integer;
label Fault;
var i,j,k,jna,errorcode:Integer; fi,figi:Double;
begin
 {assign 0 to F,G,Y,A}
 f:=0;
 for j:=0 to n-1 do begin
  g[j]:=0;
  y[j]:=0;
  jna:=0;
  for k:=0 to n-1 do begin
   a[jna+k]:=0;
   inc(jna,na);
  end;
 end;
 {
 find: F(X)=sum of squares
       G(X)=gradient F(X)
       A   =matrix of normal equations set (Jacobian'*Jacobian)
       Y   =right side of normal equations set
 }
 for i:=0 to m-1 do begin
  errorcode:=Chi(i,x,fi,gi,Custom,m,n);
  if errorcode<>0 then goto Fault;
  f:=f+sqr(fi);
  for j:=0 to n-1 do begin
   y[j]:=y[j]-fi*gi[j];
   g[j]:=g[j]+2*fi*gi[j];
   jna:=0;
   for k:=0 to n-1 do begin
    a[jna+k]:=a[jna+k]+gi[j]*gi[k];
    inc(jna,na);
   end;
  end;
 end;
 EvaluateFunGradAndNormalEquations:=0;
 exit;
Fault:
 EvaluateFunGradAndNormalEquations:=ErrorCode;
end;

 {
 Current solved problem for LeastSquares.
 }
type
 TLSQRec=record
  m      : Integer;
  Chi    : TSquaresBasis;
  pgi    : PDoubleArray;
  Custom : Pointer;
 end;

 {
 function evaluates, as argument x given, a value f of sum of m squares
 Chi(i,x), i=0..m-1, a gradient g of this sum
 }
function SquaresSum(
               n      : Integer;          { dimension of argument }
           var x      : array of Double;  { argument[n] }
           var f      : Double;           { value of sum of squares }
           var g      : array of Double;  { gradient[n] }
               Custom : Pointer
               ):Integer;
label Fault;
var
 fi:Double;
 i,j,errorcode:Integer;
 LSQ : ^TLSQRec absolute Custom;
begin
 {assign 0 to F,G}
 f:=0;
 for j:=0 to n-1 do g[j]:=0;
 { find: F(X)=sum of squares G(X)=gradient F(X) }
 for i:=0 to LSQ.m-1 do begin
  errorcode:=LSQ.Chi(i,x,fi,LSQ.pgi[0],LSQ.Custom,LSQ.m,n);
  if errorcode<>0 then goto Fault;
  f:=f+sqr(fi);
  for j:=0 to n-1 do g[j]:=g[j]+2*fi*LSQ.pgi[j];
 end;
 SquaresSum:=0;
 exit;
Fault:
 SquaresSum:=ErrorCode;
end;

 {
 Solve normal equations set a*x=y with m by n dimension
 with na is declared column dimension of a
 using singular decomposition and given abolute and relative
 tolerance abstol,reltol
 }
procedure SolveNormalEquations(var a,x,y:array of Double;
                               m,n,na:Integer; abstol,reltol:Double);
begin
  SVD_Solve(m,n,na,a,x,y,abstol,reltol);
end;

 {
 function solves a common nonlinear unconstraint least squares problem
 by Gauss method ( iterate linear least squares problem for linear term
 of Tailor decomposition of squares sum ).
 }
function  LSQGauss(Chi      : TSquaresBasis;   { squares to minimize }
                   Report   : TMinReport;      { report about iterations }
                   m        : Integer;         { number of squares in sum }
                   n        : Integer;         { argument dimension }
               var X        : array of Double; { argument }
               var F        : Double;          { value = sum(0..M-1) of sqr(}
               var G        : array of Double; { gradient }
                   Custom   : Pointer;         { user data }
               var Count    : Integer;         { function calls counter }
                   MaxCount : Integer;         { limit for Count }
                   tolx     : Double;          { x tolerance }
                   tolf     : Double;          { f tolerance }
                   tolg     : Double;          { g tolerance }
               var a        : array of Double  { work array[n*n+n+n] }
                          ) : Integer;
label
 StartIterations,Fault,TooManyIterations,MinimumFound;
var
 i,ny,ndx,ErrorCode:Integer; abstol,reltol,fbefore:Double; how:ShortString;
 procedure Inform;
 begin
  Report(n,x,f,g,Custom,Count,'Gauss',how);
 end;
begin
 ny:=n*n;
 ndx:=ny+n;
 abstol:=macheps*n*10;
 reltol:=macheps*n*10;
 fbefore:=MaxDouble;
 Count:=0;
 how:='Start';
StartIterations:
 if Count>MaxCount then goto TooManyIterations;
 ErrorCode:=EvaluateFunGradAndNormalEquations(m,n,Chi,x,f,g,Custom,a,n,a[ny],a[ndx]);
 inc(Count);
 if ErrorCode<>0 then goto Fault;
 str(Count,how);
 how:='Iteration '+how;
 inform;
 SolveNormalEquations(a[0],a[ndx],a[ny],n,n,n,abstol,reltol);
 for i:=0 to n-1 do x[i]:=x[i]+a[ndx+i];
 if Count=1 then fbefore:=f;
 if Convergence(f,fbefore,tolf) and
    Convergence_g(a[ndx],tolx,n) and
    Convergence_g(g,tolg,n)
 then goto MinimumFound;
 fbefore:=f;
 goto StartIterations;
MinimumFound:
 LSQGauss:=ecOk;
 how:='Stop because minimum found.';
 Inform;
 Exit;
TooManyIterations:
 LSQGauss:=ecFail;
 how:='Stop because too many iterations.';
 Inform;
 Exit;
Fault:
 LSQGauss:=ErrorCode;
 how:='Stop because error found.';
 Inform;
 Exit;
end;

 {
 function solves a common nonlinear unconstraint least squares problem
 by any Method.
 !!! function cannot be called recursively (except mGauss method) !!!
 }
function LeastSquares(
              Chi      : TSquaresBasis;   { squares to minimize }
              Report   : TMinReport;      { report about iterations }
              m        : Integer;         { number of squares in sum }
              n        : Integer;         { argument dimension }
          var X        : array of Double; { argument }
          var F        : Double;          { value = sum(0..M-1) of sqr(}
          var G        : array of Double; { gradient }
              Custom   : Pointer;         { user data }
          var Count    : Integer;         { function calls counter }
              MaxCount : Integer;         { limit for Count }
              Method   : Integer;         { algorithm switch, 0..9 }
              tolx     : Double;          { x tolerance }
              tolf     : Double;          { f tolerance }
              tolg     : Double;          { g tolerance }
              Inf      : Double;          { user-defined infimum, >=0 }
              Size     : Double;          { start simplex; NM algorithm }
              Step     : Double;          { start step; S algorithm }
              EvalTol  : Double;          { function evaluation precision }
          var a        : array of Double  { work array[(n+10)*(n+1)] }
                     ) : Integer;
var LSQ:TLSQRec;
begin
 case Method of
  mNelderMead..mDavidon2:
   begin
    LSQ.m:=m;
    LSQ.Chi:=Chi;
    LSQ.pgi:=@a[(n+9)*(n+1)];
    LSQ.Custom:=Custom;
    LeastSquares:=GenMin(
    SquaresSum,Report,n,x,f,g,@LSQ,Count,MaxCount,Method,tolx,tolf,tolg,Inf,
    Size,Step,EvalTol,a,n+1);
   end;
  mGauss:
   begin
    LeastSquares:=LSQGauss(
    Chi,Report,m,n,x,f,g,Custom,Count,MaxCount,tolx,tolf,tolg,a);
   end;
  else LeastSquares:=ecBadMethod;
 end;
end;

 {
 internally use types for LeastSquaresFix
 }
type
 TFixRecord = record
  N      : Integer;
  X      : PDoubleArray;
  G      : PDoubleArray;
  Fix    : PBooleanArray;
  Chi    : TSquaresBasis;
  Report : TMinReport;
  Custom : Pointer;
 end;

 {
 internally use minimization problem for fixed params
 }
function    FixedChi(
                    i      : Integer;         { 0..M-1 - index in basis }
                var X      : array of Double; { argument }
                var F      : Double;          { value }
                var G      : array of Double; { gradient }
                    Custom : Pointer;         { user data }
                    M      : Integer;         { number of squares in sum }
                    N      : Integer          { argument dimension }
                    ):Integer;                { 0 or error code }
var
 UnFixed : ^TFixRecord absolute Custom;
begin
 {unpack argument from packed to original array}
 PackFixed(Unfixed.X[0],x,Unfixed.Fix[0],Unfixed.N,false);
 {call original problem}
 FixedChi:=Unfixed.Chi(i,Unfixed.X[0],f,Unfixed.G[0],Unfixed.Custom,M,Unfixed.N);
 {pack gradient from original to packed array}
 PackFixed(Unfixed.G[0],g,Unfixed.Fix[0],Unfixed.N,true);
end;

 {
 minimization report for fixed params
 }
procedure FixedReport(n      : Integer;
                  var x      : array of Double;
                  var f      : Double;
                  var g      : array of Double;
                      Custom : Pointer;
                      Count  : Integer;
                const Met    : ShortString;
                const Com    : ShortString);
var
 i       : Integer;
 UnFixed : ^TFixRecord absolute Custom;
begin
 {unpack argument from packed to original array}
 PackFixed(Unfixed.X[0],x,Unfixed.Fix[0],Unfixed.N,false);
 for i:=0 to Unfixed.N-1 do Unfixed.G[i]:=0;
 PackFixed(Unfixed.G[0],g,Unfixed.Fix[0],Unfixed.N,false);
 {and call original report}
 Unfixed.Report(Unfixed.N,Unfixed.X[0],f,Unfixed.G[0],Unfixed.Custom,Count,Met,Com);
end;

 {
 function solves general nonlinear unconstraint least squares problem
 by any Method.
 Use this procedure when some variables must be be fixed.
 Fix[i] must be false for free variables and true for fixed.
 }
function LeastSquaresFix(
              Chi      : TSquaresBasis;   { squares to minimize }
              Report   : TMinReport;      { report about iterations }
              m        : Integer;         { number of squares in sum }
              n        : Integer;         { argument dimension }
          var X        : array of Double; { argument }
          var F        : Double;          { value = sum of sqr(Chi(i,X)) }
          var G        : array of Double; { gradient }
              Custom   : Pointer;         { user data }
          var Count    : Integer;         { function calls counter }
              MaxCount : Integer;         { limit for Count }
              Method   : Integer;         { algorithm switch, 0..9 }
              tolx     : Double;          { x tolerance }
              tolf     : Double;          { f tolerance }
              tolg     : Double;          { g tolerance }
              Inf      : Double;          { user-defined infimum, >=0 }
              Size     : Double;          { start simplex; NM algorithm }
              Step     : Double;          { start step; S algorithm }
              EvalTol  : Double;          { function evaluation precision }
          var a        : array of Double; { work array[(n+10)*(n+1)] }
          var Fix      : array of Boolean {true for fixed variables}
                     ) : Integer;
var
 LSQ:TLSQRec;
 Unfixed:TFixRecord;
 i,FixedN,FixedSize:Integer;
 FixedX,FixedG:PDoubleArray;
begin
 case Method of
  mNelderMead..mDavidon2:
   begin
    LSQ.m:=m;
    LSQ.Chi:=Chi;
    LSQ.pgi:=@a[(n+9)*(n+1)];
    LSQ.Custom:=Custom;
    LeastSquaresFix:=GenMinFix(
    SquaresSum,Report,n,x,f,g,@LSQ,Count,MaxCount,Method,tolx,tolf,tolg,Inf,
    Size,Step,EvalTol,a,n+1,Fix);
   end;
  mGauss:
   begin
    {prepare data for FixedProblem,FixedReport}
    Unfixed.N:=n;
    Unfixed.X:=@x;
    Unfixed.G:=@g;
    Unfixed.Fix:=@Fix;
    Unfixed.Chi:=Chi;
    Unfixed.Report:=Report;
    Unfixed.Custom:=Custom;
    FixedN:=n-NumFixed(Fix,n);
    if FixedN<1 then begin
     LeastSquaresFix:=ecBadDim;
     exit;
    end;
    {allocate temporary arrays for packed variables}
    FixedSize:=FixedN*sizeof(Double);
    GetMem(FixedX,FixedSize);
    GetMem(FixedG,FixedSize);
    {pack argument from original to packed array}
    PackFixed(Unfixed.X[0],FixedX[0],Unfixed.Fix[0],Unfixed.N,true);
    {call problem with fixed variables removed}
    LeastSquaresFix:=LSQGauss(FixedChi,FixedReport,m,FixedN,FixedX[0],f,FixedG[0],
                              @Unfixed,Count,MaxCount,tolx,tolf,tolg,a);
    {unpack argument from packed to original array}
    PackFixed(Unfixed.X[0],FixedX[0],Unfixed.Fix[0],Unfixed.N,false);
    for i:=0 to Unfixed.N-1 do Unfixed.G[i]:=0;
    PackFixed(Unfixed.G[0],FixedG[0],Unfixed.Fix[0],Unfixed.N,false);
    {free temporary arrays}
    FreeMem(FixedX,FixedSize);
    FreeMem(FixedG,FixedSize);
   end;
  else LeastSquaresFix:=ecBadMethod;
 end;
end;

end.
