lazarus-ccr/applications/lazstats/source/units/matrixunit.pas

{ A general-purpose matrix library }

unit MatrixUnit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,
  Globals;

type
  TDblMatrix = DblDyneMat;
  TDblVector = DblDyneVec;

  EMatrix = class(Exception);

// Vectors

operator + (A, B: TDblVector): TDblVector;
operator - (A, B: TDblVector): TDblVector;
operator * (A, B: TDblVector): Double;
operator * (A: TDblVector; b: Double): TDblVector;
operator * (a: Double; B: TDblVector): TDblVector;

procedure VecCheck(A, B: TDblVector; out n: Integer);
function VecCopy(A: TDblVector): TDblVector;
function VecMultiply(A, B: TDblVector): TDblVector;
function VecOnes(n: Integer): TDblVector;
procedure VecSize(A: TDblVector; out n: Integer);

procedure VecMaxMin(const AData: TDblVector;
  out AMax, AMin: Double);
function VecMean(const AData: TDblVector): Double;
procedure VecMeanStdDev(const AData: TDblVector;
  out AMean, AStdDev: Double);
procedure VecMeanVarStdDev(const AData: TDblVector;
  out AMean, AVariance, AStdDev: Double);
procedure VecMeanVarStdDevSS(const AData: TDblVector;
  out AMean, AVariance, AStdDev, ASumOfSquares: Double);
procedure VecSumSS(const AData: TDblVector;
  out Sum, SS: Double);

function VecMedian(const AData: TDblVector): Double;

// Matrices

operator + (A, B: TDblMatrix): TDblMatrix;
operator - (A, B: TDblMatrix): TDblMatrix;
operator * (A, B: TDblMatrix): TDblMatrix;
operator * (A: TDblMatrix; v: TDblVector): TDblVector;

{ NOTE: Indices follow math convention:
  - 1st index is the row index, i.e. runs vertically
  - 2nd index is the col index, i.e. runs horizontally
  All indices are 0-based. }
function MatAppendColVector(A: TDblMatrix; v: TDblVector): TDblMatrix;
procedure MatCheck(A: TDblMatrix);
procedure MatCheckSquare(A: TDblMatrix; out n: Integer);
procedure MatColDelete(A: TDblMatrix; ACol: Integer);
procedure MatColMeanVarStdDev(A: TDblMatrix; out AMeans, AVariances, AStdDevs: TDblVector);
function MatColMeans(A: TDblMatrix): TDblVector;
function MatColVector(A: TDblMatrix; AColIndex: Integer): TDblVector;
function MatCopy(A: TDblMatrix): TDblMatrix;
function MatDeterminant(A: TDblMatrix): double;
function MatEqualSize(A, B: TDblMatrix): Boolean;
procedure MatExchangeElements(A: TDblMatrix; i1, j1, i2, j2: Integer);
procedure MatExchangeRows(A: TDblMatrix; i1, i2: Integer);
function MatInverse(A: TDblMatrix): TDblMatrix;
function MatIsSquare(A: TDblMatrix; out n: Integer): Boolean;
function MatNumCols(A: TDblMatrix): Integer;
function MatNumRows(A: TDblMatrix): Integer;
function MatRowMeans(A: TDblMatrix): TDblVector;
function MatRowVector(A: TDblMatrix; ARowIndex: Integer): TDblVector;
procedure MatSize(A: TDblMatrix; out n, m: Integer);
function MatTransposed(A: TDblMatrix): TDblMatrix;

// Sorting
procedure Exchange(var a, b: Double); overload;
procedure Exchange(var a, b: Integer); overload;
procedure Exchange(var a, b: String); overload;
procedure SortOnX(X: TDblVector; Y: TDblVector = nil; Z: TDblVector = nil);
procedure SortOnX(X: TDblVector; Y: TDblMatrix);
procedure QuickSortOnX(X: TDblVector; Y: TDblVector = nil; Z: TDblVector = nil);   // not 100% tested...


type
  TLUSolver = class
  private
    FLU: TDblMatrix;            // LU-decomposed matrix
    FIndex: array of integer;   // records permutations
    d: Double;                   // odd or even row permuations
    procedure LUDecompose;
  public
    constructor Create(A: TDblMatrix);
//    function CreateL: TDblMatrix;
//    function CreateU: TDblMatrix;
    procedure Solve(b: TDblVector);
    property LU: TDblMatrix read FLU;
end;


implementation

uses
  Math;


operator + (A, B: TDblVector): TDblVector;
var
  i, n: Integer;
begin
  VecCheck(A, B, n);
  SetLength(Result, n);
  for i := 0 to n-1 do
    Result[i] := A[i] + B[i];
end;


operator - (A, B: TDblVector): TDblVector;
var
  i, n: Integer;
begin
  VecCheck(A, B, n);
  SetLength(Result, n);
  for i := 0 to n-1 do
    Result[i] := A[i] - B[i];
end;


// Vector dot product
operator * (A, B: TDblVector): Double;
var
  i, n: Integer;
begin
  VecCheck(A, B, n);
  Result := 0;
  for i := 0 to n-1 do
    Result := Result + A[i] * B[i];
end;


// Multiplication of a vector by a scalar
operator * (A: TDblVector; b: Double): TDblVector;
var
  i, n: Integer;
begin
  n := Length(A);
  SetLength(Result, n);
  for i := 0 to n-1 do
    Result[i] := A[i] * b;
end;

operator * (a: Double; B: TDblVector): TDblVector;
var
  i, n: Integer;
begin
  n := Length(B);
  SetLength(Result, n);
  for i := 0 to n-1 do
    Result[i] := a * B[i];
end;


procedure VecCheck(A, B: TDblVector; out n: Integer);
var
  na, nb: Integer;
begin
  na := Length(A);
  nb := Length(B);
  if na <> nb then
    raise EMatrix.Create('Dimension error.')
  else
    n := na;
end;


function VecCopy(A: TDblVector): TDblVector;
var
  i: Integer;
begin
  SetLength(Result, Length(A));
  for i := 0 to High(A) do Result[i] := A[i];
end;


function VecMultiply(A, B: TDblVector): TDblVector;
var
  i, n: Integer;
begin
  VecCheck(A, B, n);
  SetLength(Result, n);
  for i := 0 to n-1 do
    Result[i] := A[i] * B[i];
end;


function VecOnes(n: Integer): TDblVector;
var
  i: Integer;
begin
  SetLength(Result, n);
  for i := 0 to n-1 do Result[i] := 1;
end;


procedure VecSize(A: TDblVector; out n: Integer);
begin
  n := Length(A);
end;


{===============================================================================
                 Statistical vector operations
===============================================================================}

procedure VecMaxMin(const AData: TDblVector; out AMax, AMin: Double);
var
  i: Integer;
begin
  AMin := Infinity;
  AMax := -Infinity;
  for i := Low(AData) to High(AData) do
  begin
    if AData[i] < AMin then AMin := AData[i];
    if AData[i] > AMax then AMax := AData[i];
  end;
end;


function VecMean(const AData: TDblVector): Double;
var
  i, n: Integer;
begin
  Result := 0;
  n := Length(AData);
  if n > 0 then
  begin
    for i := 0 to n-1 do
      Result := Result + AData[i];
    Result := Result / n;
  end else
    Result := NaN;
end;


procedure VecMeanStdDev(const AData: TDblVector; out AMean, AStdDev: Double);
var
  variance: Double;
begin
  VecMeanVarStdDev(AData, AMean, variance, AStdDev);
end;


procedure VecMeanVarStdDev(const AData: TDblVector;
  out AMean, AVariance, AStdDev: Double);
var
  sum, ss: Double;
  n: Integer;
begin
  AMean := NaN;
  AVariance := NaN;
  AStdDev := NaN;

  n := Length(AData);
  if n = 0 then
    exit;

  VecSumSS(AData, sum, ss);

  AMean := sum / n;
  if n = 1 then
    exit;

  AVariance := (ss - sqr(AMean) * n) / (n - 1);
  AStdDev := sqrt(AVariance);
end;


procedure VecMeanVarStdDevSS(const AData: TDblVector;
  out AMean, AVariance, AStdDev, ASumOfSquares: Double);
var
  sum: Double;
  n: Integer;
begin
  AMean := NaN;
  AVariance := NaN;
  AStdDev := NaN;

  n := Length(AData);
  if n = 0 then
    exit;

  VecSumSS(AData, sum, ASumOfSquares);

  AMean := sum / n;
  if n = 1 then
    exit;

  AVariance := (ASumOfSquares - sqr(sum) / n) / (n - 1);
  AStdDev := sqrt(AVariance);
end;


procedure VecSumSS(const AData: TDblVector; out Sum, SS: Double);
var
  i: Integer;
begin
  Sum := 0;
  SS := 0;
  for i := Low(AData) to High(AData) do
  begin
    Sum := Sum + AData[i];
    SS := SS + sqr(AData[i]);
  end;
end;


function VecMedian(const AData: TDblVector): Double;
var
  N, midPt: integer;
begin
  SortOnX(AData);

  N := Length(AData);
  midPt := N div 2;
  if odd(N) then
    Result := AData[midPt]                          // odd no. of values
  else
    Result := (AData[midPt-1] + AData[midPt]) / 2;  // even no. of values
end;


{===============================================================================
                               Matrix operators
===============================================================================}

operator + (A, B: TDblMatrix): TDblMatrix;
var
  n, m, i, j: Integer;
begin
  n := Length(A);
  m := Length(A[0]);
  if (n <> Length(B)) or (m <> Length(B[0])) then
    raise EMatrix.Create('Matrix subtraction: dimension error');

  SetLength(Result, n,m);
  for i := 0 to n-1 do
    for j := 0 to m-1 do
      Result[i, j] := A[i, j] + B[i, j];
end;


operator - (A, B: TDblMatrix): TDblMatrix;
var
  n, m, i, j: Integer;
begin
  n := Length(A);
  m := Length(A[0]);
  if (n <> Length(B)) or (m <> Length(B[0])) then
    raise EMatrix.Create('Matrix subtraction: dimension error');

  SetLength(Result, n,m);
  for i := 0 to n-1 do
    for j := 0 to m-1 do
      Result[i, j] := A[i, j] - B[i, j];
end;


{ Product of two matrices }
operator * (A, B: TDblMatrix): TDblMatrix;
var
  na, ma, nb, mb, i, j, k: Integer;
  sum: Double;
begin
  MatSize(A, na, ma);
  MatSize(B, nb, mb);
  if ma <> nb then
    raise EMatrix.Create('Matrix product: dimension error');

  SetLength(Result, na,mb);

  for i := 0 to na-1 do
    for j := 0 to mb-1 do begin
      sum := 0;
      for k := 0 to mA - 1 do
        sum := sum + A[i, k] * B[k, j];
      Result[i, j] := sum;
    end;
end;


{ Product of an n x m matrix with an m vector }
operator * (A: TDblMatrix; v: TDblVector): TDblVector;
var
  na, ma, nv, i, j: Integer;
  sum: Double;
begin
  MatSize(A, na, ma);
  VecSize(v, nv);
  if ma <> nv then
    raise EMatrix.Create('Dimension error.');

  SetLength(Result, na);
  for i := 0 to na-1 do
  begin
    sum := 0;
    for j := 0 to ma-1 do
      sum := sum + A[i, j] * v[j];
    Result[i] := sum;
  end;
end;


{ Adds the elements of the vector v to the rows of the matrix A, i.e. the number
  of columns increases by 1 }
function MatAppendColVector(A: TDblMatrix; v: TDblVector): TDblMatrix;
var
  i, j, n, m, nv: Integer;
begin
  MatSize(A, n, m);
  nv := Length(v);
  if n <> nv then
    raise EMatrix.Create('Dimension error.');

  SetLength(Result, n, m+1);
  for i := 0 to n-1 do
  begin
    for j := 0 to m-1 do
      Result[i, j] := A[i, j];
    Result[i, m] := v[i];
  end;
end;


{ Checks whether the matrix A has been initialized (i.e. by calling SetLength).
  Raises an Exception otherwise. }
procedure MatCheck(A: TDblMatrix);
begin
  if (A = nil) and (Length(A) = 0) then
    raise EMatrix.Create('Matrix not created.');
end;


procedure MatCheckSquare(A: TDblMatrix; out n: Integer);
begin
  if not MatIsSquare(A, n) then
    raise EMatrix.Create('Matrix is not square.');
end;


procedure MatColDelete(A: TDblMatrix; ACol: Integer);
var
  n, m, i, j: Integer;
begin
  MatSize(A, n,m);
  if (ACol < 0) or (ACol >= m) then
    raise EMatrix.Create('MatColDelete: illegal column index.');

  for i := 0 to n - 1 do begin
    for j := 0 to m - 2 do
      if j >= ACol then
        A[i, j] := A[i, j+1];
    SetLength(A[i], m-1);
  end;
end;


procedure MatColMeanVarStdDev(A: TDblMatrix; out AMeans, AVariances, AStdDevs: TDblVector);
var
  n, m, i, j: Integer;
  s, ss: Double;
begin
  MatSize(A, n, m);
  SetLength(AMeans, m);
  SetLength(AVariances, m);
  SetLength(AStdDevs, m);
  for j := 0 to m-1 do
  begin
    s := 0;
    ss := 0;
    for i := 0 to n-1 do
    begin
      s := s + A[i, j];
      ss := ss + sqr(A[i, j]);
    end;
    AMeans[j] := s / n;
    AVariances[j] := (ss - sqr(AMeans[j]) * n) / (n - 1);
    AStdDevs[j] := sqrt(AVariances[j]);
  end;
end;


function MatColMeans(A: TDblMatrix): TDblVector;
var
  i, j, n, m: Integer;
  sum: Double;
begin
  MatSize(A, n, m);
  SetLength(Result, m);
  for j := 0 to m-1 do
  begin
    sum := 0;
    for i := 0 to n-1 do
      sum := sum + A[i, j];
    Result[j] := sum / n;
  end;
end;


function MatColVector(A: TDblMatrix; AColIndex: Integer): TDblVector;
var
  i, n, m: Integer;
begin
  MatSize(A, n,m);
  SetLength(Result, n);
  for i := 0 to n-1 do
    Result[i] := A[i, AColIndex];
end;


function MatCopy(A: TDblMatrix): TDblMatrix;
var
  n, m, i, j: Integer;
begin
  MatSize(A, n,m);
  SetLength(Result, n, m);
  for i := 0 to n-1 do
    for j := 0 to m-1 do
      Result[i, j] := A[i, j];
end;


function MatDeterminant(A: TDblMatrix): double;
var
  i, n: integer;
  S: TLUSolver;
  d: Double;
begin
  Result := NaN;
  MatCheck(A);
  MatCheckSquare(A, n);
  S := TLUSolver.Create(A);
  try
    d := S.d;
    for i := 0 to n-1 do
      d := d * S.LU[i, i];
    Result := d;
  finally
    S.Free;
  end;
end;


function MatEqualSize(A, B: TDblMatrix): Boolean;
var
  na, ma, nb, mb: Integer;
begin
  MatSize(A, na, ma);
  MatSize(B, nb, mb);
  Result := (na = ma) and (nb = mb);
end;


{ Exchanges the elements (i1,j1) and (i2,j2) of the matrix A }
procedure MatExchangeElements(A: TDblMatrix; i1,j1, i2,j2: Integer);
var
  tmp: Double;
begin
  tmp := A[i1, j1];
  A[i1, j1] := A[i2, j2];
  A[i2, j2] := tmp;
end;


{ Exchanges the rows i1 and i2 of matrix A }
procedure MatExchangeRows(A: TDblMatrix; i1, i2: Integer);
var
  j, n, m: integer;
begin
  MatSize(A, n,m);
  for j := 0 to m-1 do
    MatExchangeElements(A, i1,j, i2,j);
end;


function MatInverse(A: TDblMatrix): TDblMatrix;
var
  i, j, n: integer;
  S: TLUSolver;
  v: TDblVector;
begin
  MatCheck(A);
  MatCheckSquare(A, n);
  SetLength(Result, n,n);
  SetLength(v, n);

  S := TLUSolver.Create(A);
  try
    for j := 0 to n-1 do
    begin
      for i := 0 to n-1 do
        v[i] := 0.0;
      v[j] := 1.0;
      S.Solve(v);
      for i := 0 to n-1 do Result[i, j] := v[i];
    end;
  finally
    S.Free;
  end;
end;


function MatIsSquare(A: TDblMatrix; out n: Integer): Boolean;
var
  m: Integer;
begin
  MatSize(A, n, m);
  Result := (n = m);
end;


function MatNumCols(A: TDblMatrix): Integer;
var
  n: Integer;
begin
  MatSize(A, n, Result);
end;


function MatNumRows(A: TDblMatrix): Integer;
var
  m: Integer;
begin
  MatSize(A, Result, m);
end;


function MatRowMeans(A: TDblMatrix): TDblVector;
var
  i, j, n, m: Integer;
  sum: Double;
begin
  MatSize(A, n,m);
  SetLength(Result, n);
  for i := 0 to n-1 do
  begin
    sum := 0;
    for j := 0 to m-1 do
      sum := sum + A[i, j];
    Result[i] := sum / m;
  end;
end;


function MatRowVector(A: TDblMatrix; ARowIndex: Integer): TDblVector;
var
  j, n, m: Integer;
begin
  MatSize(A, n,m);
  SetLength(Result, m);
  for j := 0 to m-1 do
    Result[j] := A[ARowIndex, j];
end;


procedure MatSize(A: TDblMatrix; out n, m: Integer);
begin
  n := Length(A);
  m := Length(A[0]);
end;


function MatTransposed(A: TDblMatrix): TDblMatrix;
var
  n, m, i, j: Integer;
begin
  MatCheck(A);
  MatSize(A, n, m);
  SetLength(Result, m, n);
  for i := 0 to n-1 do
    for j := 0 to m-1 do
      Result[j, i] := A[i, j];
end;


{===============================================================================
                                TLUSolver
--------------------------------------------------------------------------------
 Solves the linear system of equations, A x = b by means of LU decomposition.
 Matrix A is passed when the solver is created and it is decomposed in
 upper and lower triangular matrices, A = L * U where L has non-zero elements
 only below, and U only above the diagonal.
 The equation system is is solved by means of the insertion method (Solve).

 Ref:
 Press et al, Numerical Recipies in Pascal
===============================================================================}

constructor TLUSolver.Create(A: TDblMatrix);
var
  n: Integer;
begin
  MatCheckSquare(A, n);
  FLU := MatCopy(A);
  LUDecompose;
end;

                    (*
{ A has been decomposed into the product of two matrices, L*U. L and U are
  saved in a minimal way in the single matrix FLU.
  CreateL creates a new matrix and copies the elements of L to the correct
  position in the result. The product of the two matrices created by CreateL
  and CreateU, is A. }
function TLUSolver.CreateL: TDblMatrix;
var
  n, m, i, j: integer;
begin
  MatrixSize(FLU, n,m);
  SetLength(Result, n, m);
  for i := 0 to n-1 do begin
    for j := 0 to i do begin
      if (i > j) then
        Result[i, j] := FLU[i,j]
      else
      if (i = j) then
        Result[i, j] := 1.0;
    end;
  end;
  for i := 0 to n - 1 do MatExchangeRows(Result, i, FIndex[i]);
end;

{ A has been decomposed into the product of two matrices, L*U. L and U are
  saved in a minimal way in the single matrix FLU.
  CreateU creates a new matrix and copies the elements of U to the correct
  position in the result. The product of the two matrices created by CreateL
  and CreateU, is A. }
function TLUSolver.CreateU: TDblMatrix;
var
  n, m, i, j: integer;
begin
  MatSize(FLU, n,m);
  SetLength(Result, n, m);
  for i := 0 to n-1 do
    for j := i to m-1 do
      if (i <= j) then Result[i,j] := FLU[i,j];
end;
                      *)

{ Executes the LU decompositon. Main procedure of the solver. }
procedure TLUSolver.LUDecompose;
const
  tiny = 1.0e-20;
var
  k, j, imax, i: integer;
  sum, dum, big: float;
  vv: TDblVector;
  n : integer;
begin
  n := MatNumRows(FLU);
  SetLength(vv, n);
  SetLength(FIndex, n);
  d := 1.0;
  for i := 0 to n-1 do       // Scaling information
  begin
    big := 0.0;
    for j := 0 to n-1 do
    begin
      dum := abs(FLU[i, j]);
      if dum > big then big := dum;
    end;
    if big = 0.0 then
      raise EMatrix.Create('Matrix is singular.');
    vv[i] := 1.0 / big;
  end;

  for j := 0 to n-1 do begin
    for i := 0 to j-1 do begin
      sum := FLU[i, j];
      for k := 0 to i-1 do
        sum := sum - FLU[i, k] * FLU[k, j];
      FLU[i, j] := sum;
    end;
    big := 0.0;
    for i := j to n-1 do begin
      sum := FLU[i,j];
      for k := 0 to j-1 do
        sum := sum - FLU[i, k] * FLU[k, j];
      FLU[i, j] := sum;
      dum := vv[i] * abs(sum);
      if dum > big then begin
        big := dum;
        imax := i;
      end;
    end;
    if j <> imax then begin
      for k := 0 to n-1 do begin
        dum := FLU[imax, k];
        FLU[imax, k] := FLU[j, k];
        FLU[j, k] := dum;
      end;
      d := -d;
      vv[imax] := vv[j];
    end;
    FIndex[j] := imax;
    if FLU[j, j]=0.0 then FLU[j, j] := tiny;
    if j <> n-1 then
    begin
      dum := 1.0 / FLU[j, j];
      for i := succ(j) to n-1 do
        FLU[i, j] := FLU[i, j] * dum;
    end;
  end;
end;


{ Solves the equation system A*x = b for x and returns the solution in b.
  A already had been LU-decomposed when the solver was created. This means
  that the method can be reused again and again for different b vectors.
  NOTE: the input b is overwritten by the calculation! }
procedure TLUSolver.Solve(b: TDblVector);
var
  nB, n, m: integer;
  i, ii, ip, j: integer;
  sum: Double;
begin
  nB := Length(b);
  MatSize(FLU, n,m);
  if nB <> n then
    raise EMatrix.Create('TLUSolver: Dimension error.');

  ii := -1;
  for i := 0 to n-1 do
  begin
    ip := FIndex[i];
    sum := b[ip];
    b[ip] := b[i];
    if ii <> -1 then
      for j := ii to pred(i) do
        sum := sum - FLU[i, j] * b[j]
    else
    if (sum <> 0) then
      ii := i;
    b[i] := sum;
  end;

  for i := n-1 downto 0 do
  begin
    sum := b[i];
    for j := succ(i) to n-1 do
      sum := sum - FLU[i, j] * b[j];
    b[i] := sum / FLU[i,i];
  end;
end;


{===============================================================================
                                Sorting
===============================================================================}

procedure Exchange(var a, b: Double);
var
  tmp: Double;
begin
  tmp := a;
  a := b;
  b := tmp;
end;

procedure Exchange(var a, b: Integer);
var
  tmp: Integer;
begin
  tmp := a;
  a := b;
  b := tmp;
end;

procedure Exchange(var a, b: String);
var
  tmp: String;
begin
  tmp := a;
  a := b;
  b := tmp;
end;


procedure SortOnX(X: DblDyneVec; Y: DblDyneVec = nil; Z: DblDyneVec = nil);
var
  i, j, N: Integer;
begin
  N := Length(X);
  if (Y <> nil) and (N <> Length(Y)) then
    raise Exception.Create('[SortOnX] Arrays must have the same length.');
  if (Z <> nil) and (N <> Length(Z)) then
    raise Exception.Create('[SortOnX] Arrays must have the same length.');

  for i := 0 to N - 2 do
  begin
    for j := i + 1 to N - 1 do
    begin
      if X[i] > X[j] then //swap
      begin
        Exchange(X[i], X[j]);
        if Y <> nil then
          Exchange(Y[i], Y[j]);
        if Z <> nil then
          Exchange(Z[i], Z[j]);
      end;
    end;
  end;
end;

// NOTE: The matrix Y is transposed relative to the typical usage in LazStats
procedure SortOnX(X: DblDyneVec; Y: DblDyneMat);
var
  i, j, k, N, Ny: Integer;
begin
  N := Length(X);
  if N <> Length(Y[0]) then
    raise Exception.Create('[SortOnX] Arrays X and Y (2nd index) must have the same length');
  Ny := Length(Y);

  for i := 0 to N-2 do
  begin
    for j := i+1 to N-1 do
      if X[i] > X[j] then
      begin
        Exchange(X[i], X[j]);
        for k := 0 to Ny-1 do
          Exchange(Y[k, i], Y[k, j]);
      end;
  end;
end;

procedure QuickSortOnX(X: DblDyneVec; Y: DblDyneVec = nil; Z: DblDyneVec = nil);

  procedure DoQuickSort(L, R: Integer);
  var
    I,J: Integer;
    P: Integer;
  begin
    repeat
      I := L;
      J := R;
      P := (L+R) div 2;
      repeat
        while CompareValue(X[P], X[I]) > 0 do inc(I);
        while CompareValue(X[P], X[J]) < 0 do dec(J);
        if I <= J then begin
          if I <> J then begin
            Exchange(X[I], X[J]);
            if Y <> nil then
              Exchange(Y[I], Y[J]);
            if Z <> nil then
              Exchange(Z[I], Z[J]);
          end;

          if P = I then
            P := J
          else if P = J then
            P := I;

          inc(I);
          dec(J);
        end;
      until I > J;

      if L < J then
        DoQuickSort(L, J);

      L := I;
    until I >= R;
  end;

begin
  DoQuickSort(0, High(X));
end;


end.