unit ASNum;
{$DEFINE REALCHECK}
{$WARN SYMBOL_PLATFORM OFF}
{$WARN DUPLICATE_CTOR_DTOR OFF}
interface
uses
SysUtils, Types, Math, Generics.Defaults, Generics.Collections, GenHelpers;
threadvar
GTYieldProc: TObjProc;
function AltSgn(const N: Integer): Integer; inline;
type
TInt64Guard = record
class function CanUnMin(const A: Int64): Boolean; static; inline;
class function CanAbs(const A: Int64): Boolean; static; inline;
class function CanAdd(const A, B: Int64): Boolean; static; inline;
class function CanSub(const A, B: Int64): Boolean; static; inline;
class function CanMul(const A, B: Int64): Boolean; static; inline;
class function CanDiv(const A, B: Int64): Boolean; static; inline;
class function CanDivEv(const A, B: Int64): Boolean; static; inline;
class function CanSqr(const A: Int64): Boolean; static; inline;
end;
function SameValue2(const A, B: Extended): Boolean; overload;
function SameValue2(const A, B: Double): Boolean; overload;
function SameValueEx(const A, B: Extended; Epsilon: Extended = 0): Boolean; overload;
function SameValueEx(const A, B: Double; Epsilon: Double = 0): Boolean; overload;
function CreateIntSequence(AStart, AEnd: Integer): TArray<Integer>; overload;
function CreateIntSequence(AStart, AEnd, AStep: Integer): TArray<Integer>; overload;
function CreateIntSequence64(AStart, AEnd: Int64): TArray<Int64>; overload;
function CreateIntSequence64(AStart, AEnd, AStep: Int64): TArray<Int64>; overload;
procedure TranslateIntSequence(var ASeq: TArray<Integer>; const Offset: Integer = -1);
function TranslatedIntSequence(const ASeq: array of Integer; const Offset: Integer = -1): TArray<Integer>;
procedure TranslatePoint(var APoint: TPoint; const Offset: Integer = -1);
function TranslatedPoint(const APoint: TPoint; const Offset: Integer = -1): TPoint;
type
TRange = record
From, &To, Step: Integer;
constructor Create(AFrom, ATo: Integer; AStep: Integer = 1); overload;
constructor Create(ASinglePoint: Integer); overload;
end;
function ParseRangeSeq(const ARanges: array of TRange; const ALength: Integer): TArray<Integer>;
type
EMathException = class(Exception);
{$POINTERMATH ON}
PASR = ^TASR;
{$POINTERMATH OFF}
TASR = Extended;
TASRComparer = class
class var StandardOrder, StandardOrderDescending,
AbsoluteValue, AbsoluteValueDescending: IComparer<TASR>;
class constructor ClassCreate;
end;
TASRArray = TArray<TASR>;
TASR2 = record
X, Y: TASR;
constructor Create(AX, AY: TASR);
end;
TASR3 = packed record
constructor Create(AX, AY, AZ: TASR);
case Boolean of
False:
(Elems: array[0..2] of TASR);
True:
(X, Y, Z: TASR);
end;
TASR4 = packed record
constructor Create(AX, AY, AZ, AW: TASR);
case Boolean of
False:
(Elems: array[0..3] of TASR);
True:
(X, Y, Z, W: TASR);
end;
function IntArrToRealArr(const AArray: TArray<Integer>): TArray<TASR>;
function Int64ArrToRealArr(const AArray: TArray<Int64>): TArray<TASR>;
function IntArrToStrArr(const AArray: TArray<Integer>): TArray<string>;
function Int64ArrToStrArr(const AArray: TArray<Int64>): TArray<string>;
function ASR_COUNT(const A, B: TASR): TASR; inline;
function ASR_PLUS(const A, B: TASR): TASR; inline;
function ASR_TIMES(const A, B: TASR): TASR; inline;
type
TFormatStyle = (fsDefault = 0, fsMonth = 1, fsDayOfWeek = 2, fsMidiInstrument = 3);
TFormatStyleHelper = record helper for TFormatStyle
function ToString: string;
class function FromString(const S: string): TFormatStyle; static;
end;
const
FormatStyleNames: array[TFormatStyle] of string =
('default', 'month', 'day of week', 'MIDI instrument');
type
TNumberFormat = (nfDefault, nfFraction, nfFixed, nfExponent, nfDefExp);
TNumberBase = 2..36;
TNumberBases = set of TNumberBase;
TFormatOptions = record
type
TNumberOptions = record
Base: Byte;
NumberFormat: TNumberFormat;
NumDigits: Word;
MinLength: Byte;
DecimalSeparator: Char;
MinusSign: Char;
IntGrouping: Byte;
IntGropingChar: Char;
FracGrouping: Byte;
FracGroupingChar: Char;
PrettyExp: Boolean;
PreferredBases: TNumberBases;
end;
TComplexOptions = record
ImaginaryUnit: Char;
MultiplicationSign: Char;
PlusSign: Char;
MinusSign: Char;
Spaced: Boolean;
function ImaginarySuffix: string; inline;
function PlusStr: string; inline;
function MinusStr: string; inline;
end;
TVectorOptions = record
MaxLen: Integer;
VerticalUntil: Integer;
BasisChar: Char;
LeftDelim,
ComponentSep,
RightDelim: string;
end;
TStringOptions = record
MaxLen: Integer;
NewLineStr: string;
Quoted: Boolean;
end;
TListOptions = record
MaxLen: Integer;
LeftDelim,
ElementSep,
RightDelim: string;
end;
TStructureOptions = record
AccessSep,
ValueSep,
LeftDelim,
RightDelim,
MemberSep: string;
end;
TSetOptions = record
MaxLen: Integer;
LeftDelim,
ElementSep,
RightDelim,
EmptySetSymbol: string;
end;
var
Numbers: TNumberOptions;
Complex: TComplexOptions;
Vectors: TVectorOptions;
Strings: TStringOptions;
Lists: TListOptions;
Structures: TStructureOptions;
Sets: TSetOptions;
end;
const
DOT_OPERATOR = #$22c5;
PLUS_SIGN = '+';
HYPHEN_MINUS = '-';
MINUS_SIGN = #$2212;
SPACE = #$0020;
FIGURE_SPACE = #$2007;
RETURN_SYMBOL_DAWTL = #$21B2;
DefaultFormatOptions: TFormatOptions =
(
Numbers:
(
Base: 10;
NumberFormat: nfDefault;
NumDigits: 12;
DecimalSeparator: '.';
MinusSign: MINUS_SIGN;
IntGrouping: 0;
IntGropingChar: FIGURE_SPACE;
FracGrouping: 0;
FracGroupingChar: FIGURE_SPACE;
PrettyExp: True;
PreferredBases: [10];
);
Complex:
(
ImaginaryUnit: 'i';
MultiplicationSign: DOT_OPERATOR;
PlusSign: '+';
MinusSign: MINUS_SIGN;
Spaced: True;
);
Vectors:
(
MaxLen: 100;
VerticalUntil: 8;
BasisChar: 'e';
LeftDelim: '(';
ComponentSep: ', ';
RightDelim: ')';
);
Strings:
(
MaxLen: 1000;
NewLineStr: RETURN_SYMBOL_DAWTL;
Quoted: False;
);
Lists:
(
MaxLen: 100;
LeftDelim: '(';
ElementSep: ', ';
RightDelim: ')';
);
Structures:
(
AccessSep: '.';
ValueSep: ': ';
LeftDelim: '(';
RightDelim: ')';
MemberSep: ', ';
);
Sets:
(
MaxLen: 100;
LeftDelim: '{';
ElementSep: ', ';
RightDelim: '}';
EmptySetSymbol: #$2205;
)
);
InputFormOptions: TFormatOptions =
(
Numbers:
(
Base: 10;
NumberFormat: nfDefault;
NumDigits: 18;
DecimalSeparator: '.';
MinusSign: MINUS_SIGN;
IntGrouping: 0;
IntGropingChar: FIGURE_SPACE;
FracGrouping: 0;
FracGroupingChar: FIGURE_SPACE;
PrettyExp: False
);
Complex:
(
ImaginaryUnit: 'i';
MultiplicationSign: DOT_OPERATOR;
PlusSign: '+';
MinusSign: MINUS_SIGN;
Spaced: True;
);
Vectors:
(
MaxLen: MaxInt;
VerticalUntil: 1;
BasisChar: 'e';
LeftDelim: '❨';
ComponentSep: ', ';
RightDelim: '❩';
);
Strings:
(
MaxLen: MaxInt;
NewLineStr: RETURN_SYMBOL_DAWTL;
Quoted: True;
);
Lists:
(
MaxLen: MaxInt;
LeftDelim: '''(';
ElementSep: ', ';
RightDelim: ')';
);
Structures:
(
AccessSep: '.';
ValueSep: ': ';
LeftDelim: 'structure(';
RightDelim: ')';
MemberSep: ', ';
);
Sets:
(
MaxLen: MaxInt;
LeftDelim: '{';
ElementSep: ', ';
RightDelim: '}';
EmptySetSymbol: #$2205;
)
);
ExchangeFormOptions: TFormatOptions =
(
Numbers:
(
Base: 10;
NumberFormat: nfFraction;
NumDigits: 18;
DecimalSeparator: '.';
MinusSign: HYPHEN_MINUS;
IntGrouping: 0;
IntGropingChar: FIGURE_SPACE;
FracGrouping: 0;
FracGroupingChar: FIGURE_SPACE;
PrettyExp: False
);
Complex:
(
ImaginaryUnit: 'i';
MultiplicationSign: DOT_OPERATOR;
PlusSign: '+';
MinusSign: HYPHEN_MINUS;
Spaced: True;
);
Vectors:
(
MaxLen: MaxInt;
VerticalUntil: MaxInt;
BasisChar: 'e';
LeftDelim: '(';
ComponentSep: ', ';
RightDelim: ')';
);
Strings:
(
MaxLen: MaxInt;
NewLineStr: RETURN_SYMBOL_DAWTL;
Quoted: True;
);
Lists:
(
MaxLen: MaxInt;
LeftDelim: '''(';
ElementSep: ', ';
RightDelim: ')';
);
Structures:
(
AccessSep: '.';
ValueSep: ': ';
LeftDelim: '(';
RightDelim: ')';
MemberSep: ', ';
);
Sets:
(
MaxLen: MaxInt;
LeftDelim: '{';
ElementSep: ', ';
RightDelim: '}';
EmptySetSymbol: #$2205;
)
);
function FixNumFmt(const AOptions: TFormatOptions; ANumFmt: TNumberFormat): TFormatOptions;
type
TASRFormatter = function(const AOptions: TFormatOptions; const Val: TASR): string;
PASI = ^TASI;
TASI = Int64;
PRationalNumber = ^TRationalNumber;
TRationalNumber = packed record
Numerator,
Denominator: TASI;
class operator Implicit(A: Integer): TRationalNumber;
class operator Implicit(A: TASI): TRationalNumber;
class operator Implicit(const X: TRationalNumber): TASR; inline;
class operator Negative(const X: TRationalNumber): TRationalNumber;
class operator Add(const X, Y: TRationalNumber): TRationalNumber;
class operator Subtract(const X, Y: TRationalNumber): TRationalNumber;
class operator Multiply(const X, Y: TRationalNumber): TRationalNumber;
class operator Divide(const X, Y: TRationalNumber): TRationalNumber;
class operator Equal(const X, Y: TRationalNumber): Boolean; inline;
class operator NotEqual(const X, Y: TRationalNumber): Boolean; inline;
class function Power(const X: TRationalNumber; const N: TASI): TRationalNumber; static;
constructor Create(const ANumerator, ADenominator: TASI);
procedure ToSimplestForm;
function inv: TRationalNumber;
function sqr: TRationalNumber;
function str: string;
function ToString(const AFormatOptions: TFormatOptions): string; overload;
function ToString(const AFormatOptions: TFormatOptions; const ASymbol: string): string; overload;
function ToDecimalString(const AFormatOptions: TFormatOptions): string;
function valid: Boolean; inline;
function Abs: TRationalNumber;
function Sign: TValueSign; inline;
class procedure ErrNoRep; static;
end;
const
InvalidRat: TRationalNumber = (Numerator: 1; Denominator: 0);
type
TSimpleSymbolicForm = record
A, B: TRationalNumber;
Sym: string;
SymVal: TASR;
constructor Create(const AA, AB: TRationalNumber; const ASym: string; ASymVal: TASR); overload;
constructor Create(pA, qA, pB, qB: TASI; const ASym: string; ASymVal: TASR); overload;
constructor Create(const AA: TRationalNumber); overload;
constructor Create(pA, qA: TASI); overload;
constructor Create(const AB: TRationalNumber; const ASym: string; ASymVal: TASR); overload;
constructor Create(pB, qB: TASI; const ASym: string; ASymVal: TASR); overload;
constructor CreateInvalid(const Val: TASR);
class operator Implicit(const X: TRationalNumber): TSimpleSymbolicForm;
class operator Implicit(const X: TSimpleSymbolicForm): TASR;
class operator Add(const X: TRationalNumber; const Y: TSimpleSymbolicForm): TSimpleSymbolicForm;
class operator Multiply(const X: TRationalNumber; const Y: TSimpleSymbolicForm): TSimpleSymbolicForm;
function str: string;
function sstr: string;
function ToString(const AFormatOptions: TFormatOptions): string;
function valid: Boolean; inline;
procedure MakeInvalid; inline;
end;
TCSimpleSymbolicForm = record
Re,
Im: TSimpleSymbolicForm;
end;
const
Sqrt2 = 1.4142135623730950488016887242096980785696718753769480731766797379;
InvSqrt2 = 1 / Sqrt2;
PiDiv2 = Pi / 2;
PiDiv4 = Pi / 4;
TwoDivPi = 2 / Pi;
TwoPi = 2 * Pi;
SqrtPi = 1.77245385090551602729816748334114518;
SqrtPiInv = 1 / SqrtPi;
Sqrt2Pi = 2.506628274631000502415765284811045253;
Sqrt2PiInv = 1 / 2.506628274631000502415765284811045253;
PiSq = Pi * Pi;
PiCb = Pi * Pi * Pi;
PiInv = 1 / Pi;
PiInvSq = 1 / (Pi * Pi);
EulerConstant = 2.718281828459045235360287471352;
SqrtEulerConstant = 1.6487212707001281468486507878141;
EulerConstantSq = EulerConstant * EulerConstant;
EulerConstantCb = EulerConstant * EulerConstant * EulerConstant;
EulerConstantInv = 1 / EulerConstant;
EulerConstantInvSq = 1 / (EulerConstant * EulerConstant);
GoldenRatio = 1.618033988749894848204586834365638;
GoldenRatioConj = 1 - GoldenRatio;
EulerMascheroni = 0.577215664901532860606512090082;
function IntegerToStr(const x: TASI; const AOptions: TFormatOptions): string;
function RealToStr(const x: TASR; const AOptions: TFormatOptions): string;
function pow(const a, b: TASR): TASR; inline;
function intpow(const a, b: TASI): TASI;
function cbrt(const X: TASR): TASR; inline;
function frt(const X: TASR): TASR; inline;
function tanh(const X: TASR): TASR; inline;
function coth(const X: TASR): TASR; inline;
function sech(const X: TASR): TASR; inline;
function csch(const X: TASR): TASR; inline;
function arcsinh(const X: TASR): TASR; inline;
function arccsch(const X: TASR): TASR; inline;
function sinc(const X: TASR): TASR; inline;
type
{$POINTERMATH ON}
PASC = ^TASC;
{$POINTERMATH OFF}
TASC = packed record
Re, Im: TASR;
class operator Implicit(const r: TASR): TASC;
class operator Positive(const z: TASC): TASC; inline;
class operator Negative(const z: TASC): TASC; inline;
class operator Add(const z1: TASC; const z2: TASC): TASC; inline;
class operator Subtract(const z1: TASC; const z2: TASC): TASC; inline;
class operator Multiply(const z1: TASC; const z2: TASC): TASC; inline;
class operator Divide(const z1: TASC; const z2: TASC): TASC;
class operator Equal(const z1: TASC; const z2: TASC): Boolean; inline;
class operator NotEqual(const z1: TASC; const z2: TASC): Boolean; inline;
class operator Round(const z: TASC): TASC;
class operator Trunc(const z: TASC): TASC;
function Modulus: TASR; inline;
function Argument: TASR; inline;
function Conjugate: TASC; inline;
function Sqr: TASC; inline;
function ModSqr: TASR; inline;
function Inverse: TASC; inline;
function IsReal: Boolean; inline;
function Defuzz(const Eps: Double = 1E-8): TASC;
function str: string;
function pstr: string;
end;
TASCComparer = class
class var ReIm, ReImDescending, Modulus, ModulusDescending, Argument,
ArgumentDescending, ModulusArgument, ModulusArgumentDescending: IComparer<TASC>;
class constructor ClassCreate;
end;
TASCArray = TArray<TASC>;
const
ComplexZero: TASC = (Re: 0; Im: 0);
ImaginaryUnit: TASC = (Re: 0; Im: 1);
ImaginaryUnitDiv2: TASC = (Re: 0; Im : 1/2);
NegativeImaginaryUnit: TASC = (Re: 0; Im: -1);
NegativeImaginaryUnitDiv2: TASC = (Re: 0; Im: -1/2);
function ASC(const Re: TASR; const Im: TASR = 0): TASC; overload; inline;
function ASC_COUNT(const A, B: TASC): TASC; inline;
function ASC_PLUS(const A, B: TASC): TASC; inline;
function ASC_TIMES(const A, B: TASC): TASC; inline;
function ComplexToStr(const z: TASC; ApproxEq: Boolean;
const AOptions: TFormatOptions): string;
function TryStringToComplex(AString: string; out Value: TASC;
ASignRequired: Boolean = False): Boolean;
function CSameValue(const z1, z2: TASC; const Epsilon: TASR = 0): Boolean; overload; inline;
function CSameValueEx(const z1, z2: TASC; const Epsilon: TASR = 0): Boolean; overload; inline;
function CIsZero(const z: TASC; const Epsilon: TASR = 0): Boolean; overload; inline;
function IntegerPowerOfImaginaryUnit(const n: Integer): TASC;
function SameValue2(const A, B: TASC): Boolean; overload; inline;
function CompareValue(const A, B: TASC; Epsilon: Extended = 0): TValueRelationship; overload;
function csign(const z: TASC): TASC; inline;
function cexp(const z: TASC): TASC; inline;
function cln(const z: TASC): TASC; inline;
function clog(const z: TASC): TASC; inline;
function cpow(const z, w: TASC): TASC;
function csqrt(const z: TASC): TASC; inline;
function csin(const z: TASC): TASC; inline;
function ccos(const z: TASC): TASC; inline;
function ctan(const z: TASC): TASC; inline;
function ccot(const z: TASC): TASC; inline;
function csec(const z: TASC): TASC; inline;
function ccsc(const z: TASC): TASC; inline;
function carcsin(const z: TASC): TASC; inline;
function carccos(const z: TASC): TASC; inline;
function carctan(const z: TASC): TASC; inline;
function carccot(const z: TASC): TASC; inline;
function carcsec(const z: TASC): TASC; inline;
function carccsc(const z: TASC): TASC; inline;
function csinh(const z: TASC): TASC; inline;
function ccosh(const z: TASC): TASC; inline;
function ctanh(const z: TASC): TASC; inline;
function ccoth(const z: TASC): TASC; inline;
function csech(const z: TASC): TASC; inline;
function ccsch(const z: TASC): TASC; inline;
function carcsinh(const z: TASC): TASC; inline;
function carccosh(const z: TASC): TASC; inline;
function carctanh(const z: TASC): TASC; inline;
function carccoth(const z: TASC): TASC; inline;
function carcsech(const z: TASC): TASC; inline;
function carccsch(const z: TASC): TASC; inline;
function csinc(const z: TASC): TASC; inline;
type
TIntWithMultiplicity = record
Factor: TASI;
Multiplicity: Integer;
end;
function CollapseWithMultiplicity(const ANumbers: array of TASI): TArray<TIntWithMultiplicity>;
const
intfactorials: array[0..20] of TASI =
(1,
1,
2,
6,
24,
120,
720,
5040,
40320,
362880,
3628800,
39916800,
479001600,
6227020800,
87178291200,
1307674368000,
20922789888000,
355687428096000,
6402373705728000,
121645100408832000,
2432902008176640000);
factorials: array[0..100] of TASR =
(1,
1,
2,
6,
24,
120,
720,
5040,
40320,
362880,
3628800,
39916800,
479001600,
6227020800,
87178291200,
1307674368000,
20922789888000,
355687428096000,
6402373705728000,
121645100408832000,
2.43290200817664E18,
5.109094217170944E19,
1.12400072777760768E21,
2.58520167388849766E22,
6.20448401733239439E23,
1.5511210043330986E25,
4.03291461126605636E26,
1.08888694504183522E28,
3.0488834461171386E29,
8.84176199373970196E30,
2.65252859812191059E32,
8.22283865417792282E33,
2.6313083693369353E35,
8.6833176188118865E36,
2.95232799039604141E38,
1.03331479663861449E40,
3.71993326789901217E41,
1.3763753091226345E43,
5.23022617466601112E44,
2.03978820811974434E46,
8.15915283247897734E47,
3.34525266131638071E49,
1.4050061177528799E51,
6.04152630633738356E52,
2.65827157478844877E54,
1.19622220865480195E56,
5.50262215981208895E57,
2.58623241511168181E59,
1.24139155925360727E61,
6.08281864034267561E62,
3.0414093201713378E64,
1.55111875328738228E66,
8.06581751709438786E67,
4.27488328406002556E69,
2.3084369733924138E71,
1.26964033536582759E73,
7.10998587804863452E74,
4.05269195048772168E76,
2.35056133128287857E78,
1.38683118545689836E80,
8.32098711274139014E81,
5.07580213877224799E83,
3.14699732603879375E85,
1.98260831540444006E87,
1.26886932185884164E89,
8.24765059208247066E90,
5.44344939077443064E92,
3.64711109181886853E94,
2.4800355424368306E96,
1.71122452428141311E98,
1.19785716699698918E100,
8.50478588567862317E101,
6.12344583768860868E103,
4.47011546151268434E105,
3.30788544151938641E107,
2.48091408113953981E109,
1.88549470166605025E111,
1.4518309202828587E113,
1.13242811782062978E115,
8.94618213078297528E116,
7.15694570462638023E118,
5.79712602074736798E120,
4.75364333701284175E122,
3.94552396972065865E124,
3.31424013456535327E126,
2.81710411438055028E128,
2.42270953836727324E130,
2.10775729837952772E132,
1.85482642257398439E134,
1.65079551609084611E136,
1.4857159644817615E138,
1.35200152767840296E140,
1.24384140546413073E142,
1.15677250708164157E144,
1.08736615665674308E146,
1.03299784882390593E148,
9.91677934870949689E149,
9.61927596824821198E151,
9.42689044888324774E153,
9.33262154439441526E155,
9.33262154439441526E157);
type
TRatDigitMode = (rdmSingle, rdmFractional, rdmSignificant, rdmFixedSignificant);
function GetDigit(N: TASI; Index: Integer): Integer; overload;
function GetDigits(N: TASI): TArray<Integer>; overload;
function GetDigit(const R: TRationalNumber; Index: Integer): Integer; overload;
function GetDigits(const R: TRationalNumber; Limit: Integer;
ALimitKind: TRatDigitMode; AFullOutput, ARound: Boolean;
AFirstDigitPos, AFirstSigDigitPos: PInteger): TArray<Integer>; overload;
function GetDigits(const R: TRationalNumber; Limit: Integer;
ALimitKind: TRatDigitMode; AFullOutput, ARound: Boolean;
out AFracDigits: TArray<Integer>): TArray<Integer>; overload;
function GetDigit(X: TASR; Index: Integer): Integer; overload;
function IsInteger(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
function IsIntegerEx(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
function IsInteger32(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
function IsInteger32Ex(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
function IsInteger64(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
function IsInteger64Ex(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
function _fact32(const N: Integer): Integer;
function _fact64(const N: Integer): TASI;
function _factf(const N: Integer): TASR;
function factorial(const N: Integer): TASR;
function combinations(n, k: Integer): TASR;
function intcombinations(n, k: Integer): TASI;
function binomial(const n, k: Integer): TASR; inline;
function permutations(n, k: Integer): TASR;
function intpermutations(n, k: Integer): TASI;
function lcm(const A, B: TASI): TASI; overload;
function lcm(const A, B: UInt64): UInt64; overload;
function TryLCM(const A, B: TASI; var LCM: TASI): Boolean;
function lcm(const Values: array of TASI): TASI; overload;
function gcd(const A, B: TASI): TASI; overload;
function gcd(const A, B: UInt64): UInt64; overload;
function gcd(const Values: array of TASI): TASI; overload;
function coprime(const A, B: TASI): Boolean; inline;
function NaiveTotient(const N: Integer): Integer;
function totient(const N: Integer): Integer;
function cototient(const N: Integer): Integer; inline;
function IsPrime(const N: TASI): Boolean;
function NthPrime(N: Integer): Integer;
function NextPrime(const N: TASI): TASI;
function PreviousPrime(const N: TASI): TASI;
function ExpandPrimeCache(N: Integer): Boolean;
procedure ClearPrimeCache;
function GetPrimeCacheMax: Integer;
function GetPrimeCacheSizeBytes: Integer;
function IsCarolNumber(N: TASI): Boolean;
type
TTSFPrio = (tsfpSimplest, tsfpMostExact);
function PrimePi(const N: Integer): Integer;
const
IntPrimorials: array[0..52] of TASI =
(
1,
1,
2,
6,
6,
30,
30,
210,
210,
210,
210,
2310,
2310,
30030,
30030,
30030,
30030,
510510,
510510,
9699690,
9699690,
9699690,
9699690,
223092870,
223092870,
223092870,
223092870,
223092870,
223092870,
6469693230,
6469693230,
200560490130,
200560490130,
200560490130,
200560490130,
200560490130,
200560490130,
7420738134810,
7420738134810,
7420738134810,
7420738134810,
304250263527210,
304250263527210,
13082761331670030,
13082761331670030,
13082761331670030,
13082761331670030,
614889782588491410,
614889782588491410,
614889782588491410,
614889782588491410,
614889782588491410,
614889782588491410
);
function Primorial(const N: Integer): TASR;
const
IntFibonaccis: array[0..92] of TASI =
(
0,
1,
1,
2,
3,
5,
8,
13,
21,
34,
55,
89,
144,
233,
377,
610,
987,
1597,
2584,
4181,
6765,
10946,
17711,
28657,
46368,
75025,
121393,
196418,
317811,
514229,
832040,
1346269,
2178309,
3524578,
5702887,
9227465,
14930352,
24157817,
39088169,
63245986,
102334155,
165580141,
267914296,
433494437,
701408733,
1134903170,
1836311903,
2971215073,
4807526976,
7778742049,
12586269025,
20365011074,
32951280099,
53316291173,
86267571272,
139583862445,
225851433717,
365435296162,
591286729879,
956722026041,
1548008755920,
2504730781961,
4052739537881,
6557470319842,
10610209857723,
17167680177565,
27777890035288,
44945570212853,
72723460248141,
117669030460994,
190392490709135,
308061521170129,
498454011879264,
806515533049393,
1304969544928657,
2111485077978050,
3416454622906707,
5527939700884757,
8944394323791464,
14472334024676221,
23416728348467685,
37889062373143906,
61305790721611591,
99194853094755497,
160500643816367088,
259695496911122585,
420196140727489673,
679891637638612258,
1100087778366101931,
1779979416004714189,
2880067194370816120,
4660046610375530309,
7540113804746346429
);
function Fibonacci(const N: Integer): TASR;
const
IntLucas: array[0..90] of TASI =
(
2,
1,
3,
4,
7,
11,
18,
29,
47,
76,
123,
199,
322,
521,
843,
1364,
2207,
3571,
5778,
9349,
15127,
24476,
39603,
64079,
103682,
167761,
271443,
439204,
710647,
1149851,
1860498,
3010349,
4870847,
7881196,
12752043,
20633239,
33385282,
54018521,
87403803,
141422324,
228826127,
370248451,
599074578,
969323029,
1568397607,
2537720636,
4106118243,
6643838879,
10749957122,
17393796001,
28143753123,
45537549124,
73681302247,
119218851371,
192900153618,
312119004989,
505019158607,
817138163596,
1322157322203,
2139295485799,
3461452808002,
5600748293801,
9062201101803,
14662949395604,
23725150497407,
38388099893011,
62113250390418,
100501350283429,
162614600673847,
263115950957276,
425730551631123,
688846502588399,
1114577054219522,
1803423556807921,
2918000611027443,
4721424167835364,
7639424778862807,
12360848946698171,
20000273725560978,
32361122672259149,
52361396397820127,
84722519070079276,
137083915467899403,
221806434537978679,
358890350005878082,
580696784543856761,
939587134549734843,
1520283919093591604,
2459871053643326447,
3980154972736918051,
6440026026380244498
);
function Lucas(const N: Integer): TASR;
function Floor64(const X: TASR): TASI;
function Ceil64(const X: TASR): TASI;
function imod(const x, y: Integer): Integer; overload; inline;
function imod(const x, y: TASI): TASI; overload; inline;
function rmod(const x, y: TASR): TASR; inline;
function modulo(const x, y: Integer): Integer; overload; inline;
function modulo(const x, y: TASR): TASR; overload; inline;
function PrimeFactors(const N: TASI; AOnlyUnique: Boolean = False): TArray<TASI>;
function PrimeFactorsWithMultiplicity(N: TASI): TArray<TIntWithMultiplicity>;
function Radical(N: TASI): TASI;
function IsSquareFree(N: TASI): Boolean;
function factorize(const N: TASI): TArray<TASI>;
function GetFactorizedString(const N: TASI; AMinusSign: Char = '-';
AMultiplicationSign: Char = '*'; ASpace: Boolean = False): string; overload;
function GetFactorizedString(const N: TASI; AFancy: Boolean): string; overload;
function divisors(const N: TASI): TArray<TASI>;
procedure FactorAsSquareAsPossible(const N: Integer; out A, B: Integer);
function MöbiusMu(const N: TASI): Integer;
function Mertens(const N: TASI): Integer;
function RationalNumber(const ANumerator, ADenominator: TASI): TRationalNumber;
function ToFraction(const X: TASR): TRationalNumber;
function ToSymbolicForm(const X: TASR; APriority: TTSFPrio = tsfpSimplest): TSimpleSymbolicForm;
function CToSymbolicForm(const z: TASC; APriority: TTSFPrio = tsfpSimplest): TCSimpleSymbolicForm;
function IversonBracket(b: Boolean): Integer; inline;
function KroneckerDelta(i, j: Integer): Integer; overload; inline;
function KroneckerDelta(i, j: TASI): Integer; overload; inline;
function LegendreSymbol(a, p: TASI): Integer;
function JacobiSymbol(a, n: TASI): Integer;
function KroneckerSymbol(a, n: TASI): Integer;
function ContinuedFraction(x: TASR; maxlen: Integer = 18): TArray<TASI>; overload;
function ContinuedFraction(const x: TRationalNumber): TArray<TASI>; overload;
function ContinuedFractionToFraction(const AContinuedFraction: TArray<TASI>): TRationalNumber;
function Heaviside(const X: TASR): TASR; inline;
function Ramp(const X: TASR): TASR; inline;
function Rectfcn(const X: TASR): TASR; inline;
function Tri(const X: TASR): TASR; inline;
function SquareWaveUnit(const X: TASR): TASR;
function SquareWave(const X: TASR): TASR; inline;
function TriangleWaveUnit(const X: TASR): TASR;
function TriangleWave(const X: TASR): TASR; inline;
function SawtoothWaveUnit(const X: TASR): TASR;
function SawtoothWave(const X: TASR): TASR; inline;
type
TRealFunction = function(const X: TASR): TASR;
TComplexFunction = function(const z: TASC): TASC;
TRealFunctionRef = reference to function(const X: TASR): TASR;
TComplexFunctionRef = reference to function(const z: TASC): TASC;
function differentiate(AFunction: TRealFunctionRef; const X: TASR;
const ε: TASR = 1E-6): TASR;
type
TIntegrationParams = record
constructor N(const AN: Integer);
constructor Delta(const ADelta: TASR);
case FixedDelta: Boolean of
False: (FN: Integer);
True: (FDelta: TASR);
end;
const
DefaultIntegrationParams: TIntegrationParams =
(FixedDelta: True; FDelta: 8E-7);
function integrate(AFunction: TRealFunctionRef; a, b: TASR;
const AParams: TIntegrationParams): TASR; overload;
function integrate(AFunction: TRealFunctionRef; a, b: TASR): TASR; overload;
function integrate(AFunction: TComplexFunctionRef; a, b: TASR;
const AParams: TIntegrationParams): TASC; overload;
function integrate(AFunction: TComplexFunctionRef; a, b: TASR): TASC; overload;
type
TIntegrationCacheItem = record
X, Val: TASR;
constructor Create(AX: TASR; AVal: TASR = NaN);
end;
PIntegrationCache = ^TIntegrationCache;
TIntegrationCache = array of TIntegrationCacheItem;
function FillIntegrationCache(AFunction: TRealFunctionRef; a, b: TASR;
const CacheDelta: TASR;
var Cache: TIntegrationCache;
const AParams: TIntegrationParams): TASR; overload;
function FillIntegrationCache(AFunction: TRealFunctionRef; a, b: TASR;
const CacheDelta: TASR;
var Cache: TIntegrationCache): TASR; overload;
procedure StepwiseIntegrationCacheFill(AIntegrand: TRealFunctionRef;
var ACache: TIntegrationCache; ACacheDelta: TASR; const Steps: array of TASR;
const x: TASR; const a: TASR = 0); overload;
procedure StepwiseIntegrationCacheFill(AIntegrand: TRealFunctionRef;
var ACache: TIntegrationCache; ACacheDelta: TASR; const Steps: array of TASR;
const x: TASR; const AParams: TIntegrationParams; const a: TASR = 0); overload;
function ClearIntegrationCache(var ACache: TIntegrationCache): Integer;
function GetIntegrationCacheSize(const ACache: TIntegrationCache): Integer;
function CachedIntegration(AFunction: TRealFunctionRef; a, b: TASR;
const ACache: TIntegrationCache;
const AParams: TIntegrationParams): TASR; overload;
function CachedIntegration(AFunction: TRealFunctionRef; a, b: TASR;
const ACache: TIntegrationCache): TASR; overload;
type
TSequence<T> = reference to function(N: Integer): T;
TPredicate<T> = reference to function(const X: T): Boolean;
TAccumulator<T> = reference to function(const AccumulatedValue, NewValue: T): T;
function sum(const Vals: array of TASI): TASI; overload;
function product(const Vals: array of TASI): TASI; overload;
function accumulate(AFunction: TSequence<TASR>; a, b: Integer;
AStart: TASR; AAccumulator: TAccumulator<TASR>): TASR; overload;
function accumulate(AFunction: TSequence<TASC>; a, b: Integer;
AStart: TASC; AAccumulator: TAccumulator<TASC>): TASC; overload;
function sum(AFunction: TSequence<TASR>; a, b: Integer): TASR; overload;
function sum(AFunction: TSequence<TASC>; a, b: Integer): TASC; overload;
function ArithmeticMean(AFunction: TSequence<TASR>; a, b: Integer): TASR; overload;
function ArithmeticMean(AFunction: TSequence<TASC>; a, b: Integer): TASC; overload;
function GeometricMean(AFunction: TSequence<TASR>; a, b: Integer): TASR; overload;
function GeometricMean(AFunction: TSequence<TASC>; a, b: Integer): TASC; overload;
function HarmonicMean(AFunction: TSequence<TASR>; a, b: Integer): TASR; overload;
function HarmonicMean(AFunction: TSequence<TASC>; a, b: Integer): TASC; overload;
function product(AFunction: TSequence<TASR>; a, b: Integer): TASR; overload;
function product(AFunction: TSequence<TASC>; a, b: Integer): TASC; overload;
function max(AFunction: TSequence<TASR>; a, b: Integer): TASR; overload;
function min(AFunction: TSequence<TASR>; a, b: Integer): TASR; overload;
function exists(AFunction: TSequence<TASR>; a, b: Integer;
APredicate: TPredicate<TASR>): Boolean; overload;
function count(AFunction: TSequence<TASR>; a, b: Integer;
APredicate: TPredicate<TASR>): Integer; overload;
function count(AFunction: TSequence<TASR>; a, b: Integer;
AValue: TASR): Integer; overload;
function ForAll(AFunction: TSequence<TASR>; a, b: Integer;
APredicate: TPredicate<TASR>): Boolean; overload;
function contains(AFunction: TSequence<TASR>; a, b: Integer;
const AValue: TASR): Boolean; overload;
function exists(AFunction: TSequence<TASC>; a, b: Integer;
APredicate: TPredicate<TASC>): Boolean; overload;
function count(AFunction: TSequence<TASC>; a, b: Integer;
APredicate: TPredicate<TASC>): Integer; overload;
function count(AFunction: TSequence<TASC>; a, b: Integer;
AValue: TASC): Integer; overload;
function ForAll(AFunction: TSequence<TASC>; a, b: Integer;
APredicate: TPredicate<TASC>): Boolean; overload;
function contains(AFunction: TSequence<TASC>; a, b: Integer;
const AValue: TASC): Boolean; overload;
function GetSpecialFunctionsIntegrationCacheSize: Integer;
procedure ClearSpecialFunctionsIntegrationCaches;
function erf(const X: TASR): TASR;
function erfc(const X: TASR): TASR; inline;
function FresnelC(const X: TASR): TASR;
function FresnelS(const X: TASR): TASR;
function Si(const X: TASR): TASR;
function Ci(const X: TASR): TASR;
function Li(const X: TASR): TASR;
function LiFrom2(const X: TASR): TASR;
function Bessel(N: Integer; const X: TASR;
const AParams: TIntegrationParams): TASR; overload;
function Bessel(N: Integer; const X: TASR): TASR; overload; inline;
function Bessel(N: Integer; const z: TASC;
const AParams: TIntegrationParams): TASC; overload;
function Bessel(N: Integer; const z: TASC): TASC; overload; inline;
function Laguerre(N: Integer; const X: TASR): TASR; overload;
function Laguerre(N: Integer; const z: TASC): TASC; overload;
function Hermite(N: Integer; const X: TASR): TASR; overload;
function Hermite(N: Integer; const z: TASC): TASC; overload;
function Legendre(N: Integer; const X: TASR): TASR; overload;
function Legendre(N: Integer; const z: TASC): TASC; overload;
function GammaFunction(const X: TASR): TASR; overload;
function GammaFunction(const z: TASC): TASC; overload;
function Chebyshev(N: Integer; const X: TASR): TASR; overload;
function Chebyshev(N: Integer; const z: TASC): TASC; overload;
function Bernstein(I, N: Integer; const X: TASR): TASR; overload; inline;
function Bernstein(I, N: Integer; const z: TASC): TASC; overload; inline;
function HarmonicNumber(const N: TASI): TASR;
type
TRealVector = record
strict private
FComponents: TASRArray;
function GetDimension: Integer; inline;
procedure SetDimension(const Value: Integer); inline;
function GetComponent(Index: Integer): TASR; inline;
procedure SetComponent(Index: Integer; const Value: TASR); inline;
public
constructor Create(const Components: array of TASR); overload;
constructor Create(ASize: Integer; const AVal: TASR = 0); overload;
property Components[Index: Integer]: TASR read GetComponent write SetComponent; default;
property Dimension: Integer read GetDimension write SetDimension;
property Data: TASRArray read FComponents write FComponents;
function ToIntegerArray: TArray<Integer>;
class operator Negative(const u: TRealVector): TRealVector;
class operator Add(const u: TRealVector; const v: TRealVector): TRealVector;
class operator Add(const u: TRealVector; const x: TASR): TRealVector;
class operator Subtract(const u: TRealVector; const v: TRealVector): TRealVector;
class operator Subtract(const u: TRealVector; const x: TASR): TRealVector;
class operator Multiply(const u: TRealVector; const v: TRealVector): TASR;
class operator Multiply(const x: TASR; const u: TRealVector): TRealVector;
class operator Multiply(const u: TRealVector; const x: TASR): TRealVector;
class operator Divide(const u: TRealVector; const x: TASR): TRealVector;
class operator Equal(const u: TRealVector; const v: TRealVector): Boolean;
class operator NotEqual(const u: TRealVector; const v: TRealVector): Boolean; inline;
class operator LeftShift(const u: TRealVector; Val: Integer): TRealVector;
class operator RightShift(const u: TRealVector; Val: Integer): TRealVector;
class operator Trunc(const u: TRealVector): TRealVector;
class operator Round(const u: TRealVector): TRealVector;
class operator LessThan(const u, v: TRealVector): Boolean; inline;
class operator LessThanOrEqual(const u, v: TRealVector): Boolean; inline;
class operator GreaterThan(const u, v: TRealVector): Boolean; inline;
class operator GreaterThanOrEqual(const u, v: TRealVector): Boolean; inline;
function IsZeroVector(const Epsilon: Extended = 0): Boolean;
procedure Normalize;
procedure NormalizeIfNonzero;
function Normalized: TRealVector;
function NormalizedIfNonzero: TRealVector; inline;
function Norm: TASR; inline;
function NormSqr: TASR; inline;
function pNorm(const p: TASR): TASR;
function MaxNorm: TASR; inline;
function SumNorm: TASR; inline;
function kNorm(k: Integer): TASR;
function IsPositive(const Epsilon: Extended = 0): Boolean;
function IsNonNegative(const Epsilon: Extended = 0): Boolean;
function IsNegative(const Epsilon: Extended = 0): Boolean;
function IsNonPositive(const Epsilon: Extended = 0): Boolean;
function Abs: TRealVector;
procedure Append(const AValue: TASR); inline;
procedure ExtendWith(const AValue: TRealVector); inline;
procedure Insert(AIndex: Integer; const AValue: TASR); inline;
procedure Remove(const AIndices: array of Integer);
procedure Swap(AIndex1, AIndex2: Integer); inline;
function TruncateAt(ALength: Integer): TRealVector;
function Reduce(AStep: Integer): TRealVector;
function Clone: TRealVector;
function Subvector(AFrom, ATo: Integer): TRealVector; overload;
function Subvector(const AIndices: array of Integer): TRealVector; overload;
function Sort: TRealVector; overload;
function Sort(AComparer: IComparer<TASR>): TRealVector; overload;
function SafeSort(AComparer: IComparer<TASR>): TRealVector; overload;
function ReverseSort: TRealVector; inline;
function Shuffle: TRealVector;
function Unique: TRealVector;
function UniqueAdj: TRealVector;
function UniqueEps(const Epsilon: TASR = 0): TRealVector;
function UniqueAdjEps(const Epsilon: TASR = 0): TRealVector;
function Reverse: TRealVector;
function Apply(AFunction: TRealFunctionRef): TRealVector;
function Filter(APredicate: TPredicate<TASR>): TRealVector;
function Replace(APredicate: TPredicate<TASR>; const ANewValue: TASR): TRealVector; overload;
function Replace(const AOldValue, ANewValue: TASR; const Epsilon: Extended = 0): TRealVector; overload;
function Replace(const ANewValue: TASR): TRealVector; overload;
procedure RemoveFirst(N: Integer);
function Defuzz(const Eps: Double = 1E-8): TRealVector;
function str(const AOptions: TFormatOptions): string;
end;
function ASC(const u: TRealVector): TASC; overload; inline;
function ASR2(const u1, u2: TASR): TRealVector; overload; inline;
function ASR2(const z: TASC): TRealVector; overload; inline;
function ASR3(const u1, u2, u3: TASR): TRealVector; inline;
function ASR4(const u1, u2, u3, u4: TASR): TRealVector; inline;
function ASR5(const u1, u2, u3, u4, u5: TASR): TRealVector; inline;
function ZeroVector(const Dimension: Integer): TRealVector; inline;
function RandomVector(const Dimension: Integer): TRealVector;
function RandomIntVector(const Dimension, A, B: Integer): TRealVector;
function RandomVectorWithSigns(const Dimension: Integer): TRealVector;
function SequenceVector(ALen: Integer; AStart: TASR = 1; AStep: TASR = 1): TRealVector;
function UnitVector(ADim, AIndex: Integer): TRealVector;
function SameVector(const u, v: TRealVector; const Epsilon: Extended = 0): Boolean; overload;
function SameVectorEx(const u, v: TRealVector; const Epsilon: Extended = 0): Boolean; overload;
function AreParallel(const u, v: TRealVector; Epsilon: Extended = 0): Boolean; overload;
function ArePerpendicular(const u, v: TRealVector; const Epsilon: Extended = 0): Boolean; overload; inline;
function accumulate(const u: TRealVector; const AStart: TASR;
AFunc: TAccumulator<TASR>): TASR; overload;
function sum(const u: TRealVector): TASR; overload;
function ArithmeticMean(const u: TRealVector): TASR; overload; inline;
function GeometricMean(const u: TRealVector): TASR; overload;
function HarmonicMean(const u: TRealVector): TASR; overload;
function product(const u: TRealVector): TASR; overload;
function max(const u: TRealVector): TASR; overload;
function min(const u: TRealVector): TASR; overload;
function exists(const u: TRealVector; APredicate: TPredicate<TASR>): Boolean; overload;
function count(const u: TRealVector; APredicate: TPredicate<TASR>): Integer; overload;
function count(const u: TRealVector; const AValue: TASR): Integer; overload;
function ForAll(const u: TRealVector; APredicate: TPredicate<TASR>): Boolean; overload;
function contains(const u: TRealVector; const AValue: TASR;
const AEpsilon: TASR = 0; ALen: Integer = -1): Boolean; overload;
function CrossProduct(const u, v: TRealVector): TRealVector; overload;
function angle(const u, v: TRealVector): TASR; overload;
function VectConcat(const u, v: TRealVector): TRealVector; overload;
type
TComplexVector = record
strict private
FComponents: TASCArray;
function GetDimension: Integer; inline;
procedure SetDimension(const Value: Integer); inline;
function GetComponent(Index: Integer): TASC; inline;
procedure SetComponent(Index: Integer; const Value: TASC); inline;
public
constructor Create(const Components: array of TASC); overload;
constructor Create(ASize: Integer; const AVal: TASC); overload;
property Components[Index: Integer]: TASC read GetComponent write SetComponent; default;
property Dimension: Integer read GetDimension write SetDimension;
property Data: TASCArray read FComponents write FComponents;
class operator Implicit(const u: TRealVector): TComplexVector;
class operator Negative(const u: TComplexVector): TComplexVector;
class operator Add(const u: TComplexVector; const v: TComplexVector): TComplexVector;
class operator Add(const u: TComplexVector; const z: TASC): TComplexVector;
class operator Subtract(const u: TComplexVector; const v: TComplexVector): TComplexVector;
class operator Subtract(const u: TComplexVector; const z: TASC): TComplexVector;
class operator Multiply(const u: TComplexVector; const v: TComplexVector): TASC;
class operator Multiply(const z: TASC; const u: TComplexVector): TComplexVector;
class operator Multiply(const u: TComplexVector; const z: TASC): TComplexVector;
class operator Divide(const u: TComplexVector; const z: TASC): TComplexVector;
class operator Equal(const u: TComplexVector; const v: TComplexVector): Boolean;
class operator NotEqual(const u: TComplexVector; const v: TComplexVector): Boolean; inline;
class operator LeftShift(const u: TComplexVector; Val: Integer): TComplexVector;
class operator RightShift(const u: TComplexVector; Val: Integer): TComplexVector;
class operator Round(const u: TComplexVector): TComplexVector;
function IsZeroVector(const Epsilon: Extended = 0): Boolean;
procedure Normalize;
procedure NormalizeIfNonzero;
function Normalized: TComplexVector;
function NormalizedIfNonzero: TComplexVector;
function Norm: TASR; inline;
function NormSqr: TASR; inline;
function pNorm(const p: TASR): TASR;
function MaxNorm: TASR; inline;
function SumNorm: TASR; inline;
function kNorm(k: Integer): TASR;
function Abs: TRealVector;
procedure Append(const AValue: TASC); inline;
procedure ExtendWith(const AValue: TComplexVector); inline;
procedure Insert(AIndex: Integer; const AValue: TASC); inline;
procedure Remove(const AIndices: array of Integer);
procedure Swap(AIndex1, AIndex2: Integer); inline;
function TruncateAt(ALength: Integer): TComplexVector;
function Reduce(AStep: Integer): TComplexVector;
function Clone: TComplexVector;
function Subvector(AFrom, ATo: Integer): TComplexVector; overload;
function Subvector(const AIndices: array of Integer): TComplexVector; overload;
function Sort(AComparer: IComparer<TASC>): TComplexVector;
function SafeSort(AComparer: IComparer<TASC>): TComplexVector;
function Shuffle: TComplexVector;
function Unique: TComplexVector;
function UniqueAdj: TComplexVector;
function UniqueEps(const Epsilon: TASR = 0): TComplexVector;
function UniqueAdjEps(const Epsilon: TASR = 0): TComplexVector;
function Reverse: TComplexVector;
function Apply(AFunction: TComplexFunctionRef): TComplexVector;
function Filter(APredicate: TPredicate<TASC>): TComplexVector;
function Replace(APredicate: TPredicate<TASC>;
const ANewValue: TASC): TComplexVector; overload;
function Replace(const AOldValue, ANewValue: TASC;
const Epsilon: Extended = 0): TComplexVector; overload;
function Replace(const ANewValue: TASC): TComplexVector; overload;
function RealPart: TRealVector;
function ImaginaryPart: TRealVector;
procedure RemoveFirst(N: Integer);
function Defuzz(const Eps: Double = 1E-8): TComplexVector;
function str(const AOptions: TFormatOptions): string;
function IsReal: Boolean;
end;
function ASC2(const u1, u2: TASC): TComplexVector; inline;
function ASC3(const u1, u2, u3: TASC): TComplexVector; inline;
function ASC4(const u1, u2, u3, u4: TASC): TComplexVector; inline;
function ASC5(const u1, u2, u3, u4, u5: TASC): TComplexVector; inline;
function ComplexZeroVector(const Dimension: Integer): TComplexVector; inline;
function SameVector(const u, v: TComplexVector; const Epsilon: Extended = 0): Boolean; overload;
function SameVectorEx(const u, v: TComplexVector; const Epsilon: Extended = 0): Boolean; overload;
function AreParallel(const u, v: TComplexVector; Epsilon: Extended = 0): Boolean; overload;
function ArePerpendicular(const u, v: TComplexVector; const Epsilon: Extended = 0): Boolean; overload; inline;
function accumulate(const u: TComplexVector; const AStart: TASC;
AFunc: TAccumulator<TASC>): TASC; overload;
function sum(const u: TComplexVector): TASC; overload;
function ArithmeticMean(const u: TComplexVector): TASC; overload; inline;
function GeometricMean(const u: TComplexVector): TASC; overload;
function HarmonicMean(const u: TComplexVector): TASC; overload;
function product(const u: TComplexVector): TASC; overload;
function exists(const u: TComplexVector; APredicate: TPredicate<TASC>): Boolean; overload;
function count(const u: TComplexVector; APredicate: TPredicate<TASC>): Integer; overload;
function count(const u: TComplexVector; const AValue: TASC): Integer; overload;
function ForAll(const u: TComplexVector; APredicate: TPredicate<TASC>): Boolean; overload;
function contains(const u: TComplexVector; const AValue: TASC;
const AEpsilon: TASR = 0; ALen: Integer = -1): Boolean; overload;
function CrossProduct(const u, v: TComplexVector): TComplexVector; overload;
function angle(const u, v: TComplexVector): TASR; overload;
function VectConcat(const u, v: TComplexVector): TComplexVector; overload;
const
INFTY = High(Integer);
type
TDuplicateFinder<T> = record
class function ContainsDuplicates(Arr: array of T): Boolean; static;
class function PresortedContainsDuplicates(const Arr: array of T): Boolean; static;
end;
TMatrixSize = record
strict private
FRows, FCols: Integer;
private
constructor CreateUnsafe(Rows, Cols: Integer); overload;
function LessenedSize: TMatrixSize; inline;
public
constructor Create(Rows, Cols: Integer); overload;
constructor Create(Size: Integer); overload;
property Rows: Integer read FRows;
property Cols: Integer read FCols;
function ElementCount: Integer; inline;
function SmallestDimension: Integer; inline;
function TransposeSize: TMatrixSize; inline;
function IsSquare: Boolean; inline;
class operator Implicit(S: Integer): TMatrixSize;
class operator Implicit(const ASize: TSize): TMatrixSize;
class operator Implicit(const AMatrixSize: TMatrixSize): TSize;
class operator Equal(const S1, S2: TMatrixSize): Boolean; inline;
class operator NotEqual(const S1, S2: TMatrixSize): Boolean; inline;
class operator Add(const S1, S2: TMatrixSize): TMatrixSize;
end;
const
Mat1x1: TMatrixSize = (FRows: 1; FCols: 1);
Mat2x1: TMatrixSize = (FRows: 2; FCols: 1);
Mat3x1: TMatrixSize = (FRows: 3; FCols: 1);
Mat2x2: TMatrixSize = (FRows: 2; FCols: 2);
Mat3x3: TMatrixSize = (FRows: 3; FCols: 3);
Mat4x4: TMatrixSize = (FRows: 4; FCols: 4);
type
TRowOperationType = (roSwap, roScale, roAddMul);
TMatrixIndexFunction<T> = reference to function(Row, Col: Integer): T;
TIndexArray = array of Integer;
function __sign(const P: TIndexArray): Integer;
type
TRealRowOperationRecord = record
RowOperationType: TRowOperationType;
Row1, Row2: Integer;
Factor: TASR;
end;
TRealRowOpSequence = array of TRealRowOperationRecord;
TRealMatrix = record
strict private
const
InitialRowOpSeqSize = 16;
var
FSize: TMatrixSize;
FElements: TASRArray;
FRowOpSeq: TRealRowOpSequence;
FRowOpCount: Integer;
FRowOpFactor: TASR;
_FCollectRowOpData: Boolean;
procedure SetSize(const Value: TMatrixSize);
function GetElement(Row, Col: Integer): TASR; inline;
procedure SetElement(Row, Col: Integer; const Value: TASR); inline;
function GetRow(ARow: Integer): TRealVector;
function GetCol(ACol: Integer): TRealVector;
procedure _DoSetRow(ARowIndex: Integer; const ARow: TRealVector);
procedure _DoSetCol(AColIndex: Integer; const ACol: TRealVector);
function GetFirstCol: TRealVector; inline;
procedure SetFirstCol(const ACol: TRealVector); inline;
function GetLastCol: TRealVector; inline;
procedure SetLastCol(const ACol: TRealVector); inline;
function GetMainDiagonal: TRealVector;
procedure SetMainDiagonal(const ADiagonal: TRealVector);
function GetSuperDiagonal: TRealVector;
procedure SetSuperDiagonal(const ADiagonal: TRealVector);
function GetSubDiagonal: TRealVector;
procedure SetSubDiagonal(const ADiagonal: TRealVector);
function GetAntiDiagonal: TRealVector;
procedure SetAntiDiagonal(const ADiagonal: TRealVector);
procedure Alloc(ARows, ACols: Integer); overload;
procedure Alloc(ASize: Integer); overload;
procedure Alloc(const ASize: TMatrixSize); overload;
function GetRowData(AIndex: Integer): PASR; inline;
function SafeGetRowData(AIndex: Integer): PASR;
function GetMemorySize: Int64;
procedure BeginCollectRowOpData;
procedure AddRowOpRecord(AType: TRowOperationType; ARow1, ARow2: Integer;
AFactor: TASR = 0);
procedure GetHouseholderMap(const AVect: TRealVector;
out tau, gamma: TASR; out u: TRealVector);
function Eigenvalues2x2: TComplexVector;
private
constructor CreateWithoutAllocation(const ASize: TMatrixSize);
function IsEmpty: Boolean; inline;
procedure DoQuickLU(out A: TRealMatrix; out P: TIndexArray);
procedure RequireNonEmpty; inline;
public
constructor CreateUninitialized(const ASize: TMatrixSize);
constructor Create(const AMatrix: TRealMatrix); overload;
constructor Create(const Elements: array of TASRArray); overload;
constructor Create(const Elements: array of TASR; Cols: Integer = 1); overload;
constructor Create(const ASize: TMatrixSize; const AVal: TASR = 0); overload;
constructor CreateFromRows(const Rows: array of TRealVector);
constructor CreateFromColumns(const Columns: array of TRealVector);
constructor Create(const u, v: TRealVector); overload;
constructor Create(const ASize: TMatrixSize;
AFunction: TMatrixIndexFunction<TASR>); overload;
constructor CreateDiagonal(const Elements: array of TASR); overload;
constructor CreateDiagonal(const Elements: TRealVector); overload;
constructor CreateDiagonal(ASize: Integer; AVal: TASR = 1); overload;
constructor Create(const Blocks: array of TRealMatrix; Cols: Integer = 2); overload;
property Size: TMatrixSize read FSize write SetSize;
property Elements[Row, Col: Integer]: TASR read GetElement write SetElement; default;
property Rows[Index: Integer]: TRealVector read GetRow write _DoSetRow;
property Cols[Index: Integer]: TRealVector read GetCol write _DoSetCol;
property FirstColumn: TRealVector read GetFirstCol write SetFirstCol;
property LastColumn: TRealVector read GetLastCol write SetLastCol;
property MainDiagonal: TRealVector read GetMainDiagonal write SetMainDiagonal;
property SuperDiagonal: TRealVector read GetSuperDiagonal write SetSuperDiagonal;
property SubDiagonal: TRealVector read GetSubDiagonal write SetSubDiagonal;
property AntiDiagonal: TRealVector read GetAntiDiagonal write SetAntiDiagonal;
property Data: TASRArray read FElements write FElements;
property RowData[Index: Integer]: PASR read GetRowData;
property SafeRowData[Index: Integer]: PASR read SafeGetRowData;
property MemorySize: Int64 read GetMemorySize;
class operator Implicit(const u: TRealVector): TRealMatrix;
class operator Explicit(const A: TRealMatrix): TRealVector; inline;
class operator Explicit(X: TASR): TRealMatrix;
class operator Negative(const A: TRealMatrix): TRealMatrix;
class operator Add(const A, B: TRealMatrix): TRealMatrix;
class operator Add(const A: TRealMatrix; const X: TASR): TRealMatrix;
class operator Subtract(const A, B: TRealMatrix): TRealMatrix;
class operator Subtract(const A: TRealMatrix; const X: TASR): TRealMatrix;
class operator Multiply(const A, B: TRealMatrix): TRealMatrix;
class operator Multiply(const X: TASR; const A: TRealMatrix): TRealMatrix;
class operator Multiply(const A: TRealMatrix; const X: TASR): TRealMatrix;
class operator Divide(const A: TRealMatrix; const X: TASR): TRealMatrix;
class operator Equal(const A, B: TRealMatrix): Boolean; inline;
class operator NotEqual(const A, B: TRealMatrix): Boolean; inline;
class operator Trunc(const A: TRealMatrix): TRealMatrix;
class operator Round(const A: TRealMatrix): TRealMatrix;
class operator LessThan(const A, B: TRealMatrix): Boolean; inline;
class operator LessThanOrEqual(const A, B: TRealMatrix): Boolean; inline;
class operator GreaterThan(const A, B: TRealMatrix): Boolean; inline;
class operator GreaterThanOrEqual(const A, B: TRealMatrix): Boolean; inline;
function IsRow: Boolean; inline;
function IsColumn: Boolean; inline;
function IsSquare: Boolean; inline;
function IsIdentity(const Epsilon: Extended = 0): Boolean;
function IsZeroMatrix(const Epsilon: Extended = 0): Boolean;
function IsDiagonal(const Epsilon: Extended = 0): Boolean;
function IsAntiDiagonal(const Epsilon: Extended = 0): Boolean;
function IsReversal(const Epsilon: Extended = 0): Boolean;
function IsUpperTriangular(const Epsilon: Extended = 0): Boolean;
function IsLowerTriangular(const Epsilon: Extended = 0): Boolean;
function IsTriangular(const Epsilon: Extended = 0): Boolean; inline;
function PivotPos(ARow: Integer; const Epsilon: Extended = 0): Integer;
function IsZeroRow(ARow: Integer; const Epsilon: Extended = 0): Boolean; inline;
function IsEssentiallyZeroRow(ARow: Integer;
const Epsilon: Extended = 0): Boolean; inline;
function IsRowEchelonForm(const Epsilon: Extended = 0): Boolean;
function IsReducedRowEchelonForm(const Epsilon: Extended = 0): Boolean;
function IsScalar(const Epsilon: Extended = 0): Boolean;
function IsSymmetric(const Epsilon: Extended = 0): Boolean; inline;
function IsSkewSymmetric(const Epsilon: Extended = 0): Boolean; inline;
function IsOrthogonal(const Epsilon: Extended = 0): Boolean; inline;
function IsNormal(const Epsilon: Extended = 0): Boolean; inline;
function IsBinary(const Epsilon: Extended = 0): Boolean;
function IsPermutation(const Epsilon: Extended = 0): Boolean;
function IsCirculant(const Epsilon: Extended = 0): Boolean;
function IsToeplitz(const Epsilon: Extended = 0): Boolean;
function IsHankel(const Epsilon: Extended = 0): Boolean;
function IsUpperHessenberg(const Epsilon: Extended = 0): Boolean;
function IsLowerHessenberg(const Epsilon: Extended = 0): Boolean;
function IsTridiagonal(const Epsilon: Extended = 0): Boolean; inline;
function IsUpperBidiagonal(const Epsilon: Extended = 0): Boolean; inline;
function IsLowerBidiagonal(const Epsilon: Extended = 0): Boolean; inline;
function IsBidiagonal(const Epsilon: Extended = 0): Boolean; inline;
function IsCentrosymmetric(const Epsilon: Extended = 0): Boolean; inline;
function IsVandermonde(const Epsilon: Extended = 0): Boolean;
function CommutesWith(const A: TRealMatrix;
const Epsilon: Extended = 0): Boolean; inline;
function IsIdempotent(const Epsilon: Extended = 0): Boolean; inline;
function IsInvolution(const Epsilon: Extended = 0): Boolean; inline;
function IsPositiveDefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsPositiveSemiDefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsNegativeDefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsNegativeSemiDefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsIndefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsNilpotent(const Epsilon: Extended = 0): Boolean; inline;
function NilpotencyIndex(const Epsilon: Extended = 0): Integer;
function IsDiagonallyDominant: Boolean;
function IsStrictlyDiagonallyDominant: Boolean;
function IsPositive(const Epsilon: Extended = 0): Boolean; inline;
function IsNonNegative(const Epsilon: Extended = 0): Boolean; inline;
function IsNegative(const Epsilon: Extended = 0): Boolean; inline;
function IsNonPositive(const Epsilon: Extended = 0): Boolean; inline;
procedure MakeLowerTriangular;
procedure MakeUpperTriangular;
procedure MakeUpperHessenberg;
function Sqr: TRealMatrix; inline;
function Transpose: TRealMatrix;
function HermitianSquare: TRealMatrix; inline;
function Modulus: TRealMatrix; inline;
function Determinant: TASR;
function Trace: TASR;
function Inverse: TRealMatrix;
function TryInvert(out AInverse: TRealMatrix): Boolean;
function Rank: Integer; inline;
function Nullity: Integer; inline;
function ConditionNumber(p: Integer = 2): TASR;
function IsSingular: Boolean;
function Norm: TASR; inline;
function NormSqr: TASR; inline;
function pNorm(const p: TASR): TASR; inline;
function MaxNorm: TASR; inline;
function SumNorm: TASR; inline;
function kNorm(const k: Integer): TASR; inline;
function MaxColSumNorm: TASR;
function MaxRowSumNorm: TASR;
function SpectralNorm: TASR; inline;
function DeletedAbsoluteRowSum(ARow: Integer): TASR;
function RowSwap(ARow1, ARow2: Integer): TRealMatrix;
function RowScale(ARow: Integer; AFactor: TASR): TRealMatrix;
function RowAddMul(ATarget, ASource: Integer; AFactor: TASR;
ADefuzz: Boolean = False; AFirstCol: Integer = 0): TRealMatrix;
function RowOp(const ARowOp: TRealRowOperationRecord): TRealMatrix;
function RowEchelonForm(CollectRowOps: Boolean = False): TRealMatrix;
function ReducedRowEchelonForm(CollectRowOps: Boolean = False): TRealMatrix;
function NumZeroRows(const AEpsilon: TASR = 0): Integer;
function NumTrailingZeroRows(const AEpsilon: TASR = 0): Integer;
function GramSchmidt: TRealMatrix;
procedure InplaceGramSchmidt(FirstCol, LastCol: Integer);
function ColumnSpaceBasis: TRealMatrix;
function ColumnSpaceProjection(const AVector: TRealVector): TRealVector;
function DistanceFromColumnSpace(const AVector: TRealVector): TASR;
function SimilarHessenberg(A2x2Bulge: Boolean = False): TRealMatrix;
function UnsortedEigenvalues: TComplexVector;
function eigenvalues: TComplexVector;
function spectrum: TComplexVector; inline;
function eigenvectors(out AEigenvalues: TRealVector;
out AEigenvectors: TRealMatrix; ASkipVerify: Boolean = False): Boolean;
function IsEigenvector(const u: TRealVector;
const Epsilon: Extended = 0): Boolean;
function EigenvalueOf(const u: TRealVector;
const Epsilon: Extended = 0): TASR;
function TryEigenvalueOf(const u: TRealVector; out AEigenvalue: TASR;
const Epsilon: Extended = 0): Boolean;
function IsEigenpair(const lambda: TASR; const u: TRealVector;
const Epsilon: Extended = 0): Boolean;
function EigenvectorOf(const lambda: TASR): TRealVector;
function SpectralRadius: TASR; inline;
function SingularValues: TRealVector;
function Abs: TRealMatrix;
function Defuzz(const Eps: Double = 1E-8): TRealMatrix;
function Clone: TRealMatrix;
function Vectorization: TRealVector; inline;
function AsVector: TRealVector; inline;
function Augment(const A: TRealMatrix): TRealMatrix; overload;
function Augment: TRealMatrix; overload; inline;
procedure SetRow(ARowIndex: Integer; const ARow: array of TASR);
procedure SetCol(AColIndex: Integer; const ACol: array of TASR);
function Submatrix(ARowToRemove: Integer = 0;
AColToRemove: Integer = 0; AAllowEmpty: Boolean = False): TRealMatrix; overload;
function Submatrix(const ARows: array of Integer;
const ACols: array of Integer): TRealMatrix; overload;
function Submatrix(const ARows: array of Integer): TRealMatrix; overload;
function LeadingPrincipalSubmatrix(const ASize: Integer): TRealMatrix;
function Lessened: TRealMatrix;
function Minor(ARow, ACol: Integer): TASR; inline;
function Cofactor(ARow, ACol: Integer): TASR; inline;
function CofactorMatrix: TRealMatrix;
function AdjugateMatrix: TRealMatrix; inline;
function Apply(AFunction: TRealFunctionRef): TRealMatrix;
function Replace(APredicate: TPredicate<TASR>;
const ANewValue: TASR): TRealMatrix; overload;
function Replace(const AOldValue, ANewValue: TASR;
const Epsilon: Extended = 0): TRealMatrix; overload;
function Replace(const ANewValue: TASR): TRealMatrix; overload;
function str(const AOptions: TFormatOptions): string;
procedure AddRow(const ARow: array of TASR);
function Sort(AComparer: IComparer<TASR>): TRealMatrix;
function SafeSort(AComparer: IComparer<TASR>): TRealMatrix;
function Shuffle: TRealMatrix;
function Reverse: TRealMatrix;
procedure LU(out P, L, U: TRealMatrix);
function Cholesky(out R: TRealMatrix): Boolean;
procedure QR(out Q, R: TRealMatrix);
procedure Hessenberg(out A, U: TRealMatrix);
end;
function mpow(const A: TRealMatrix; const N: Integer): TRealMatrix; overload;
function msqrt(const A: TRealMatrix): TRealMatrix; overload;
function SameMatrix(const A, B: TRealMatrix;
const Epsilon: Extended = 0): Boolean; overload; inline;
function SameMatrixEx(const A, B: TRealMatrix;
const Epsilon: Extended = 0): Boolean; overload; inline;
function ZeroMatrix(const ASize: TMatrixSize): TRealMatrix; inline;
function IdentityMatrix(ASize: Integer): TRealMatrix;
function ReversalMatrix(ASize: Integer): TRealMatrix;
function RandomMatrix(const ASize: TMatrixSize): TRealMatrix;
function RandomIntMatrix(const ASize: TMatrixSize; a, b: Integer): TRealMatrix;
function diag(const AElements: array of TASR): TRealMatrix; overload;
function diag(const AElements: TRealVector): TRealMatrix; overload; inline;
function OuterProduct(const u, v: TRealVector): TRealMatrix; overload; inline;
function CirculantMatrix(const AElements: array of TASR): TRealMatrix; overload;
function ToeplitzMatrix(const AFirstRow,
AFirstCol: array of TASR): TRealMatrix; overload;
function HankelMatrix(const AFirstRow,
ALastCol: array of TASR): TRealMatrix; overload;
function BackwardShiftMatrix(ASize: Integer): TRealMatrix;
function ForwardShiftMatrix(ASize: Integer): TRealMatrix;
function VandermondeMatrix(const AElements: array of TASR;
ACols: Integer = 0): TRealMatrix; overload;
function HilbertMatrix(const ASize: TMatrixSize): TRealMatrix;
function RotationMatrix(AAngle: TASR; ADim: Integer = 2; AIndex1: Integer = 0;
AIndex2: Integer = 1): TRealMatrix; overload;
function RotationMatrix(AAngle: TASR; AAxis: TRealVector): TRealMatrix; overload;
function ReflectionMatrix(const u: TRealVector): TRealMatrix; overload;
function QuickReflectionMatrix(const u: TRealVector): TRealMatrix; overload; inline;
function HadamardProduct(const A, B: TRealMatrix): TRealMatrix; overload;
function DirectSum(const A, B: TRealMatrix): TRealMatrix; overload; inline;
function DirectSum(const Blocks: array of TRealMatrix): TRealMatrix; overload;
function Commute(const A, B: TRealMatrix;
const Epsilon: Extended = 0): Boolean; overload; inline;
function accumulate(const A: TRealMatrix; AStart: TASR;
AAccumulator: TAccumulator<TASR>): TASR; overload; inline;
function sum(const A: TRealMatrix): TASR; overload; inline;
function ArithmeticMean(const A: TRealMatrix): TASR; overload; inline;
function GeometricMean(const A: TRealMatrix): TASR; overload; inline;
function HarmonicMean(const A: TRealMatrix): TASR; overload; inline;
function product(const A: TRealMatrix): TASR; overload; inline;
function max(const A: TRealMatrix): TASR; overload; inline;
function min(const A: TRealMatrix): TASR; overload; inline;
function exists(const A: TRealMatrix; APredicate: TPredicate<TASR>): Boolean; overload;
function count(const A: TRealMatrix; APredicate: TPredicate<TASR>): Integer; overload;
function count(const A: TRealMatrix; const AValue: TASR): Integer; overload; inline;
function ForAll(const A: TRealMatrix; APredicate: TPredicate<TASR>): Boolean; overload;
function contains(const A: TRealMatrix; AValue: TASR): Boolean; overload; inline;
function TryForwardSubstitution(const A: TRealMatrix; const Y: TRealVector;
out Solution: TRealVector; IsUnitDiagonal: Boolean = False): Boolean; overload;
function ForwardSubstitution(const A: TRealMatrix; const Y: TRealVector;
IsUnitDiagonal: Boolean = False): TRealVector; overload;
function TryBackSubstitution(const A: TRealMatrix; const Y: TRealVector;
out Solution: TRealVector): Boolean; overload;
function BackSubstitution(const A: TRealMatrix; const Y: TRealVector): TRealVector; overload;
function SysSolve(const AAugmented: TRealMatrix): TRealVector; overload; inline;
function TrySysSolve(const A: TRealMatrix; const Y: TRealVector;
out Solution: TRealVector): Boolean; overload;
function TrySysSolve(const A: TRealMatrix; const Y: TRealMatrix;
out Solution: TRealMatrix): Boolean; overload;
function SysSolve(const A: TRealMatrix; const Y: TRealVector): TRealVector; overload;
function SysSolve(const A: TRealMatrix; const Y: TRealMatrix): TRealMatrix; overload;
function LeastSquaresPolynomialFit(const X, Y: TRealVector;
ADegree: Integer): TRealVector; overload;
procedure VectMove(const ASource: TRealVector; const AFrom, ATo: Integer;
var ATarget: TRealVector; const ATargetFrom: Integer = 0); overload; inline;
procedure VectMoveToMatCol(const ASource: TRealVector; const AFrom, ATo: Integer;
var ATarget: TRealMatrix; const ATargetCol: Integer;
const ATargetFirstRow: Integer = 0); overload;
procedure VectMoveToMatRow(const ASource: TRealVector; const AFrom, ATo: Integer;
var ATarget: TRealMatrix; const ATargetRow: Integer;
const ATargetFirstCol: Integer = 0); overload; inline;
procedure MatMove(const ASource: TRealMatrix; const ARect: TRect;
var ATarget: TRealMatrix; const ATargetTopLeft: TPoint); overload;
procedure MatMove(const ASource: TRealMatrix; var ATarget: TRealMatrix;
const ATargetTopLeft: TPoint); overload; inline;
procedure MatMoveColToVect(const ASource: TRealMatrix; const AColumn: Integer;
const AFrom, ATo: Integer; var ATarget: TRealVector;
const ATargetFrom: Integer = 0); overload;
procedure MatMoveRowToVect(const ASource: TRealMatrix; const ARow: Integer;
const AFrom, ATo: Integer; var ATarget: TRealVector;
const ATargetFrom: Integer = 0); overload; inline;
procedure MatMulBlockInplaceL(var ATarget: TRealMatrix; const ARect: TRect;
const AFactor: TRealMatrix); overload;
procedure MatMulBlockInplaceL(var ATarget: TRealMatrix; const ATopLeft: TPoint;
const AFactor: TRealMatrix); overload; inline;
procedure MatMulBottomRight(var ATarget: TRealMatrix; const AFactor: TRealMatrix); overload;
procedure MatBlockFill(var ATarget: TRealMatrix; const ARect: TRect;
const Value: TASR); overload;
type
TComplexRowOperationRecord = record
RowOperationType: TRowOperationType;
Row1, Row2: Integer;
Factor: TASC;
end;
TComplexRowOpSequence = array of TComplexRowOperationRecord;
TComplexMatrix = record
strict private
const
InitialRowOpSeqSize = 16;
var
FSize: TMatrixSize;
FElements: TASCArray;
FRowOpSeq: TComplexRowOpSequence;
FRowOpCount: Integer;
FRowOpFactor: TASC;
_FCollectRowOpData: Boolean;
procedure SetSize(const Value: TMatrixSize);
function GetElement(Row, Col: Integer): TASC; inline;
procedure SetElement(Row, Col: Integer; const Value: TASC); inline;
function GetRow(ARow: Integer): TComplexVector;
function GetCol(ACol: Integer): TComplexVector;
procedure _DoSetRow(ARowIndex: Integer; const ARow: TComplexVector);
procedure _DoSetCol(AColIndex: Integer; const ACol: TComplexVector);
function GetFirstCol: TComplexVector; inline;
procedure SetFirstCol(const ACol: TComplexVector); inline;
function GetLastCol: TComplexVector; inline;
procedure SetLastCol(const ACol: TComplexVector); inline;
function GetMainDiagonal: TComplexVector;
procedure SetMainDiagonal(const ADiagonal: TComplexVector);
function GetSuperDiagonal: TComplexVector;
procedure SetSuperDiagonal(const ADiagonal: TComplexVector);
function GetSubDiagonal: TComplexVector;
procedure SetSubDiagonal(const ADiagonal: TComplexVector);
function GetAntiDiagonal: TComplexVector;
procedure SetAntiDiagonal(const ADiagonal: TComplexVector);
procedure Alloc(ARows, ACols: Integer); overload;
procedure Alloc(ASize: Integer); overload;
procedure Alloc(const ASize: TMatrixSize); overload;
function GetRowData(AIndex: Integer): PASC; inline;
function SafeGetRowData(AIndex: Integer): PASC;
function GetMemorySize: Int64;
procedure BeginCollectRowOpData;
procedure AddRowOpRecord(AType: TRowOperationType; ARow1, ARow2: Integer;
AFactor: TASC);
procedure GetHouseholderMap(const AVect: TComplexVector;
out tau, gamma: TASC; out u: TComplexVector);
function Eigenvalues2x2: TComplexVector;
private
function IsEmpty: Boolean; inline;
procedure DoQuickLU(out A: TComplexMatrix; out P: TIndexArray);
procedure RequireNonEmpty; inline;
public
constructor CreateUninitialized(const ASize: TMatrixSize);
constructor Create(const AMatrix: TComplexMatrix); overload;
constructor Create(const Elements: array of TASCArray); overload;
constructor Create(const Elements: array of TASC; Cols: Integer = 1); overload;
constructor Create(const ASize: TMatrixSize; const AVal: TASC); overload;
constructor CreateFromRows(const Rows: array of TComplexVector);
constructor CreateFromColumns(const Columns: array of TComplexVector);
constructor Create(const u, v: TComplexVector); overload;
constructor Create(const ASize: TMatrixSize;
AFunction: TMatrixIndexFunction<TASC>); overload;
constructor CreateDiagonal(const Elements: array of TASC); overload;
constructor CreateDiagonal(const Elements: TComplexVector); overload;
constructor CreateDiagonal(ASize: Integer; AVal: TASC); overload;
constructor Create(const Blocks: array of TComplexMatrix; Cols: Integer = 2); overload;
property Size: TMatrixSize read FSize write SetSize;
property Elements[Row, Col: Integer]: TASC read GetElement write SetElement; default;
property Rows[Index: Integer]: TComplexVector read GetRow write _DoSetRow;
property Cols[Index: Integer]: TComplexVector read GetCol write _DoSetCol;
property FirstColumn: TComplexVector read GetFirstCol write SetFirstCol;
property LastColumn: TComplexVector read GetLastCol write SetLastCol;
property MainDiagonal: TComplexVector read GetMainDiagonal write SetMainDiagonal;
property SuperDiagonal: TComplexVector read GetSuperDiagonal write SetSuperDiagonal;
property SubDiagonal: TComplexVector read GetSubDiagonal write SetSubDiagonal;
property AntiDiagonal: TComplexVector read GetAntiDiagonal write SetAntiDiagonal;
property Data: TASCArray read FElements write FElements;
property RowData[Index: Integer]: PASC read GetRowData;
property SafeRowData[Index: Integer]: PASC read SafeGetRowData;
property MemorySize: Int64 read GetMemorySize;
class operator Implicit(const u: TComplexVector): TComplexMatrix;
class operator Implicit(const A: TRealMatrix): TComplexMatrix;
class operator Explicit(const A: TComplexMatrix): TComplexVector; inline;
class operator Explicit(X: TASC): TComplexMatrix;
class operator Negative(const A: TComplexMatrix): TComplexMatrix;
class operator Add(const A, B: TComplexMatrix): TComplexMatrix;
class operator Add(const A: TComplexMatrix; const X: TASC): TComplexMatrix;
class operator Subtract(const A, B: TComplexMatrix): TComplexMatrix;
class operator Subtract(const A: TComplexMatrix; const X: TASC): TComplexMatrix;
class operator Multiply(const A, B: TComplexMatrix): TComplexMatrix;
class operator Multiply(const X: TASC; const A: TComplexMatrix): TComplexMatrix;
class operator Multiply(const A: TComplexMatrix; const X: TASC): TComplexMatrix;
class operator Divide(const A: TComplexMatrix; const X: TASC): TComplexMatrix;
class operator Equal(const A, B: TComplexMatrix): Boolean; inline;
class operator NotEqual(const A, B: TComplexMatrix): Boolean; inline;
class operator Trunc(const A: TComplexMatrix): TComplexMatrix;
class operator Round(const A: TComplexMatrix): TComplexMatrix;
function IsRow: Boolean; inline;
function IsColumn: Boolean; inline;
function IsSquare: Boolean; inline;
function IsIdentity(const Epsilon: Extended = 0): Boolean;
function IsZeroMatrix(const Epsilon: Extended = 0): Boolean;
function IsDiagonal(const Epsilon: Extended = 0): Boolean;
function IsAntiDiagonal(const Epsilon: Extended = 0): Boolean;
function IsReversal(const Epsilon: Extended = 0): Boolean;
function IsUpperTriangular(const Epsilon: Extended = 0): Boolean;
function IsLowerTriangular(const Epsilon: Extended = 0): Boolean;
function IsTriangular(const Epsilon: Extended = 0): Boolean; inline;
function PivotPos(ARow: Integer; const Epsilon: Extended = 0): Integer;
function IsZeroRow(ARow: Integer; const Epsilon: Extended = 0): Boolean; inline;
function IsEssentiallyZeroRow(ARow: Integer;
const Epsilon: Extended = 0): Boolean; inline;
function IsRowEchelonForm(const Epsilon: Extended = 0): Boolean;
function IsReducedRowEchelonForm(const Epsilon: Extended = 0): Boolean;
function IsScalar(const Epsilon: Extended = 0): Boolean;
function IsSymmetric(const Epsilon: Extended = 0): Boolean; inline;
function IsSkewSymmetric(const Epsilon: Extended = 0): Boolean; inline;
function IsHermitian(const Epsilon: Extended = 0): Boolean; inline;
function IsSkewHermitian(const Epsilon: Extended = 0): Boolean; inline;
function IsOrthogonal(const Epsilon: Extended = 0): Boolean; inline;
function IsUnitary(const Epsilon: Extended = 0): Boolean; inline;
function IsNormal(const Epsilon: Extended = 0): Boolean; inline;
function IsBinary(const Epsilon: Extended = 0): Boolean;
function IsPermutation(const Epsilon: Extended = 0): Boolean;
function IsCirculant(const Epsilon: Extended = 0): Boolean;
function IsToeplitz(const Epsilon: Extended = 0): Boolean;
function IsHankel(const Epsilon: Extended = 0): Boolean;
function IsUpperHessenberg(const Epsilon: Extended = 0): Boolean;
function IsLowerHessenberg(const Epsilon: Extended = 0): Boolean;
function IsTridiagonal(const Epsilon: Extended = 0): Boolean; inline;
function IsUpperBidiagonal(const Epsilon: Extended = 0): Boolean; inline;
function IsLowerBidiagonal(const Epsilon: Extended = 0): Boolean; inline;
function IsBidiagonal(const Epsilon: Extended = 0): Boolean; inline;
function IsCentrosymmetric(const Epsilon: Extended = 0): Boolean; inline;
function IsVandermonde(const Epsilon: Extended = 0): Boolean;
function CommutesWith(const A: TComplexMatrix;
const Epsilon: Extended = 0): Boolean; inline;
function IsIdempotent(const Epsilon: Extended = 0): Boolean; inline;
function IsInvolution(const Epsilon: Extended = 0): Boolean; inline;
function IsPositiveDefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsPositiveSemiDefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsNegativeDefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsNegativeSemiDefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsIndefinite(const Epsilon: Extended = 0): Boolean; inline;
function IsNilpotent(const Epsilon: Extended = 0): Boolean; inline;
function NilpotencyIndex(const Epsilon: Extended = 0): Integer;
function IsDiagonallyDominant: Boolean;
function IsStrictlyDiagonallyDominant: Boolean;
function RealPart: TRealMatrix;
function ImaginaryPart: TRealMatrix;
procedure MakeLowerTriangular;
procedure MakeUpperTriangular;
procedure MakeUpperHessenberg;
function Sqr: TComplexMatrix; inline;
function Transpose: TComplexMatrix;
function Adjoint: TComplexMatrix;
function HermitianSquare: TComplexMatrix; inline;
function Modulus: TComplexMatrix; inline;
function Determinant: TASC;
function Trace: TASC;
function Inverse: TComplexMatrix;
function TryInvert(out AInverse: TComplexMatrix): Boolean;
function Rank: Integer; inline;
function Nullity: Integer; inline;
function ConditionNumber(p: Integer = 2): TASR;
function IsSingular: Boolean;
function Norm: TASR; inline;
function NormSqr: TASR; inline;
function pNorm(const p: TASR): TASR; inline;
function MaxNorm: TASR; inline;
function SumNorm: TASR; inline;
function kNorm(const k: Integer): TASR; inline;
function MaxColSumNorm: TASR;
function MaxRowSumNorm: TASR;
function SpectralNorm: TASR; inline;
function DeletedAbsoluteRowSum(ARow: Integer): TASR;
function RowSwap(ARow1, ARow2: Integer): TComplexMatrix;
function RowScale(ARow: Integer; AFactor: TASC): TComplexMatrix;
function RowAddMul(ATarget, ASource: Integer; AFactor: TASC;
ADefuzz: Boolean = False; AFirstCol: Integer = 0): TComplexMatrix;
function RowOp(const ARowOp: TComplexRowOperationRecord): TComplexMatrix;
function RowEchelonForm(CollectRowOps: Boolean = False): TComplexMatrix;
function ReducedRowEchelonForm(CollectRowOps: Boolean = False): TComplexMatrix;
function NumZeroRows(const AEpsilon: TASR = 0): Integer;
function NumTrailingZeroRows(const AEpsilon: TASR = 0): Integer;
function GramSchmidt: TComplexMatrix;
procedure InplaceGramSchmidt(FirstCol, LastCol: Integer);
function ColumnSpaceBasis: TComplexMatrix;
function ColumnSpaceProjection(const AVector: TComplexVector): TComplexVector;
function DistanceFromColumnSpace(const AVector: TComplexVector): TASR;
function SimilarHessenberg(A2x2Bulge: Boolean = False): TComplexMatrix;
function UnsortedEigenvalues: TComplexVector;
function eigenvalues: TComplexVector;
function spectrum: TComplexVector; inline;
function eigenvectors(out AEigenvalues: TComplexVector;
out AEigenvectors: TComplexMatrix; ASkipVerify: Boolean = False): Boolean;
function IsEigenvector(const u: TComplexVector;
const Epsilon: Extended = 0): Boolean;
function EigenvalueOf(const u: TComplexVector;
const Epsilon: Extended = 0): TASC;
function TryEigenvalueOf(const u: TComplexVector; out AEigenvalue: TASC;
const Epsilon: Extended = 0): Boolean;
function IsEigenpair(const lambda: TASC; const u: TComplexVector;
const Epsilon: Extended = 0): Boolean;
function EigenvectorOf(const lambda: TASC): TComplexVector;
function SpectralRadius: TASR; inline;
function SingularValues: TRealVector;
function Abs: TRealMatrix;
function Defuzz(const Eps: Double = 1E-8): TComplexMatrix;
function Clone: TComplexMatrix;
function Vectorization: TComplexVector; inline;
function AsVector: TComplexVector; inline;
function Augment(const A: TComplexMatrix): TComplexMatrix; overload;
function Augment: TComplexMatrix; overload; inline;
procedure SetRow(ARowIndex: Integer; const ARow: array of TASC);
procedure SetCol(AColIndex: Integer; const ACol: array of TASC);
function Submatrix(ARowToRemove: Integer = 0;
AColToRemove: Integer = 0; AAllowEmpty: Boolean = False): TComplexMatrix; overload;
function Submatrix(const ARows: array of Integer;
const ACols: array of Integer): TComplexMatrix; overload;
function Submatrix(const ARows: array of Integer): TComplexMatrix; overload;
function LeadingPrincipalSubmatrix(const ASize: Integer): TComplexMatrix;
function Lessened: TComplexMatrix;
function Minor(ARow, ACol: Integer): TASC; inline;
function Cofactor(ARow, ACol: Integer): TASC; inline;
function CofactorMatrix: TComplexMatrix;
function AdjugateMatrix: TComplexMatrix; inline;
function Apply(AFunction: TComplexFunctionRef): TComplexMatrix;
function Replace(APredicate: TPredicate<TASC>;
const ANewValue: TASC): TComplexMatrix; overload;
function Replace(const AOldValue, ANewValue: TASC;
const Epsilon: Extended = 0): TComplexMatrix; overload;
function Replace(const ANewValue: TASC): TComplexMatrix; overload;
function str(const AOptions: TFormatOptions): string;
procedure AddRow(const ARow: array of TASC);
function Sort(AComparer: IComparer<TASC>): TComplexMatrix;
function SafeSort(AComparer: IComparer<TASC>): TComplexMatrix;
function Shuffle: TComplexMatrix;
function Reverse: TComplexMatrix;
procedure LU(out P, L, U: TComplexMatrix);
function Cholesky(out R: TComplexMatrix): Boolean;
procedure QR(out Q, R: TComplexMatrix);
procedure Hessenberg(out A, U: TComplexMatrix);
end;
function mpow(const A: TComplexMatrix; const N: Integer): TComplexMatrix; overload;
function msqrt(const A: TComplexMatrix): TComplexMatrix; overload;
function SameMatrix(const A, B: TComplexMatrix;
const Epsilon: Extended = 0): Boolean; overload; inline;
function SameMatrixEx(const A, B: TComplexMatrix;
const Epsilon: Extended = 0): Boolean; overload; inline;
function ComplexZeroMatrix(const ASize: TMatrixSize): TComplexMatrix; inline;
function ComplexIdentityMatrix(ASize: Integer): TComplexMatrix;
function ComplexReversalMatrix(ASize: Integer): TComplexMatrix;
function diag(const AElements: array of TASC): TComplexMatrix; overload;
function diag(const AElements: TComplexVector): TComplexMatrix; inline; overload;
function OuterProduct(const u, v: TComplexVector): TComplexMatrix; overload; inline;
function CirculantMatrix(const AElements: array of TASC): TComplexMatrix; overload;
function ToeplitzMatrix(const AFirstRow,
AFirstCol: array of TASC): TComplexMatrix; overload;
function HankelMatrix(const AFirstRow,
ALastCol: array of TASC): TComplexMatrix; overload;
function VandermondeMatrix(const AElements: array of TASC;
ACols: Integer = 0): TComplexMatrix; overload;
function ReflectionMatrix(const u: TComplexVector): TComplexMatrix; overload;
function QuickReflectionMatrix(const u: TComplexVector): TComplexMatrix; overload; inline;
function HadamardProduct(const A, B: TComplexMatrix): TComplexMatrix; overload;
function DirectSum(const A, B: TComplexMatrix): TComplexMatrix; overload; inline;
function DirectSum(const Blocks: array of TComplexMatrix): TComplexMatrix; overload;
function Commute(const A, B: TComplexMatrix;
const Epsilon: Extended = 0): Boolean; overload; inline;
function accumulate(const A: TComplexMatrix; const AStart: TASC;
AAccumulator: TAccumulator<TASC>): TASC; overload; inline;
function sum(const A: TComplexMatrix): TASC; overload; inline;
function ArithmeticMean(const A: TComplexMatrix): TASC; overload; inline;
function GeometricMean(const A: TComplexMatrix): TASC; overload; inline;
function HarmonicMean(const A: TComplexMatrix): TASC; overload; inline;
function product(const A: TComplexMatrix): TASC; overload; inline;
function exists(const A: TComplexMatrix; APredicate: TPredicate<TASC>): Boolean; overload;
function count(const A: TComplexMatrix; APredicate: TPredicate<TASC>): Integer; overload;
function count(const A: TComplexMatrix; const AValue: TASC): Integer; overload; inline;
function ForAll(const A: TComplexMatrix; APredicate: TPredicate<TASC>): Boolean; overload;
function contains(const A: TComplexMatrix; AValue: TASC): Boolean; overload; inline;
function TryForwardSubstitution(const A: TComplexMatrix; const Y: TComplexVector;
out Solution: TComplexVector; IsUnitDiagonal: Boolean = False): Boolean; overload;
function ForwardSubstitution(const A: TComplexMatrix; const Y: TComplexVector;
IsUnitDiagonal: Boolean = False): TComplexVector; overload;
function TryBackSubstitution(const A: TComplexMatrix; const Y: TComplexVector;
out Solution: TComplexVector): Boolean; overload;
function BackSubstitution(const A: TComplexMatrix; const Y: TComplexVector): TComplexVector; overload;
function SysSolve(const AAugmented: TComplexMatrix): TComplexVector; overload; inline;
function TrySysSolve(const A: TComplexMatrix; const Y: TComplexVector;
out Solution: TComplexVector): Boolean; overload;
function TrySysSolve(const A: TComplexMatrix; const Y: TComplexMatrix;
out Solution: TComplexMatrix): Boolean; overload;
function SysSolve(const A: TComplexMatrix; const Y: TComplexVector): TComplexVector; overload;
function SysSolve(const A: TComplexMatrix; const Y: TComplexMatrix): TComplexMatrix; overload;
function LeastSquaresPolynomialFit(const X, Y: TComplexVector;
ADegree: Integer): TComplexVector; overload;
procedure VectMove(const ASource: TComplexVector; const AFrom, ATo: Integer;
var ATarget: TComplexVector; const ATargetFrom: Integer = 0); overload; inline;
procedure VectMoveToMatCol(const ASource: TComplexVector; const AFrom, ATo: Integer;
var ATarget: TComplexMatrix; const ATargetCol: Integer;
const ATargetFirstRow: Integer = 0); overload;
procedure VectMoveToMatRow(const ASource: TComplexVector; const AFrom, ATo: Integer;
var ATarget: TComplexMatrix; const ATargetRow: Integer;
const ATargetFirstCol: Integer = 0); overload; inline;
procedure MatMove(const ASource: TComplexMatrix; const ARect: TRect;
var ATarget: TComplexMatrix; const ATargetTopLeft: TPoint); overload;
procedure MatMove(const ASource: TComplexMatrix; var ATarget: TComplexMatrix;
const ATargetTopLeft: TPoint); overload; inline;
procedure MatMoveColToVect(const ASource: TComplexMatrix; const AColumn: Integer;
const AFrom, ATo: Integer; var ATarget: TComplexVector;
const ATargetFrom: Integer = 0); overload;
procedure MatMoveRowToVect(const ASource: TComplexMatrix; const ARow: Integer;
const AFrom, ATo: Integer; var ATarget: TComplexVector;
const ATargetFrom: Integer = 0); overload; inline;
procedure MatMulBlockInplaceL(var ATarget: TComplexMatrix; const ARect: TRect;
const AFactor: TComplexMatrix); overload;
procedure MatMulBlockInplaceL(var ATarget: TComplexMatrix; const ATopLeft: TPoint;
const AFactor: TComplexMatrix); overload; inline;
procedure MatMulBottomRight(var ATarget: TComplexMatrix; const AFactor: TComplexMatrix); overload;
procedure MatBlockFill(var ATarget: TComplexMatrix; const ARect: TRect;
const Value: TASC); overload;
function sqrt(const X: TASR): TASR; overload; inline;
function sqrt(const z: TASC): TASC; overload; inline;
function sqrt(const A: TRealMatrix): TRealMatrix; overload; inline;
function sqrt(const A: TComplexMatrix): TComplexMatrix; overload; inline;
const
RealCheck = {$IFDEF REALCHECK}True{$ELSE}False{$ENDIF};
var
MaxThreadCount: Integer = 8;
function GetTotalCacheSize: Integer;
procedure ClearCaches;
const
InvLn10: TASC = (Re: 0.434294481903251827651128918916605082294397005803666566114; Im: 0);
function DoubleListToASR2s(const LList: TArray<Double>): TArray<TASR2>;
function DoubleListToASR3s(const LList: TArray<Double>): TArray<TASR3>;
implementation
uses
Classes, StrUtils, Windows, Character, WideStrUtils;
var
FS: TFormatSettings;
procedure DoYield; inline;
begin
if Assigned(GTYieldProc) then
GTYieldProc;
end;
class function TInt64Guard.CanUnMin(const A: Int64): Boolean;
begin
Result := A <> A.MinValue;
end;
class function TInt64Guard.CanAbs(const A: Int64): Boolean;
begin
Result := A <> A.MinValue;
end;
class function TInt64Guard.CanAdd(const A, B: Int64): Boolean;
const
SafeMin = Int64.MinValue div 2 + 1;
SafeMax = Int64.MaxValue div 2 - 1;
begin
Result := InRange(A, SafeMin, SafeMax) and InRange(A, SafeMin, SafeMax);
end;
class function TInt64Guard.CanSub(const A, B: Int64): Boolean;
const
SafeMin = Int64.MinValue div 2 + 1;
SafeMax = Int64.MaxValue div 2 - 1;
begin
Result := InRange(A, SafeMin, SafeMax) and InRange(A, SafeMin, SafeMax);
end;
class function TInt64Guard.CanMul(const A, B: Int64): Boolean;
const
SafeMin = Extended(Int64.MinValue) / 2;
SafeMax = Extended(Int64.MaxValue) / 2;
begin
Result := InRange(Extended(A) * Extended(B), SafeMin, SafeMax);
end;
class function TInt64Guard.CanDiv(const A, B: Int64): Boolean;
begin
Result := (A <> A.MinValue) or (B <> -1);
end;
class function TInt64Guard.CanDivEv(const A, B: Int64): Boolean;
begin
Result := CanDiv(A, B) and (A mod B = 0);
end;
class function TInt64Guard.CanSqr(const A: Int64): Boolean;
begin
Result := InRange(A, -3037000499, 3037000499);
end;
function GetThreadCount: Integer; inline;
begin
Result := Min(CPUCount, MaxThreadCount);
end;
const
FuzzFactor = 1000;
ExtendedResolution = 1E-19 * FuzzFactor;
DoubleResolution = 1E-15 * FuzzFactor;
function SameValue2(const A, B: Extended): Boolean;
var
Epsilon: Extended;
begin
Epsilon := Min(Abs(A), Abs(B)) * ExtendedResolution;
if A > B then
Result := (A - B) <= Epsilon
else
Result := (B - A) <= Epsilon;
end;
function SameValue2(const A, B: Double): Boolean;
var
Epsilon: Double;
begin
Epsilon := Min(Abs(A), Abs(B)) * DoubleResolution;
if A > B then
Result := (A - B) <= Epsilon
else
Result := (B - A) <= Epsilon;
end;
function SameValueEx(const A, B: Extended; Epsilon: Extended): Boolean; overload;
begin
if Epsilon = 0 then
Epsilon := Max(Min(Abs(A), Abs(B)) * ExtendedResolution, ExtendedResolution)
else
Epsilon := Max(Min(Abs(A), Abs(B)) * Epsilon, Epsilon);
if A > B then
Result := (A - B) <= Epsilon
else
Result := (B - A) <= Epsilon;
end;
function SameValueEx(const A, B: Double; Epsilon: Double): Boolean; overload;
begin
if Epsilon = 0 then
Epsilon := Max(Min(Abs(A), Abs(B)) * DoubleResolution, DoubleResolution)
else
Epsilon := Max(Min(Abs(A), Abs(B)) * Epsilon, Epsilon);
if A > B then
Result := (A - B) <= Epsilon
else
Result := (B - A) <= Epsilon;
end;
function inv(const X: TASR): TASR; inline;
begin
Result := 1 / X;
end;
function cinv(const X: TASC): TASC; inline;
begin
Result := 1 / X;
end;
function NN(N: Integer): Integer; inline;
begin
if N >= 0 then
Result := N
else
Result := 0;
end;
function AltSgn(const N: Integer): Integer; inline;
begin
if N mod 2 = 0 then
Result := 1
else
Result := -1;
end;
function CreateIntSequence(AStart, AEnd: Integer): TArray<Integer>;
var
i: Integer;
begin
if AEnd >= AStart then
begin
SetLength(Result, AEnd - AStart + 1);
for i := 0 to High(Result) do
Result[i] := AStart + i
end
else
begin
SetLength(Result, AStart - AEnd + 1);
for i := 0 to High(Result) do
Result[i] := AStart - i;
end;
end;
function CreateIntSequence(AStart, AEnd, AStep: Integer): TArray<Integer>;
var
i: Integer;
begin
if AStep = 0 then
raise EMathException.Create('Cannot create an integer sequence with step size 0.');
AStep := Abs(AStep);
if AEnd >= AStart then
begin
SetLength(Result, 1 + (AEnd - AStart) div AStep);
for i := 0 to High(Result) do
Result[i] := AStart + i * AStep;
end
else
begin
SetLength(Result, 1 + (AStart - AEnd) div AStep);
for i := 0 to High(Result) do
Result[i] := AStart - i * AStep;
end;
end;
function CreateIntSequence64(AStart, AEnd: Int64): TArray<Int64>;
var
i: Int64;
begin
if AEnd >= AStart then
begin
SetLength(Result, AEnd - AStart + 1);
for i := 0 to High(Result) do
Result[i] := AStart + i
end
else
begin
SetLength(Result, AStart - AEnd + 1);
for i := 0 to High(Result) do
Result[i] := AStart - i;
end;
end;
function CreateIntSequence64(AStart, AEnd, AStep: Int64): TArray<Int64>;
var
i: Int64;
begin
if AStep = 0 then
raise EMathException.Create('Cannot create an integer sequence with step size 0.');
AStep := Abs(AStep);
if AEnd >= AStart then
begin
SetLength(Result, 1 + (AEnd - AStart) div AStep);
for i := 0 to High(Result) do
Result[i] := AStart + i * AStep;
end
else
begin
SetLength(Result, 1 + (AStart - AEnd) div AStep);
for i := 0 to High(Result) do
Result[i] := AStart - i * AStep;
end;
end;
procedure TranslateIntSequence(var ASeq: TArray<Integer>; const Offset: Integer = -1);
var
i: Integer;
begin
for i := Low(ASeq) to High(ASeq) do
Inc(ASeq[i], Offset);
end;
function TranslatedIntSequence(const ASeq: array of Integer;
const Offset: Integer = -1): TArray<Integer>;
var
i: Integer;
begin
SetLength(Result, Length(ASeq));
for i := 0 to High(ASeq) do
Result[i] := ASeq[i] + Offset;
end;
procedure TranslatePoint(var APoint: TPoint; const Offset: Integer = -1);
begin
APoint.X := APoint.X + Offset;
APoint.Y := APoint.Y + Offset;
end;
function TranslatedPoint(const APoint: TPoint; const Offset: Integer = -1): TPoint;
begin
Result.X := APoint.X + Offset;
Result.Y := APoint.Y + Offset;
end;
function ParseRangeSeq(const ARanges: array of TRange;
const ALength: Integer): TArray<Integer>;
var
List: TList<Integer>;
i, j: Integer;
a, b: Integer;
Step: Integer;
begin
List := TList<Integer>.Create;
try
for i := 0 to High(ARanges) do
begin
a := ARanges[i].From;
if a < 0 then
a := ALength + 1 + a;
b := ARanges[i].&To;
if b < 0 then
b := ALength + 1 + b;
Step := ARanges[i].Step;
case CompareValue(a, b) of
LessThanValue:
begin
j := max(a, 1);
while j <= min(b, ALength) do
begin
List.Add(j);
Inc(j, Step);
end;
end;
EqualsValue:
if InRange(a, 1, ALength) then
List.Add(a);
GreaterThanValue:
begin
j := min(a, ALength);
while j >= max(b, 1) do
begin
List.Add(j);
Dec(j, Step);
end;
end;
end;
end;
Result := List.ToArray;
finally
List.Free;
end;
end;
function IntArrToRealArr(const AArray: TArray<Integer>): TArray<TASR>;
var
i: Integer;
begin
SetLength(Result, Length(AArray));
for i := 0 to High(Result) do
Result[i] := AArray[i];
end;
function Int64ArrToRealArr(const AArray: TArray<Int64>): TArray<TASR>;
var
i: Integer;
begin
SetLength(Result, Length(AArray));
for i := 0 to High(Result) do
Result[i] := AArray[i];
end;
function IntArrToStrArr(const AArray: TArray<Integer>): TArray<string>;
var
i: Integer;
begin
SetLength(Result, Length(AArray));
for i := 0 to High(Result) do
Result[i] := AArray[i].ToString;
end;
function Int64ArrToStrArr(const AArray: TArray<Int64>): TArray<string>;
var
i: Integer;
begin
SetLength(Result, Length(AArray));
for i := 0 to High(Result) do
Result[i] := AArray[i].ToString;
end;
function ASR_COUNT(const A, B: TASR): TASR;
begin
Result := A + 1;
end;
function ASR_PLUS(const A, B: TASR): TASR;
begin
Result := A + B;
end;
function ASR_TIMES(const A, B: TASR): TASR;
begin
Result := A * B;
end;
function DoubleListToASR2s(const LList: TArray<Double>): TArray<TASR2>;
begin
SetLength(Result, Length(LList) div 2);
for var i := 0 to High(Result) do
begin
Result[i].X := LList[2*i ];
Result[i].Y := LList[2*i + 1];
end;
end;
function DoubleListToASR3s(const LList: TArray<Double>): TArray<TASR3>;
begin
SetLength(Result, Length(LList) div 3);
for var i := 0 to High(Result) do
begin
Result[i].X := LList[3*i ];
Result[i].Y := LList[3*i + 1];
Result[i].Z := LList[3*i + 2];
end;
end;
function TFormatStyleHelper.ToString: string;
begin
Result := FormatStyleNames[Self];
end;
class function TFormatStyleHelper.FromString(const S: string): TFormatStyle;
resourcestring
SUnknownNumberFormatName = 'Unknown number format "%s".';
var
i: TFormatStyle;
begin
for i := Low(TFormatStyle) to High(TFormatStyle) do
if i.ToString = S then
Exit(i);
raise Exception.CreateFmt(SUnknownNumberFormatName, [S]);
end;
constructor TRationalNumber.Create(const ANumerator, ADenominator: TASI);
begin
Numerator := ANumerator;
Denominator := ADenominator;
ToSimplestForm;
end;
class procedure TRationalNumber.ErrNoRep;
begin
raise EMathException.Create('Rational number cannot be represented.');
end;
function __DigChr(ADig: Integer): Char; inline;
begin
Result := Chr(Ord('0') + ADig);
end;
function TRationalNumber.ToDecimalString(
const AFormatOptions: TFormatOptions): string;
const
NegExpLimit = 4;
RDMs: array[TNumberFormat] of TRatDigitMode = (rdmFixedSignificant,
rdmFixedSignificant, rdmFractional, rdmSignificant, rdmSignificant);
FO: array[TNumberFormat] of Boolean = (False, False, True, True, False);
var
NF: TNumberFormat;
D: TArray<Integer>;
FirstDigitPos, FirstSigDigitPos: Integer;
NumDigits,
NumIntDigits,
NumFracDigits: Integer;
ResLen: Integer;
c: Integer;
i: Integer;
dgt: Char;
LNumDigits: Integer;
begin
if not valid then
Exit('NaN');
NF := AFormatOptions.Numbers.NumberFormat;
LNumDigits := Max(AFormatOptions.Numbers.NumDigits, IfThen(NF = nfFixed, 0, 1));
if ((Denominator = 1) or (Numerator = 0)) and (NF in [nfDefault, nfFraction]) then
Exit(IntegerToStr(Numerator, AFormatOptions));
try
D := GetDigits(Self, LNumDigits, RDMs[NF], FO[NF], True, @FirstDigitPos, @FirstSigDigitPos);
except
Exit(RealToStr(TASR(Self), AFormatOptions));
end;
NumDigits := Length(D);
NumIntDigits := IfThen(NF in [nfExponent, nfDefExp], 1, Max(FirstDigitPos + 1, 0));
NumFracDigits := NumDigits - NumIntDigits;
Assert(NumDigits >= 1);
Assert(NumIntDigits >= 0);
case NF of
nfDefault, nfFraction, nfFixed:
begin
if NF in [nfDefault, nfFraction] then
if (NumIntDigits > LNumDigits) or (FirstSigDigitPos < -NegExpLimit) then
Exit(ToDecimalString(FixNumFmt(AFormatOptions, nfDefExp)));
ResLen := NumDigits;
if (Numerator < 0) and (FirstSigDigitPos <> FirstSigDigitPos.MaxValue) then
Inc(ResLen, 1);
if (NumIntDigits > 0) and (AFormatOptions.Numbers.IntGrouping <> 0) then
Inc(ResLen, Ceil(NumIntDigits / AFormatOptions.Numbers.IntGrouping) - 1);
if NumFracDigits > 0 then
Inc(ResLen, 1);
if (NumFracDigits > 0) and (AFormatOptions.Numbers.FracGrouping <> 0) then
Inc(ResLen, Ceil(NumFracDigits / AFormatOptions.Numbers.FracGrouping) - 1);
SetLength(Result, ResLen);
c := 0;
if (Numerator < 0) and (FirstSigDigitPos <> FirstSigDigitPos.MaxValue) then
begin
Inc(c);
Result[c] := AFormatOptions.Numbers.MinusSign;
end;
for i := 0 to NumIntDigits - 1 do
begin
if
(AFormatOptions.Numbers.IntGrouping <> 0)
and
(i > 0)
and
((NumIntDigits - i) mod (AFormatOptions.Numbers.IntGrouping) = 0)
then
begin
Inc(c);
Result[c] := AFormatOptions.Numbers.IntGropingChar;
end;
Inc(c);
Result[c] := __DigChr(D[i]);
end;
if NumFracDigits > 0 then
begin
Inc(c);
Result[c] := AFormatOptions.Numbers.DecimalSeparator;
for i := NumIntDigits to NumDigits - 1 do
begin
if
(AFormatOptions.Numbers.FracGrouping <> 0)
and
(i > NumIntDigits)
and
((i - NumIntDigits) mod (AFormatOptions.Numbers.FracGrouping) = 0)
then
begin
Inc(c);
Result[c] := AFormatOptions.Numbers.FracGroupingChar;
end;
Inc(c);
Result[c] := __DigChr(D[i]);
end;
end;
Assert(c = ResLen);
end;
nfExponent, nfDefExp:
begin
ResLen := NumDigits;
if Numerator < 0 then
Inc(ResLen, 1);
if NumFracDigits >= 1 then
Inc(ResLen, 1);
if AFormatOptions.Numbers.PrettyExp then
Inc(ResLen, 4)
else
Inc(ResLen, 1);
if AFormatOptions.Numbers.PrettyExp or (NF = nfDefExp) then
Inc(ResLen, FirstDigitPos.ToString.Length)
else
Inc(ResLen, System.Abs(FirstDigitPos).ToString.Length + 1 );
if (NumFracDigits > 0) and (AFormatOptions.Numbers.FracGrouping <> 0) then
Inc(ResLen, Ceil(NumFracDigits / AFormatOptions.Numbers.FracGrouping) - 1);
SetLength(Result, ResLen);
c := 0;
if Numerator < 0 then
begin
Inc(c);
Result[c] := AFormatOptions.Numbers.MinusSign;
end;
Inc(c);
Result[c] := __DigChr(D[0]);
if NumFracDigits > 0 then
begin
Inc(c);
Result[c] := AFormatOptions.Numbers.DecimalSeparator;
end;
for i := 1 to High(D) do
begin
if
(AFormatOptions.Numbers.FracGrouping <> 0)
and
(i > 1)
and
(Pred(i) mod (AFormatOptions.Numbers.FracGrouping) = 0)
then
begin
Inc(c);
Result[c] := AFormatOptions.Numbers.FracGroupingChar;
end;
Inc(c);
Result[c] := __DigChr(D[i])
end;
if AFormatOptions.Numbers.PrettyExp then
begin
Result[c + 1] := DOT_OPERATOR;
Result[c + 2] := '1';
Result[c + 3] := '0';
Result[c + 4] := '^';
Inc(c, 4);
end
else
begin
Inc(c);
Result[c] := 'E';
end;
if (FirstDigitPos < 0) or not AFormatOptions.Numbers.PrettyExp and (NF = nfExponent) then
Inc(c);
if FirstDigitPos < 0 then
Result[c] := AFormatOptions.Numbers.MinusSign
else if not AFormatOptions.Numbers.PrettyExp and (NF = nfExponent) then
Result[c] := '+';
for dgt in System.Abs(FirstDigitPos).ToString do
begin
Inc(c);
Result[c] := dgt;
end;
Assert(c = ResLen);
end;
else
Result := RealToStr(TASR(Self), AFormatOptions);
end;
end;
procedure TRationalNumber.ToSimplestForm;
var
_gcd: TASI;
begin
if Denominator = 0 then
raise EMathException.Create('Rational number with zero denominator.');
if Numerator = 0 then
begin
Denominator := 1;
Exit;
end;
_gcd := gcd(Numerator, Denominator);
Numerator := Numerator div _gcd;
Denominator := Denominator div _gcd;
if Denominator < 0 then
if TInt64Guard.CanUnMin(Numerator) and TInt64Guard.CanUnMin(Denominator) then
begin
Numerator := -Numerator;
Denominator := -Denominator;
end
else
ErrNoRep;
end;
function TRationalNumber.ToString(const AFormatOptions: TFormatOptions;
const ASymbol: string): string;
begin
ToSimplestForm;
if Denominator = 1 then
begin
if Numerator = 1 then
Result := ASymbol
else if Numerator = -1 then
Result := AFormatOptions.Numbers.MinusSign + ASymbol
else
Result := IntegerToStr(Numerator, AFormatOptions) + DOT_OPERATOR + ASymbol
end
else if Numerator = 1 then
Result := ASymbol + '/' + IntegerToStr(Denominator, AFormatOptions)
else if Numerator = -1 then
Result := AFormatOptions.Numbers.MinusSign + ASymbol + '/' + IntegerToStr(Denominator, AFormatOptions)
else
Result := '(' + ToString(AFormatOptions) + ')' + DOT_OPERATOR + ASymbol;
end;
function TRationalNumber.ToString(const AFormatOptions: TFormatOptions): string;
begin
if AFormatOptions.Numbers.NumberFormat = nfFraction then
begin
if Denominator = 1 then
Result := IntegerToStr(Numerator, AFormatOptions)
else
Result := Format('%s/%s',
[IntegerToStr(Numerator, AFormatOptions), IntegerToStr(Denominator, AFormatOptions)])
end
else
Result := ToDecimalString(AFormatOptions)
end;
class operator TRationalNumber.Implicit(A: Integer): TRationalNumber;
begin
Result.Numerator := A;
Result.Denominator := 1;
end;
class operator TRationalNumber.Implicit(A: TASI): TRationalNumber;
begin
Result.Numerator := A;
Result.Denominator := 1;
end;
class operator TRationalNumber.Implicit(const X: TRationalNumber): TASR;
begin
Result := X.Numerator / X.Denominator;
end;
class operator TRationalNumber.Equal(const X, Y: TRationalNumber): Boolean;
var
tmp1, tmp2: TRationalNumber;
begin
tmp1 := X;
tmp2 := Y;
tmp1.ToSimplestForm;
tmp2.ToSimplestForm;
Result := (tmp1.Numerator = tmp2.Numerator) and (tmp1.Denominator = tmp2.Denominator);
end;
class operator TRationalNumber.NotEqual(const X, Y: TRationalNumber): Boolean;
begin
Result := not (X = Y);
end;
class function TRationalNumber.Power(const X: TRationalNumber;
const N: TASI): TRationalNumber;
var
c: Integer;
begin
if not X.valid then
Exit(InvalidRat);
if (X.Numerator = 0) and (N = 0) then
Exit(InvalidRat);
if InRange(N, -1000, 1000) then
begin
c := System.Abs(N);
Result := 1;
while (c > 0) and Result.valid do
begin
Result := Result * X;
Dec(c);
end;
if (N < 0) and Result.valid then
Result := Result.inv;
end
else
Result := InvalidRat;
end;
function TRationalNumber.Sign: TValueSign;
begin
Result := Math.Sign(Numerator) * Math.Sign(Denominator);
end;
class operator TRationalNumber.Negative(const X: TRationalNumber): TRationalNumber;
begin
if TInt64Guard.CanUnMin(X.Numerator) then
begin
Result.Numerator := -X.Numerator;
Result.Denominator := X.Denominator;
end
else
Result := InvalidRat;
end;
class operator TRationalNumber.Add(const X, Y: TRationalNumber): TRationalNumber;
var
_lcm, XFactor, YFactor, XPart, YPart: TASI;
begin
if TryLCM(X.Denominator, Y.Denominator, _lcm) then
begin
XFactor := _lcm div X.Denominator;
YFactor := _lcm div Y.Denominator;
if TInt64Guard.CanMul(X.Numerator, XFactor) and TInt64Guard.CanMul(Y.Numerator, YFactor) then
begin
XPart := X.Numerator * XFactor;
YPart := Y.Numerator * YFactor;
if TInt64Guard.CanAdd(XPart, YPart) then
begin
Result.Numerator := XPart + YPart;
Result.Denominator := _lcm;
Result.ToSimplestForm;
Exit;
end;
end;
end;
Result := InvalidRat;
end;
class operator TRationalNumber.Subtract(const X, Y: TRationalNumber): TRationalNumber;
var
_lcm, XFactor, YFactor, XPart, YPart: TASI;
begin
if TryLCM(X.Denominator, Y.Denominator, _lcm) then
begin
XFactor := _lcm div X.Denominator;
YFactor := _lcm div Y.Denominator;
if TInt64Guard.CanMul(X.Numerator, XFactor) and TInt64Guard.CanMul(Y.Numerator, YFactor) then
begin
XPart := X.Numerator * XFactor;
YPart := Y.Numerator * YFactor;
if TInt64Guard.CanSub(XPart, YPart) then
begin
Result.Numerator := XPart - YPart;
Result.Denominator := _lcm;
Result.ToSimplestForm;
Exit;
end;
end;
end;
Result := InvalidRat;
end;
class operator TRationalNumber.Multiply(const X, Y: TRationalNumber): TRationalNumber;
var
tmp1, tmp2: TRationalNumber;
begin
if TInt64Guard.CanMul(X.Numerator, Y.Numerator) and TInt64Guard.CanMul(X.Denominator, Y.Denominator) then
begin
Result.Numerator := X.Numerator * Y.Numerator;
Result.Denominator := X.Denominator * Y.Denominator;
Result.ToSimplestForm;
end
else
begin
tmp1 := RationalNumber(X.Numerator, Y.Denominator);
tmp2 := RationalNumber(Y.Numerator, X.Denominator);
if TInt64Guard.CanMul(tmp1.Numerator, tmp2.Numerator) and TInt64Guard.CanMul(tmp1.Denominator, tmp2.Denominator) then
begin
Result.Numerator := tmp1.Numerator * tmp2.Numerator;
Result.Denominator := tmp1.Denominator * tmp2.Denominator;
Result.ToSimplestForm;
end
else
Result := InvalidRat;
end
end;
class operator TRationalNumber.Divide(const X, Y: TRationalNumber): TRationalNumber;
begin
Result := X * Y.inv;
end;
function TRationalNumber.inv: TRationalNumber;
begin
if Numerator = 0 then
raise EMathException.Create('Division by zero.');
Result.Denominator := Numerator;
Result.Numerator := Denominator;
if Result.Denominator < 0 then
begin
if TInt64Guard.CanUnMin(Result.Numerator) and TInt64Guard.CanUnMin(Result.Denominator) then
begin
Result.Numerator := -Result.Numerator;
Result.Denominator := -Result.Denominator;
end
else
Result := InvalidRat;
end
end;
function TRationalNumber.sqr: TRationalNumber;
begin
Result := Self * Self;
end;
function TRationalNumber.str: string;
begin
if Denominator = 1 then
Result := Format('%d', [Numerator])
else
Result := Format('%d/%d', [Numerator, Denominator]);
end;
function TRationalNumber.valid: Boolean;
begin
Result := Denominator <> 0;
end;
function TRationalNumber.Abs: TRationalNumber;
begin
if TInt64Guard.CanAbs(Numerator) then
begin
Result.Numerator := System.Abs(Numerator);
Result.Denominator := Denominator;
end
else
Result := InvalidRat;
end;
constructor TSimpleSymbolicForm.Create(const AA, AB: TRationalNumber;
const ASym: string; ASymVal: TASR);
begin
A := AA;
B := AB;
Sym := ASym;
SymVal := ASymVal;
end;
constructor TSimpleSymbolicForm.Create(pA, qA, pB, qB: TASI; const ASym: string;
ASymVal: TASR);
begin
A := RationalNumber(pA, qA);
B := RationalNumber(pB, qB);
Sym := ASym;
SymVal := ASymVal;
end;
constructor TSimpleSymbolicForm.Create(const AA: TRationalNumber);
begin
A := AA;
B := 0;
Sym := '';
SymVal := 0;
end;
constructor TSimpleSymbolicForm.Create(pA, qA: TASI);
begin
A := RationalNumber(pA, qA);
B := 0;
Sym := '';
SymVal := 0;
end;
constructor TSimpleSymbolicForm.Create(const AB: TRationalNumber;
const ASym: string; ASymVal: TASR);
begin
A := 0;
B := AB;
Sym := ASym;
SymVal := ASymVal;
end;
constructor TSimpleSymbolicForm.Create(pB, qB: TASI; const ASym: string;
ASymVal: TASR);
begin
A := 0;
B := RationalNumber(pB, qB);
Sym := ASym;
SymVal := ASymVal;
end;
constructor TSimpleSymbolicForm.CreateInvalid(const Val: TASR);
begin
SymVal := Val;
MakeInvalid;
end;
class operator TSimpleSymbolicForm.Implicit(const X: TRationalNumber): TSimpleSymbolicForm;
begin
Result := TSimpleSymbolicForm.Create(X);
end;
class operator TSimpleSymbolicForm.Implicit(const X: TSimpleSymbolicForm): TASR;
begin
if X.valid then
Result := TASR(X.A) + TASR(X.B) * X.SymVal
else
Result := X.SymVal;
end;
class operator TSimpleSymbolicForm.Add(const X: TRationalNumber;
const Y: TSimpleSymbolicForm): TSimpleSymbolicForm;
begin
Result := Y;
Result.A := Result.A + X;
end;
class operator TSimpleSymbolicForm.Multiply(const X: TRationalNumber;
const Y: TSimpleSymbolicForm): TSimpleSymbolicForm;
begin
Result := TSimpleSymbolicForm.Create(X * Y.A, X * Y.B, Y.Sym, Y.SymVal);
end;
function TSimpleSymbolicForm.str: string;
begin
Result := Format('(%s, %s, %s = %g)', [A.str, B.str, Sym, SymVal]);
end;
function TSimpleSymbolicForm.ToString(
const AFormatOptions: TFormatOptions): string;
var
LFormatOptions: TFormatOptions;
begin
Result := '';
if not valid then
Exit;
LFormatOptions := FixNumFmt(AFormatOptions, nfFraction);
if (A = 0) and (B = 0) then
Result := IntegerToStr(0, LFormatOptions)
else if (A <> 0) and (B = 0) then
Result := A.ToString(LFormatOptions)
else if (A = 0) and (B <> 0) then
Result := B.ToString(LFormatOptions, Sym)
else
begin
if B.Numerator > 0 then
Result := A.ToString(LFormatOptions) + ' + ' + B.ToString(LFormatOptions, Sym)
else
Result := A.ToString(LFormatOptions) + #32 + MINUS_SIGN + #32 + (-B).ToString(LFormatOptions, Sym)
end;
end;
function TSimpleSymbolicForm.sstr: string;
begin
Result := Format('(%s, %s, %s)', [A.str, B.str, Sym]);
end;
function TSimpleSymbolicForm.valid: Boolean;
begin
Result := A.valid and B.valid;
end;
procedure TSimpleSymbolicForm.MakeInvalid;
begin
A.Denominator := 0;
end;
function FixNumFmt(const AOptions: TFormatOptions; ANumFmt: TNumberFormat): TFormatOptions;
begin
Result := AOptions;
Result.Numbers.NumberFormat := ANumFmt;
end;
function IntegerToStr(const x: TASI; const AOptions: TFormatOptions): string;
var
y, Base, Rem: UInt64;
i, c, pStart: Integer;
NumDigits: array[0..255] of Char;
const
Digits: array[0..35] of Char = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
begin
if (AOptions.Numbers.Base = 10) or (AOptions.Numbers.Base < 2) or (AOptions.Numbers.Base > 36) or not TInt64Guard.CanAbs(x) then
begin
Result := x.ToString;
if AOptions.Numbers.MinLength > 0 then
begin
if x < 0 then
begin
Assert((Result.Length > 0) and (Result[1] = '-'));
Delete(Result, 1, 1);
end;
Result := Result.PadLeft(AOptions.Numbers.MinLength, '0');
if x < 0 then
Result := AOptions.Numbers.MinusSign + Result;
end;
end
else
begin
if x = 0 then
Result := StringOfChar('0', Max(1, AOptions.Numbers.MinLength))
else
begin
Assert(x.Size = y.Size);
Assert(8*x.Size <= Length(NumDigits));
{$WARN COMPARISON_TRUE OFF}
Assert(AOptions.Numbers.MinLength.MaxValue < Length(NumDigits));
{$WARN COMPARISON_TRUE DEFAULT}
y := UInt64(Abs(x));
Base := AOptions.Numbers.Base;
FillChar(NumDigits, SizeOf(NumDigits), 0);
c := 0;
while y <> 0 do
begin
DivMod(y, Base, y, Rem);
Assert(InRange(Rem, Low(Digits), High(Digits)));
Assert(c <= High(NumDigits));
NumDigits[c] := Digits[Rem];
Inc(c);
end;
while c < AOptions.Numbers.MinLength do
begin
Assert(c <= High(NumDigits));
NumDigits[c] := '0';
Inc(c);
end;
if x < 0 then
begin
Assert(c <= High(NumDigits));
NumDigits[c] := AOptions.Numbers.MinusSign;
Inc(c);
end;
SetLength(Result, c);
for i := 1 to c do
Result[i] := NumDigits[c - i];
end;
end;
if (Result.Length > 0) and (Result[1] = '-') then
Result[1] := AOptions.Numbers.MinusSign;
if AOptions.Numbers.IntGrouping > 0 then
begin
i := Result.Length;
if (Result.Length > 0) and (Result[1] = AOptions.Numbers.MinusSign) then
pStart := 2
else
pStart := 1;
c := 1;
while i > pStart do
begin
if c mod AOptions.Numbers.IntGrouping = 0 then
Insert(AOptions.Numbers.IntGropingChar, Result, i);
Dec(i);
Inc(c);
end;
end;
end;
function RealToStr(const x: TASR; const AOptions: TFormatOptions): string;
var
i, c: Integer;
pPeriod, pExp, pStart, pEnd: Integer;
begin
if IsInfinite(x) then
case Sign(x) of
+1:
Exit('∞');
-1:
Exit('−∞');
end;
case AOptions.Numbers.NumberFormat of
nfFixed:
Result := FloatToStrF(x, ffFixed, 18, AOptions.Numbers.NumDigits, FS);
nfExponent:
Result := FloatToStrF(x, ffExponent, AOptions.Numbers.NumDigits, 0, FS);
else
Result := FloatToStrF(x, ffGeneral, AOptions.Numbers.NumDigits, 0, FS);
end;
for i := 1 to Result.Length - 1 do
if Result[i] = '-' then
Result[i] := AOptions.Numbers.MinusSign;
if AOptions.Numbers.PrettyExp then
for i := 1 to Result.Length - 1 do
if Result[i] = 'E' then
begin
Delete(Result, i, 1);
if Result[i] = '+' then
Delete(Result, i, 1);
Insert('⋅10^', Result, i);
Break;
end;
if AOptions.Numbers.IntGrouping + AOptions.Numbers.FracGrouping > 0 then
begin
pPeriod := 0;
for i := 1 to Result.Length do
if Result[i] = '.' then
begin
pPeriod := i;
Break;
end;
pExp := 0;
for i := 1 to Result.Length do
if (Result[i] = 'E') or (Result[i] = DOT_OPERATOR) then
begin
pExp := i;
Break;
end;
if AOptions.Numbers.IntGrouping > 0 then
begin
if pPeriod > 0 then
i := pPeriod - 1
else if pExp > 0 then
i := pExp - 1
else
i := Result.Length;
if (Result.Length > 0) and (Result[1] = AOptions.Numbers.MinusSign) then
pStart := 2
else
pStart := 1;
c := 1;
while i > pStart do
begin
if c mod AOptions.Numbers.IntGrouping = 0 then
begin
Insert(AOptions.Numbers.IntGropingChar, Result, i);
if pPeriod > 0 then
Inc(pPeriod);
if pExp > 0 then
Inc(pExp);
end;
Dec(i);
Inc(c);
end;
end;
if (AOptions.Numbers.FracGrouping > 0) and (pPeriod > 0) then
begin
if pExp > 0 then
pEnd := pExp - 1
else
pEnd := Result.Length;
i := pPeriod + 2;
c := 1;
while i <= pEnd do
begin
if c mod AOptions.Numbers.FracGrouping = 0 then
begin
Insert(AOptions.Numbers.FracGroupingChar, Result, i);
Inc(i);
Inc(pEnd);
end;
Inc(i);
Inc(c);
end;
end;
end;
end;
type
TStandardOrderASRComparer = class(TComparer<TASR>)
function Compare(const Left, Right: TASR): Integer; override;
end;
TDescendingStandardOrderASRComparer = class(TComparer<TASR>)
function Compare(const Left, Right: TASR): Integer; override;
end;
TAbsoluteValueASRComparer = class(TComparer<TASR>)
function Compare(const Left, Right: TASR): Integer; override;
end;
TDescendingAbsoluteValueASRComparer = class(TComparer<TASR>)
function Compare(const Left, Right: TASR): Integer; override;
end;
function TStandardOrderASRComparer.Compare(const Left, Right: TASR): Integer;
begin
Result := CompareValue(Left, Right);
end;
function TDescendingStandardOrderASRComparer.Compare(const Left, Right: TASR): Integer;
begin
Result := -CompareValue(Left, Right);
end;
function TAbsoluteValueASRComparer.Compare(const Left, Right: TASR): Integer;
begin
Result := CompareValue(Abs(Left), Abs(Right));
if Result = 0 then
Result := CompareValue(Left, Right);
end;
function TDescendingAbsoluteValueASRComparer.Compare(const Left, Right: TASR): Integer;
begin
Result := CompareValue(Abs(Left), Abs(Right));
if Result = 0 then
Result := CompareValue(Left, Right);
Result := -Result;
end;
class constructor TASRComparer.ClassCreate;
begin
TASRComparer.StandardOrder := TStandardOrderASRComparer.Create;
TASRComparer.StandardOrderDescending := TDescendingStandardOrderASRComparer.Create;
TASRComparer.AbsoluteValue := TAbsoluteValueASRComparer.Create;
TASRComparer.AbsoluteValueDescending := TDescendingAbsoluteValueASRComparer.Create;
end;
function pow(const a, b: TASR): TASR;
begin
if (a = 0) and (b = 0) then
raise EMathException.Create('Zero raised to the power of zero.');
Result := Math.Power(a, b);
end;
function intpow(const a, b: TASI): TASI;
var
i: TASI;
begin
if b < 0 then
raise EMathException.Create('Integer power requires a non-negative exponent.');
Result := 1;
for i := 1 to b do
Result := Result * a;
end;
function cbrt(const X: TASR): TASR; inline;
begin
Result := Math.Power(X, 1/3);
end;
function frt(const X: TASR): TASR; inline;
begin
Result := Math.Power(X, 1/4);
end;
function tanh(const X: TASR): TASR; inline;
var
yp, ym: TASR;
begin
yp := exp(x);
ym := exp(-x);
Result := (yp - ym) / (yp + ym);
end;
function coth(const X: TASR): TASR; inline;
var
yp, ym: TASR;
begin
yp := exp(x);
ym := exp(-x);
Result := (yp + ym) / (yp - ym);
end;
function sech(const X: TASR): TASR; inline;
begin
{$IF sizeof(TASR) = 10}
if Abs(X) > 11300 then
Exit(0.0);
{$ELSE}
if Abs(X) > 700 then
Exit(0.0);
{$ENDIF}
Result := 2 / (exp(X) + exp(-X));
end;
function csch(const X: TASR): TASR; inline;
begin
{$IF sizeof(TASR) = 10}
if Abs(X) > 11300 then
Exit(0.0);
{$ELSE}
if Abs(X) > 700 then
Exit(0.0);
{$ENDIF}
Result := 2 / (exp(X) - exp(-X));
end;
function arcsinh(const X: TASR): TASR; inline;
begin
if X >= 0 then
Result := Math.ArcSinh(X)
else
Result := -Math.ArcSinh(-X);
end;
function arccsch(const X: TASR): TASR; inline;
var
y: TASR;
begin
if X >= 0 then
begin
y := 1/x;
Result := ln(y + sqrt(y*y + 1));
end
else
begin
y := 1/-x;
Result := -ln(y + sqrt(y*y + 1));
end;
end;
function sinc(const X: TASR): TASR; inline;
begin
if IsZero(X) then
Result := 1
else
Result := sin(x) / x;
end;
class operator TASC.Implicit(const r: TASR): TASC;
begin
Result.Re := r;
Result.Im := 0;
end;
class operator TASC.Positive(const z: TASC): TASC;
begin
Result := z;
end;
function TASC.pstr: string;
begin
Result := ComplexToStr(Self, False, DefaultFormatOptions);
end;
class operator TASC.Negative(const z: TASC): TASC;
begin
Result.Re := -z.Re;
Result.Im := -z.Im;
end;
class operator TASC.Add(const z1: TASC; const z2: TASC): TASC;
begin
Result.Re := z1.Re + z2.Re;
Result.Im := z1.Im + z2.Im;
end;
class operator TASC.Subtract(const z1: TASC; const z2: TASC): TASC;
begin
Result.Re := z1.Re - z2.Re;
Result.Im := z1.Im - z2.Im;
end;
class operator TASC.Multiply(const z1: TASC; const z2: TASC): TASC;
begin
Result.Re := z1.Re * z2.Re - z1.Im * z2.Im;
Result.Im := z1.Re * z2.Im + z1.Im * z2.Re;
end;
class operator TASC.Divide(const z1: TASC; const z2: TASC): TASC;
var
denom: TASR;
begin
denom := z2.Re * z2.Re + z2.Im * z2.Im;
Result.Re := (z1.Re * z2.Re + z1.Im * z2.Im) / denom;
Result.Im := (z1.Im * z2.Re - z1.Re * z2.Im) / denom;
end;
class operator TASC.Equal(const z1: TASC; const z2: TASC): Boolean;
begin
Result := (z1.Re = z2.Re) and (z1.Im = z2.Im);
end;
class operator TASC.NotEqual(const z1: TASC; const z2: TASC): Boolean;
begin
Result := not (z1 = z2);
end;
class operator TASC.Round(const z: TASC): TASC;
begin
Result.Re := Round(z.Re);
Result.Im := Round(z.Im);
end;
class operator TASC.Trunc(const z: TASC): TASC;
begin
Result.Re := Trunc(z.Re);
Result.Im := Trunc(z.Im);
end;
function TASC.Modulus: TASR;
begin
Result := Hypot(Re, Im);
end;
function TASC.Argument: TASR;
begin
Result := ArcTan2(Im, Re);
end;
function TASC.Conjugate: TASC;
begin
Result.Re := Re;
Result.Im := -Im;
end;
function TASC.Sqr: TASC;
begin
Result.Re := System.Sqr(Re) - System.Sqr(Im);
Result.Im := 2*Re*Im;
end;
function TASC.ModSqr: TASR;
begin
Result := System.Sqr(Re) + System.Sqr(Im);
end;
function TASC.Inverse: TASC;
var
h: TASR;
begin
h := System.Sqr(Re) + System.Sqr(Im);
Result.Re := Re/h;
Result.Im := -Im/h;
end;
function TASC.IsReal: Boolean;
begin
Result := IsZero(Im);
end;
function TASC.Defuzz(const Eps: Double): TASC;
begin
if IsInteger(Re, Eps) then
Result.Re := Round(Re)
else
Result.Re := Re;
if IsInteger(Im, Eps) then
Result.Im := Round(Im)
else
Result.Im := Im;
end;
function TASC.str: string;
begin
Result := Format('(%.18g, %.18g)', [Re, Im]);
end;
function ASC(const Re, Im: TASR): TASC; inline;
begin
Result.Re := Re;
Result.Im := Im;
end;
function ASC_COUNT(const A, B: TASC): TASC;
begin
Result := A + 1;
end;
function ASC_PLUS(const A, B: TASC): TASC;
begin
Result := A + B;
end;
function ASC_TIMES(const A, B: TASC): TASC;
begin
Result := A * B;
end;
function ComplexToStr(const z: TASC; ApproxEq: Boolean;
const AOptions: TFormatOptions): string;
var
Re0, Im0, Im1, ImN1: Boolean;
begin
if ApproxEq then
begin
Re0 := IsZero(z.Re);
Im0 := IsZero(z.Im);
Im1 := IsZero(z.Im - 1);
ImN1 := IsZero(z.Im + 1);
end
else
begin
Re0 := z.Re = 0;
Im0 := z.Im = 0;
Im1 := z.Im = 1;
ImN1 := z.Im = -1;
end;
if Re0 and Im0 then
Result := RealToStr(0, AOptions)
else if Im0 then
Result := RealToStr(z.Re, AOptions)
else if Re0 then
if Im1 then
Result := 'i'
else if ImN1 then
Result := AOptions.Complex.MinusSign + 'i'
else
Result := RealToStr(z.Im, AOptions) + AOptions.Complex.ImaginarySuffix
else
if Im1 then
Result := RealToStr(z.Re, AOptions) + AOptions.Complex.PlusStr + 'i'
else if ImN1 then
Result := RealToStr(z.Re, AOptions) + AOptions.Complex.MinusStr + 'i'
else if z.Im > 0 then
Result := RealToStr(z.Re, AOptions) + AOptions.Complex.PlusStr + RealToStr(z.Im, AOptions) + AOptions.Complex.ImaginarySuffix
else
Result := RealToStr(z.Re, AOptions) + AOptions.Complex.MinusStr + RealToStr(-z.Im, AOptions) + AOptions.Complex.ImaginarySuffix;
end;
function TryStringToComplex(AString: string; out Value: TASC;
ASignRequired: Boolean = False): Boolean;
var
num: TASR;
part1, part2: TASC;
len: Integer;
i, p, p2, pp: Integer;
signed, period, exp, neg, times, imag: Boolean;
procedure SkipWhitespace;
begin
while (i <= len) and AString[i].IsWhiteSpace do Inc(i);
end;
procedure SkipTrailingWhitespace;
var
j: Integer;
begin
j := i;
while (j <= len) and AString[j].IsWhiteSpace do Inc(j);
if j > len then
begin
p2 := i;
i := j;
end;
end;
procedure SkipDigits;
begin
while (i <= len) and AString[i].IsDigit do Inc(i);
end;
function EOF: Boolean;
begin
Result := i > len;
end;
procedure SkipSign;
begin
if (i <= len) and inOpArray(AString[i], ['+', '-']) then Inc(i);
end;
procedure SkipSignEx;
begin
if i <= len then
if AString[i] = '+' then
begin
signed := True;
Inc(i);
end
else if AString[i] = '-' then
begin
signed := True;
neg := not neg;
Inc(i);
end;
end;
procedure SkipPeriod;
begin
if (i <= len) and (AString[i] = '.') and not period then
begin
period := True;
Inc(i);
end;
end;
function sign: TASR;
begin
Result := IfThen(neg, -1, 1);
end;
function basis: TASC;
begin
if imag then
Result := ImaginaryUnit
else
Result := 1;
end;
function TryDone: Boolean;
var
res: Boolean;
begin
if i > len then
begin
res := TryStrToFloat(Copy(AString, p, p2 - p), num, FS);
TryStringToComplex := res;
if res then Value := sign * num;
Exit(True);
end
else
Result := False;
end;
procedure SkipExp;
begin
if (i <= len) and (AString[i] = 'e') and not exp then
begin
exp := True;
Inc(i);
end;
end;
procedure SkipTimes;
begin
if (i <= len) and (AString[i] = '*') then
begin
times := True;
Inc(i);
end;
end;
procedure SkipImUnit;
begin
if (i <= len) and (AString[i] = 'i') and not imag then
begin
imag := True;
Inc(i);
end;
end;
begin
len := Length(AString);
signed := False;
period := False;
exp := False;
times := False;
imag := False;
neg := False;
p2 := 128;
for i := 1 to len do
case AString[i] of
MINUS_SIGN:
AString[i] := '-';
'I', 'j', 'J':
AString[i] := 'i';
DOT_OPERATOR:
AString[i] := '*';
'E':
AString[i] := 'e';
end;
i := 1;
SkipWhitespace;
if EOF then Exit(False);
SkipSignEx;
if ASignRequired and not signed then Exit(False);
SkipWhitespace;
p := i;
SkipPeriod;
if TryDone then Exit;
SkipDigits;
SkipTrailingWhitespace;
if TryDone then Exit;
SkipPeriod;
SkipTrailingWhitespace;
if TryDone then Exit;
SkipDigits;
SkipTrailingWhitespace;
if TryDone then Exit;
SkipExp;
if EOF then Exit(False);
if exp then SkipSign;
if EOF then Exit(False);
pp := i;
SkipDigits;
if exp and (i = pp) then Exit(False);
p2 := i;
SkipWhitespace;
if TryDone then Exit;
SkipTimes;
SkipWhitespace;
if EOF then Exit(False);
SkipImUnit;
SkipWhitespace;
if times and not imag then Exit(False);
if i > len then
begin
Assert(imag);
num := 1;
Result := (p = p2) or TryStrToFloat(Copy(AString, p, p2 - p), num, FS);
if Result then Value := sign * num * ImaginaryUnit;
Exit;
end;
num := 1;
if (imag and (p = p2)) or TryStrToFloat(Copy(AString, p, p2 - p), num, FS) then
begin
part1 := sign * num * basis;
if i = 1 then Exit(False);
if TryStringToComplex(Copy(AString, i), part2, True) then
begin
Value := part1 + part2;
Exit(True);
end;
end;
Result := False;
end;
function CSameValue(const z1, z2: TASC; const Epsilon: TASR = 0): Boolean; inline;
begin
Result := SameValue(z1.Re, z2.Re, Epsilon) and SameValue(z1.Im, z2.Im, Epsilon);
end;
function CSameValueEx(const z1, z2: TASC; const Epsilon: TASR = 0): Boolean; inline;
begin
Result := SameValueEx(z1.Re, z2.Re, Epsilon) and SameValueEx(z1.Im, z2.Im, Epsilon);
end;
function CIsZero(const z: TASC; const Epsilon: TASR): Boolean; overload; inline;
begin
Result := IsZero(z.Re, Epsilon) and IsZero(z.Im, Epsilon);
end;
function IntegerPowerOfImaginaryUnit(const n: Integer): TASC;
const
vals: array[0..3] of TASC = ((Re: 1; Im: 0), (Re: 0; Im: 1), (Re: -1; Im: 0), (Re: 0; Im: -1));
begin
Result := vals[imod(n, Length(vals))];
end;
function SameValue2(const A, B: TASC): Boolean; overload;
begin
Result := SameValue2(A.Re, B.Re) and SameValue2(A.Im, B.Im);
end;
function CompareValue(const A, B: TASC; Epsilon: Extended): TValueRelationship;
begin
if CSameValue(A, B, Epsilon) then
Result := EqualsValue
else if (A.Re < B.Re) or ((A.Re = B.Re) and (A.Im < B.Im)) then
Result := LessThanValue
else
Result := GreaterThanValue;
end;
type
TReImASCComparer = class(TComparer<TASC>)
function Compare(const Left, Right: TASC): Integer; override;
end;
TDescendingReImASCComparer = class(TComparer<TASC>)
function Compare(const Left, Right: TASC): Integer; override;
end;
TModulusASCComparer = class(TComparer<TASC>)
function Compare(const Left, Right: TASC): Integer; override;
end;
TDescendingModulusASCComparer = class(TComparer<TASC>)
function Compare(const Left, Right: TASC): Integer; override;
end;
TArgASCComparer = class(TComparer<TASC>)
function Compare(const Left, Right: TASC): Integer; override;
end;
TDescendingArgASCComparer = class(TComparer<TASC>)
function Compare(const Left, Right: TASC): Integer; override;
end;
TModulusArgumentASCComparer = class(TComparer<TASC>)
function Compare(const Left, Right: TASC): Integer; override;
end;
TDescendingModulusArgumentASCComparer = class(TComparer<TASC>)
function Compare(const Left, Right: TASC): Integer; override;
end;
function TReImASCComparer.Compare(const Left, Right: TASC): Integer;
begin
Result := CompareValue(Left.Re, Right.Re);
if Result = 0 then
Result := CompareValue(Left.Im, Right.Im);
end;
function TDescendingReImASCComparer.Compare(const Left, Right: TASC): Integer;
begin
Result := CompareValue(Left.Re, Right.Re);
if Result = 0 then
Result := CompareValue(Left.Im, Right.Im);
Result := -Result;
end;
function TModulusASCComparer.Compare(const Left, Right: TASC): Integer;
begin
Result := CompareValue(Left.Modulus, Right.Modulus);
if Result = 0 then
Result := CompareValue(Left.Re, Right.Re);
if Result = 0 then
Result := CompareValue(Left.Im, Right.Im);
end;
function TDescendingModulusASCComparer.Compare(const Left, Right: TASC): Integer;
begin
Result := CompareValue(Left.Modulus, Right.Modulus);
if Result = 0 then
Result := CompareValue(Left.Re, Right.Re);
if Result = 0 then
Result := CompareValue(Left.Im, Right.Im);
Result := -Result;
end;
function TArgASCComparer.Compare(const Left, Right: TASC): Integer;
var
LA, RA: TASR;
begin
LA := Left.Argument;
if SameValue(LA, -Pi) then
LA := Pi;
RA := Right.Argument;
if SameValue(RA, -Pi) then
RA := Pi;
Result := CompareValue(LA, RA);
if Result = 0 then
Result := CompareValue(Left.Modulus, Right.Modulus);
end;
function TDescendingArgASCComparer.Compare(const Left, Right: TASC): Integer;
var
LA, RA: TASR;
begin
LA := Left.Argument;
if SameValue(LA, -Pi) then
LA := Pi;
RA := Right.Argument;
if SameValue(RA, -Pi) then
RA := Pi;
Result := CompareValue(LA, RA);
if Result = 0 then
Result := CompareValue(Left.Modulus, Right.Modulus);
Result := -Result;
end;
function TModulusArgumentASCComparer.Compare(const Left, Right: TASC): Integer;
var
LA, RA: TASR;
begin
Result := CompareValue(Left.Modulus, Right.Modulus);
if Result = 0 then
begin
LA := Left.Argument;
if SameValue(LA, -Pi) then
LA := Pi;
RA := Right.Argument;
if SameValue(RA, -Pi) then
RA := Pi;
Result := CompareValue(LA, RA);
end;
end;
function TDescendingModulusArgumentASCComparer.Compare(const Left, Right: TASC): Integer;
var
LA, RA: TASR;
begin
Result := CompareValue(Left.Modulus, Right.Modulus);
if Result = 0 then
begin
LA := Left.Argument;
if SameValue(LA, -Pi) then
LA := Pi;
RA := Right.Argument;
if SameValue(RA, -Pi) then
RA := Pi;
Result := CompareValue(LA, RA);
end;
Result := -Result;
end;
class constructor TASCComparer.ClassCreate;
begin
TASCComparer.ReIm := TReImASCComparer.Create;
TASCComparer.ReImDescending := TDescendingReImASCComparer.Create;
TASCComparer.Modulus := TModulusASCComparer.Create;
TASCComparer.ModulusDescending := TDescendingModulusASCComparer.Create;
TASCComparer.Argument := TArgASCComparer.Create;
TASCComparer.ArgumentDescending := TDescendingArgASCComparer.Create;
TASCComparer.ModulusArgument := TModulusArgumentASCComparer.Create;
TASCComparer.ModulusArgumentDescending := TDescendingModulusArgumentASCComparer.Create;
end;
function csign(const z: TASC): TASC; inline;
begin
if CIsZero(z) then
Result := 0
else
Result := z / z.Modulus;
end;
function cexp(const z: TASC): TASC; inline;
var
e, s, c: TASR;
begin
e := exp(z.Re);
SinCos(z.Im, s, c);
Result.Re := e * c;
Result.Im := e * s;
end;
function cln(const z: TASC): TASC; inline;
begin
Result.Re := ln(z.Modulus);
Result.Im := z.Argument;
end;
function clog(const z: TASC): TASC; inline;
begin
Result := cln(z) * InvLn10;
end;
function cpow(const z, w: TASC): TASC;
var
n: Integer;
i: Integer;
begin
if z = 0 then
if w.Re > 0 then
Exit(0)
else
raise EMathException.Create('Zero raised to a complex number with non-positive real part.');
if IsZero(w.Im) and IsZero(frac(w.Re)) and (abs(w.Re) < 13) then
begin
n := round(w.Re);
if n > 0 then
begin
Result := z;
for i := 2 to n do
Result := Result * z;
Exit;
end
else if n < 0 then
begin
Result := z;
for i := 2 to -n do
Result := Result * z;
Exit(1/Result);
end
else if (n = 0) and (z <> 0) then
Exit(1)
else
raise EMathException.Create('Zero raised to the power of zero.');
end
else if ((z.Im = 0) and (w.Im = 0)) and
((z.Re > 0) or ((z.Re = 0) and (w.Re > 0)) or ((z.Re < 0) and (frac(w.Re) = 0))) then
Exit(pow(z.Re, w.Re))
else if (z.Re = 0) and (w.Im = 0) and (frac(w.Re) = 0) then
Exit(IntPower(z.Im, round(w.Re)) * IntegerPowerOfImaginaryUnit(round(w.Re)));
Result := cexp(w * cln(z));
end;
function csqrt(const z: TASC): TASC; inline;
begin
if (z.Im = 0) and (z.Re >= 0) then
Exit(sqrt(z.Re));
if (z.Im = 0) and (z.Re < 0) then
Exit(ASC(0, sqrt(-z.Re)));
Result := cexp(cln(z)/2);
end;
function csin(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(sin(z.Re));
{$ENDIF}
Result := (cexp(ImaginaryUnit*z) - cexp(NegativeImaginaryUnit*z)) / (2*ImaginaryUnit);
end;
function ccos(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(cos(z.Re));
{$ENDIF}
Result := (cexp(ImaginaryUnit*z) + cexp(NegativeImaginaryUnit*z)) / 2;
end;
function ctan(const z: TASC): TASC; inline;
var
w: TASC;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(tan(z.Re));
{$ENDIF}
w := cexp(2*ImaginaryUnit*z);
Result := NegativeImaginaryUnit * (w - 1)/(w + 1);
end;
function ccot(const z: TASC): TASC; inline;
var
w: TASC;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(cot(z.Re));
{$ENDIF}
w := cexp(2*ImaginaryUnit*z);
Result := ImaginaryUnit * (w + 1)/(w - 1);
end;
function csec(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(sec(z.Re));
{$ENDIF}
Result := 2 / (cexp(ImaginaryUnit*z) + cexp(NegativeImaginaryUnit*z));
end;
function ccsc(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(csc(z.Re));
{$ENDIF}
Result := (2*ImaginaryUnit) / (cexp(ImaginaryUnit*z) - cexp(NegativeImaginaryUnit*z));
end;
function carcsin(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if (z.Im = 0) and InRange(z.Re, -1, 1) then
Exit(arcsin(z.Re));
{$ENDIF}
Result := NegativeImaginaryUnit * cln(ImaginaryUnit * z + csqrt(1 - z.Sqr));
end;
function carccos(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if (z.Im = 0) and InRange(z.Re, -1, 1) then
Exit(arccos(z.Re));
{$ENDIF}
Result := PiDiv2 + ImaginaryUnit * cln(ImaginaryUnit * z + csqrt(1 - z.Sqr));
end;
function carctan(const z: TASC): TASC; inline;
var
w: TASC;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(arctan(z.Re));
{$ENDIF}
w := ImaginaryUnit * z;
Result := ImaginaryUnitDiv2 * (cln(1 - w) - cln(1 + w));
end;
function carccot(const z: TASC): TASC; inline;
var
w: TASC;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(arccot(z.Re));
{$ENDIF}
if CIsZero(z) then
Result := PiDiv2
else
begin
w := ImaginaryUnit / z;
Result := ImaginaryUnitDiv2 * (cln(1 - w) - cln(1 + w))
end;
end;
function carcsec(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if (z.Im = 0) and (abs(z.Re) >= 1) then
Exit(arcsec(z.Re));
{$ENDIF}
Result := PiDiv2 + ImaginaryUnit * cln(ImaginaryUnit / z + csqrt(1 - z.Inverse.Sqr));
end;
function carccsc(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if (z.Im = 0) and (abs(z.Re) >= 1) then
Exit(arccsc(z.Re));
{$ENDIF}
Result := NegativeImaginaryUnit * cln(ImaginaryUnit / z + csqrt(1 - z.Inverse.Sqr));
end;
function csinh(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(sinh(z.Re));
{$ENDIF}
Result := (cexp(z) - cexp(-z)) / 2;
end;
function ccosh(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(cosh(z.Re));
{$ENDIF}
Result := (cexp(z) + cexp(-z)) / 2;
end;
function ctanh(const z: TASC): TASC; inline;
var
w: TASC;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(tanh(z.Re));
{$ENDIF}
w := cexp(2*z);
Result := (w - 1)/(w + 1);
end;
function ccoth(const z: TASC): TASC; inline;
var
w: TASC;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(coth(z.Re));
{$ENDIF}
w := cexp(2*z);
Result := (w + 1)/(w - 1);
end;
function csech(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(sech(z.Re));
{$ENDIF}
Result := 2 / (cexp(z) + cexp(-z));
end;
function ccsch(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(csch(z.Re));
{$ENDIF}
Result := 2 / (cexp(z) - cexp(-z));
end;
function carcsinh(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(arcsinh(z.Re));
{$ENDIF}
Result := cln(z + csqrt(1 + z.Sqr));
end;
function carccosh(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if (z.Im = 0) and (z.Re >= 1) then
Exit(arccosh(z.Re));
{$ENDIF}
Result := cln(z + csqrt(z + 1) * csqrt(z - 1));
end;
function carctanh(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if (z.Im = 0) and (z.Re > -1) and (z.Re < 1) then
Exit(arctanh(z.Re));
{$ENDIF}
Result := (cln(1 + z) - cln(1 - z)) / 2;
end;
function carccoth(const z: TASC): TASC; inline;
var
w: TASC;
begin
{$IFDEF REALCHECK}
if (z.Im = 0) and ((z.Re < -1) or (z.Re > 1)) then
Exit(arccoth(z.Re));
{$ENDIF}
if CIsZero(z) then
Result := PiDiv2 * ImaginaryUnit
else
begin
w := z.Inverse;
Result := (cln(1 + w) - cln(1 - w)) / 2;
end;
end;
function carcsech(const z: TASC): TASC; inline;
var
w: TASC;
begin
{$IFDEF REALCHECK}
if (z.Im = 0) and (z.Re > 0) and (z.Re <= 1) then
Exit(arcsech(z.Re));
{$ENDIF}
w := z.Inverse;
Result := cln(w + csqrt(w + 1) * csqrt(w - 1));
end;
function carccsch(const z: TASC): TASC; inline;
var
w: TASC;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(arccsch(z.Re));
{$ENDIF}
w := z.Inverse;
Result := cln(w + csqrt(1 + w.Sqr));
end;
function csinc(const z: TASC): TASC; inline;
begin
{$IFDEF REALCHECK}
if z.Im = 0 then
Exit(sinc(z.Re));
{$ENDIF}
if CIsZero(z) then
Result := 1
else
Result := csin(z) / z;
end;
function CollapseWithMultiplicity(const ANumbers: array of TASI): TArray<TIntWithMultiplicity>;
var
ActualLength: Integer;
i, c: Integer;
PrevNumber: TASI;
procedure New(ANumber: TASI);
begin
PrevNumber := ANumber;
c := 1;
end;
procedure Add;
begin
Result[ActualLength].Factor := PrevNumber;
Result[ActualLength].Multiplicity := c;
Inc(ActualLength);
end;
begin
SetLength(Result, Length(ANumbers));
ActualLength := 0;
for i := 0 to High(ANumbers) do
begin
if i = 0 then
New(ANumbers[i])
else if ANumbers[i] <> PrevNumber then
begin
Add;
New(ANumbers[i]);
end
else
Inc(c);
end;
if Length(ANumbers) > 0 then
Add;
SetLength(Result, ActualLength);
end;
function GetDigit(N: TASI; Index: Integer): Integer;
begin
if Index < 0 then
Exit(0);
while (Index > 0) and (N <> 0) do
begin
N := N div 10;
Dec(Index);
end;
Result := Abs(N mod 10);
end;
function GetDigits(N: TASI): TArray<Integer>;
begin
if N = 0 then
Result := [0]
else
while N <> 0 do
begin
TArrBuilder<Integer>.Add(Result, Abs(N mod 10));
N := N div 10;
end;
end;
procedure _RatDigits(const R: TRationalNumber; Index: Integer;
const Mode: TRatDigitMode; AFullOutput, ARound: Boolean; out Digit: Integer;
out Digits: TArray<Integer>; AFirstDigitPos, AFirstSigDigitPos: PInteger);
function makenum(source: TArray<Integer>; start, len: Integer): TASI;
var
i: Integer;
j: TASI;
begin
Result := 0;
j := 1;
for i := start to start + len - 1 do
begin
if i >= 0 then
Inc(Result, source[i] * j);
j := 10 * j;
end;
end;
var
LFirstDigitPos: Integer;
Numerator, Denominator: TArray<Integer>;
Pos: Integer;
CurNumerator, Quotient, Remainder: TASI;
Sig: Integer;
Rounding: Boolean;
EffectRound: Boolean;
i: Integer;
begin
Rounding := False;
EffectRound := False;
Numerator := GetDigits(R.Numerator);
Denominator := GetDigits(R.Denominator);
if Length(Denominator) >= 18 then
raise EMathException.Create('Denominator too large.');
Pos := Length(Numerator) - Length(Denominator);
CurNumerator := makenum(Numerator, Pos, Length(Denominator));
LFirstDigitPos := LFirstDigitPos.MaxValue;
if Mode <> rdmSingle then
begin
if Assigned(AFirstDigitPos) then
AFirstDigitPos^ := AFirstDigitPos^.MaxValue;
if Assigned(AFirstSigDigitPos) then
AFirstSigDigitPos^ := AFirstSigDigitPos^.MaxValue;
end;
case Mode of
rdmSingle:
begin
Digit := 0;
if (R.Numerator = 0) or (Index > Pos) then
Exit;
end;
rdmFractional:
begin
if R.Numerator = 0 then
begin
SetLength(Digits, Index + 1);
if Assigned(AFirstDigitPos) then
AFirstDigitPos^ := 0;
Exit;
end;
if Pos < 0 then
begin
SetLength(Digits, Min(-Pos, 1 + Index));
if Assigned(AFirstDigitPos) then
AFirstDigitPos^ := 0;
LFirstDigitPos := 0;
if Length(Digits) - 1 >= Index then
begin
if ARound and (-Pos = Index + 1) then
Rounding := True
else
Exit;
end;
end;
end;
rdmSignificant:
begin
if R.Numerator = 0 then
begin
SetLength(Digits, Index);
if Assigned(AFirstDigitPos) then
AFirstDigitPos^ := 0;
Exit;
end;
end;
rdmFixedSignificant:
begin
if R.Numerator = 0 then
begin
SetLength(Digits, Index);
if Assigned(AFirstDigitPos) then
AFirstDigitPos^ := 0;
Exit;
end;
if Pos < 0 then
begin
SetLength(Digits, -Pos);
if Assigned(AFirstDigitPos) then
AFirstDigitPos^ := 0;
LFirstDigitPos := 0;
end;
end;
else
raise Exception.CreateFmt('Unsupported rational digit extraction mode: %d', [Ord(Mode)]);
end;
Sig := 0;
while True do
begin
Quotient := CurNumerator div R.Denominator;
Remainder := CurNumerator mod R.Denominator;
case Mode of
rdmSingle:
begin
if Pos = Index then
begin
Digit := Quotient;
Exit;
end;
if (Pos < 0) and (Remainder = 0) then
Exit;
end;
rdmFractional:
begin
if Rounding then
begin
if Quotient >= 5 then
begin
EffectRound := True;
if Assigned(AFirstSigDigitPos) and (AFirstSigDigitPos^ = AFirstSigDigitPos^.MaxValue) then
AFirstSigDigitPos^ := Pos;
end;
Break;
end;
if (Pos <= 0) or (Length(Digits) > 0) or (Quotient <> 0) then
begin
if Assigned(AFirstDigitPos) then
if AFirstDigitPos^ = AFirstDigitPos^.MaxValue then
AFirstDigitPos^ := Pos;
if LFirstDigitPos = LFirstDigitPos.MaxValue then
LFirstDigitPos := Pos;
TArrBuilder<Integer>.Add(Digits, Quotient);
if (Quotient <> 0) or (Sig > 0) then
begin
if (Sig = 0) and Assigned(AFirstSigDigitPos) then
AFirstSigDigitPos^ := Pos;
Inc(Sig);
end;
end;
if not AFullOutput and (Pos <= 0) and (Remainder = 0) then
Break;
if Pos <= -Index then
begin
if ARound then
Rounding := True
else
Break;
end;
end;
rdmSignificant, rdmFixedSignificant:
begin
if Rounding then
begin
if Quotient >= 5 then
EffectRound := True;
Break;
end;
if (Length(Digits) > 0) or (Quotient <> 0) or (Pos <= 0) and (Mode = rdmFixedSignificant) then
begin
if Assigned(AFirstDigitPos) then
if AFirstDigitPos^ = AFirstDigitPos^.MaxValue then
AFirstDigitPos^ := Pos;
if LFirstDigitPos = LFirstDigitPos.MaxValue then
LFirstDigitPos := Pos;
TArrBuilder<Integer>.Add(Digits, Quotient);
if (Quotient <> 0) or (Sig > 0) then
begin
if (Sig = 0) and Assigned(AFirstSigDigitPos) then
AFirstSigDigitPos^ := Pos;
Inc(Sig);
end;
end;
if not AFullOutput and (Pos <= 0) and (Remainder = 0) then
Break;
if Sig >= Index then
begin
if ARound then
Rounding := True
else
Break;
end;
end;
else
raise Exception.CreateFmt('Unsupported rational digit extraction mode: %d', [Ord(Mode)]);
end;
CurNumerator := 10 * Remainder;
if Pos > 0 then
Inc(CurNumerator, Numerator[Pos - 1]);
Dec(Pos);
end;
if EffectRound then
begin
for i := High(Digits) downto 0 do
if Digits[i] <> 9 then
begin
Inc(Digits[i]);
Break;
end
else
begin
Digits[i] := 0;
if i = 0 then
begin
Insert([1], Digits, 0);
if Assigned(AFirstDigitPos) and (AFirstDigitPos^ <> AFirstDigitPos^.MaxValue) then
Inc(AFirstDigitPos^);
if LFirstDigitPos <> LFirstDigitPos.MaxValue then
Inc(LFirstDigitPos);
if Assigned(AFirstSigDigitPos) and (AFirstSigDigitPos^ <> AFirstSigDigitPos^.MaxValue) then
Inc(AFirstSigDigitPos^);
if Mode in [rdmSignificant, rdmFixedSignificant] then
SetLength(Digits, Pred(Length(Digits)));
Break;
end;
end;
end;
if not AFullOutput then
begin
i := High(Digits);
while (i > 0) and (Digits[i] = 0) and ((i > LFirstDigitPos) or (Mode <> rdmFixedSignificant)) do
Dec(i);
SetLength(Digits, i + 1);
end;
end;
function GetDigit(const R: TRationalNumber; Index: Integer): Integer; overload;
var
dummy: TArray<Integer>;
begin
_RatDigits(R, Index, rdmSingle, False, False, Result, dummy, nil, nil);
end;
function GetDigits(const R: TRationalNumber; Limit: Integer;
ALimitKind: TRatDigitMode; AFullOutput, ARound: Boolean;
AFirstDigitPos, AFirstSigDigitPos: PInteger): TArray<Integer>; overload;
var
dummy: Integer;
begin
_RatDigits(R, Limit, ALimitKind, AFullOutput, ARound, dummy, Result,
AFirstDigitPos, AFirstSigDigitPos);
end;
function GetDigits(const R: TRationalNumber; Limit: Integer;
ALimitKind: TRatDigitMode; AFullOutput, ARound: Boolean;
out AFracDigits: TArray<Integer>): TArray<Integer>; overload;
var
AIntDigits: TArray<Integer> absolute Result;
LDigits: TArray<Integer>;
LFirstDigitPos: Integer;
begin
LDigits := GetDigits(R, Limit, ALimitKind, AFullOutput, ARound, @LFirstDigitPos, nil);
if LFirstDigitPos >= 0 then
AIntDigits := Copy(LDigits, 0, LFirstDigitPos + 1)
else
AIntDigits := [0];
if LFirstDigitPos < 0 then
SetLength(AFracDigits, -LFirstDigitPos - 1);
TReverser<Integer>.Reverse(AIntDigits);
AFracDigits := AFracDigits + Copy(LDigits, LFirstDigitPos + 1);
end;
function GetDigit(X: TASR; Index: Integer): Integer; overload;
procedure ErrPrec;
begin
raise EMathException.Create('Cannot extract required digit from floating-point number due to insufficient precision.');
end;
var
IndexHigh: Integer;
IntVal: Int64;
const
PRECISION_DIGITS = 15;
begin
X := Abs(X);
if X = 0 then Exit(0);
IndexHigh := Floor(Log10(X));
if Index > IndexHigh then
Exit(0);
if IndexHigh - Index + 1 > PRECISION_DIGITS then
ErrPrec;
IntVal := Round(X * Math.IntPower(10, PRECISION_DIGITS - IndexHigh - 1));
Result := GetDigit(IntVal, PRECISION_DIGITS - 1 + (Index - IndexHigh));
end;
function IsInteger(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
begin
Result := InRange(X, TASI.MinValue + 1, TASI.MaxValue - 1) and SameValue(X, Round(X), Epsilon);
end;
function IsIntegerEx(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
begin
Result := InRange(X, TASI.MinValue + 1, TASI.MaxValue - 1) and SameValueEx(X, Round(X), Epsilon);
end;
function IsInteger32(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
begin
Result := InRange(X, Int32.MinValue + 1, Int32.MaxValue - 1) and SameValue(X, Round(X), Epsilon);
end;
function IsInteger32Ex(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
begin
Result := InRange(X, Int32.MinValue + 1, Int32.MaxValue - 1) and SameValueEx(X, Round(X), Epsilon);
end;
function IsInteger64(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
begin
Result := InRange(X, Int64.MinValue + 1, Int64.MaxValue - 1) and SameValue(X, Round(X), Epsilon);
end;
function IsInteger64Ex(const X: TASR; const Epsilon: Extended = 0): Boolean; inline;
begin
Result := InRange(X, Int64.MinValue + 1, Int64.MaxValue - 1) and SameValueEx(X, Round(X), Epsilon);
end;
function _fact32(const N: Integer): Integer;
var
i: Integer;
begin
if N < 0 then
raise EMathException.Create('Factorial of a negative number.');
if N > 12 then
raise EIntOverflow.Create('Integer overflow when computing 32-bit integer factorial.');
Result := 1;
for i := 2 to N do
Result := Result * i;
end;
function _fact64(const N: Integer): TASI;
var
i: Integer;
begin
if N < 0 then
raise EMathException.Create('Factorial of a negative number.');
if N > 20 then
raise EIntOverflow.Create('Integer overflow when computing 64-bit integer factorial.');
Result := 1;
for i := 2 to N do
Result := Result * i;
end;
function _factf(const N: Integer): TASR;
var
i: Integer;
begin
if N < 0 then
raise EMathException.Create('Factorial of a negative number.');
Result := 1;
for i := 2 to N do
Result := Result * i;
end;
function factorial(const N: Integer): TASR;
var
i: Integer;
begin
if N < 0 then
raise EMathException.Create('Factorial of a negative number.');
if N <= High(factorials) then
Exit(factorials[N]);
Result := factorials[High(factorials)];
for i := High(factorials) + 1 to N do
Result := Result * i;
end;
function combinations(n, k: Integer): TASR;
var
i: Integer;
begin
if not ((k >= 0) and (n >= k)) then
raise EMathException.Create('Binomial coefficient C(n, k) only defined for integers n and k satisfying 0 ≤ k ≤ n.');
if k > n - k then
k := n - k;
Result := 1.0;
for i := 0 to k - 1 do
Result := Result * (n - i) / (i + 1);
end;
function intcombinations(n, k: Integer): TASI;
var
i: Integer;
begin
if not ((k >= 0) and (n >= k)) then
raise EMathException.Create('Binomial coefficient C(n, k) only defined for integers n and k satisfying 0 ≤ k ≤ n.');
if k > n - k then
k := n - k;
Result := 1;
for i := 1 to k do
begin
if Result div i > Result.MaxValue div n then
Exit(0);
Result := (Result div i) * n + ((Result mod i) * n) div i;
Dec(n);
end;
end;
function binomial(const n, k: Integer): TASR; inline;
begin
Result := combinations(n, k);
end;
function permutations(n, k: Integer): TASR;
var
i: Integer;
begin
if not ((k >= 0) and (n >= k)) then
raise EMathException.Create('Binomial coefficient C(n, k) only defined for integers n and k satisfying 0 ≤ k ≤ n.');
Result := 1.0;
for i := n - k + 1 to n do
Result := Result * i;
end;
function intpermutations(n, k: Integer): TASI;
var
i: Integer;
begin
if not ((k >= 0) and (n >= k)) then
raise EMathException.Create('Binomial coefficient C(n, k) only defined for integers n and k satisfying 0 ≤ k ≤ n.');
Result := 1;
for i := n - k + 1 to n do
if Result < Result.MaxValue div i then
Result := Result * i
else
Exit(0);
end;
function lcm(const A, B: TASI): TASI; inline;
begin
if (a = 0) or (b = 0) then
Result := 0
else
Result := Abs((A div gcd(A, B)) * B);
end;
function lcm(const A, B: UInt64): UInt64; inline;
begin
if (a = 0) or (b = 0) then
Result := 0
else
Result := (A div gcd(A, B)) * B;
end;
function TryLCM(const A, B: TASI; var LCM: TASI): Boolean;
var
tmp: TASI;
begin
if (a = 0) or (b = 0) then
begin
Result := True;
LCM := 0;
end
else
begin
tmp := A div gcd(A, B);
Result := TInt64Guard.CanMul(tmp, B);
if Result then
LCM := tmp * B;
end;
end;
function lcm(const Values: array of TASI): TASI;
var
i: Integer;
begin
if Length(Values) = 0 then
raise EMathException.Create('Cannot compute the LCM of an empty list.');
Result := Abs(Values[0]);
for i := 1 to High(Values) do
Result := lcm(Result, Values[i]);
for i := 0 to High(Values) do
if (Values[i] <> 0) and (Result mod Values[i] <> 0) then
raise Exception.Create('LCM too large for the integer type.');
end;
function gcd(const A, B: TASI): TASI;
begin
if B = 0 then
Result := Abs(A)
else
Result := gcd(B, A mod B);
end;
function gcd(const A, B: UInt64): UInt64;
begin
if B = 0 then
Result := A
else
Result := gcd(B, A mod B);
end;
function gcd(const Values: array of TASI): TASI;
var
i: Integer;
begin
if Length(Values) = 0 then
raise EMathException.Create('Cannot compute the GCD of an empty list.');
Result := Abs(Values[0]);
for i := 1 to High(Values) do
Result := gcd(Result, Values[i]);
end;
function coprime(const A, B: TASI): Boolean; inline;
begin
Result := gcd(A, B) = 1;
end;
function NaiveTotient(const N: Integer): Integer;
var
i: Integer;
begin
if n <= 0 then
raise EMathException.Create('Totient only defined for positive integers.');
Result := 1;
for i := 2 to N - 1 do
if coprime(i, N) then
Inc(Result);
end;
function totient(const N: Integer): Integer;
var
prevfactor, factor: TASI;
res: Double;
begin
if n <= 0 then
raise EMathException.Create('Totient only defined for positive integers.');
res := n;
prevfactor := 1;
for factor in PrimeFactors(N) do
begin
if factor <> prevfactor then
res := res * (1 - 1 / factor);
prevfactor := factor;
end;
Result := Round(res);
Assert(IsIntegerEx(res));
end;
function cototient(const N: Integer): Integer; inline;
begin
Result := N - totient(N);
end;
var
_IsPrime: TBits;
_Primes: TList<Integer>;
_MöbiusCache: array of Int8;
_MertensCache: TList<Integer>;
const
PRIMES_ALLOC_BY = 65536;
MAX_ISPRIME_INDEX = 1000000000;
MAX_ISPRIME_INDEX_SQUARE = TASI(MAX_ISPRIME_INDEX) * MAX_ISPRIME_INDEX;
MAX_PRIME = 999999937;
INDEX_OF_MAX_PRIME = 50847534;
INVALID_MÖBIUS_VALUE = 2;
function ExpandPrimeCache(N: Integer): Boolean;
var
i, j: Integer;
begin
if Assigned(_IsPrime) and (_IsPrime.Size >= N + 1) then
Exit(False);
N := EnsureRange(Round(1.25*N), 1000, MAX_ISPRIME_INDEX);
if Assigned(_IsPrime) and (_IsPrime.Size >= N + 1) then
Exit(False);
Result := True;
FreeAndNil(_IsPrime);
FreeAndNil(_Primes);
_IsPrime := TBits.Create;
_Primes := TList<Integer>.Create;
try
_IsPrime.Size := N + 1;
_IsPrime[0] := False;
_IsPrime[1] := False;
for i := 2 to N do
_IsPrime[i] := True;
for i := 2 to Trunc(Sqrt(N)) do
if _IsPrime[i] then
begin
j := Sqr(i);
while j <= N do
begin
_IsPrime[j] := False;
Inc(j, i);
end;
end;
for i := 0 to _IsPrime.Size - 1 do
if _IsPrime[i] then
_Primes.Add(i);
except
FreeAndNil(_Primes);
FreeAndNil(_IsPrime);
raise;
end;
end;
procedure ClearPrimeCache;
begin
FreeAndNil(_Primes);
FreeAndNil(_IsPrime);
end;
function GetPrimeCacheMax: Integer;
begin
if _IsPrime = nil then
Result := -1
else
Result := _IsPrime.Size - 1;
end;
function GetPrimeCacheSizeBytes: Integer;
begin
Result := 0;
if Assigned(_IsPrime) then
Inc(Result, Ceil(_IsPrime.Size / 8));
if Assigned(_Primes) then
Inc(Result, SizeOf(Integer) * _Primes.Count);
end;
function IsPrime(const N: TASI): Boolean;
var
i: Integer;
attempt: Integer;
begin
if N < 2 then
Exit(False);
if N > MAX_ISPRIME_INDEX_SQUARE then
raise EMathException.Create('Cannot test integers this large for primality.');
ExpandPrimeCache(10000);
for attempt := 0 to 1 do
begin
if N <= _IsPrime.Size - 1 then
Exit(_IsPrime[N]);
for i := 0 to _Primes.Count - 1 do
if _Primes[i] > Sqrt(N) then
Exit(True)
else if N mod _Primes[i] = 0 then
Exit(False);
ExpandPrimeCache(Round(Sqrt(N)));
end;
raise EMathException.Create('Couldn''t determine if the integer is prime.');
end;
function NthPrime(N: Integer): Integer;
begin
if N < 1 then
raise EMathException.Create('To obtain the Nth prime number, N must be a positive integer.');
if N > INDEX_OF_MAX_PRIME then
raise EMathException.Create('Cannot test integers this large for primality.');
ExpandPrimeCache(10000);
if N > 6 then
ExpandPrimeCache(Ceil(N * Ln(N*Ln(N))));
Dec(N);
if N <= _Primes.Count - 1 then
Exit(_Primes[N]);
raise Exception.Create('Couldn''t obtain the Nth prime number.');
end;
function NextPrime(const N: TASI): TASI;
var
i: TASI;
begin
if N < 2 then
Exit(2);
for i := N + 1 to TASI.MaxValue do
if IsPrime(i) then
Exit(i);
raise EMathException.Create('Cannot test integers this large for primality.');
end;
function PreviousPrime(const N: TASI): TASI;
var
i: TASI;
begin
if N <= 2 then
raise EMathException.Create('There are no prime numbers smaller than 2.');
for i := N - 1 downto 2 do
if IsPrime(i) then
Exit(i);
raise Exception.Create('Internal error.');
end;
function PrimePi(const N: Integer): Integer;
begin
if N > MAX_ISPRIME_INDEX then
raise EMathException.Create('Cannot test integers this large for primality.');
ExpandPrimeCache(N);
if _Primes.BinarySearch(N, Result) then
Inc(Result);
end;
function Primorial(const N: Integer): TASR;
var
p: TASI;
begin
if N < 0 then
Result := 1
else if InRange(N, Low(IntPrimorials), High(IntPrimorials)) then
Result := IntPrimorials[N]
else
begin
Result := IntPrimorials[High(IntPrimorials)];
p := NextPrime(High(IntPrimorials));
while p <= N do
begin
Result := p * Result;
p := NextPrime(p);
end;
end;
end;
function Fibonacci(const N: Integer): TASR;
var
i: Integer;
prev, prevprev: TASR;
begin
if N < 0 then
raise EInvalidArgument.Create('To obtain the Nth Fibonacci number, N must be zero or a positive integer.');
if N = 0 then
Exit(0);
if N = 1 then
Exit(1);
prev := 1;
prevprev := 0;
Result := 1;
for i := 2 to N do
begin
Result := prev + prevprev;
prevprev := prev;
prev := Result;
end;
end;
function Lucas(const N: Integer): TASR;
var
i: Integer;
prev, prevprev: TASR;
begin
if N < 0 then
raise EInvalidArgument.Create('To obtain the Nth Lucas number, N must be zero or a positive integer.');
if N = 0 then
Exit(2);
if N = 1 then
Exit(1);
prev := 1;
prevprev := 2;
Result := 3;
for i := 2 to N do
begin
Result := prev + prevprev;
prevprev := prev;
prev := Result;
end;
end;
function Floor64(const X: TASR): TASI;
begin
Result := TASI(Trunc(X));
if Frac(X) < 0 then
Dec(Result);
end;
function Ceil64(const X: TASR): TASI;
begin
Result := TASI(Trunc(X));
if Frac(X) > 0 then
Inc(Result);
end;
function imod(const x, y: Integer): Integer; inline;
begin
Result := x mod y;
if Result < 0 then
Inc(Result, y);
end;
function imod(const x, y: TASI): TASI; inline;
begin
Result := x mod y;
if Result < 0 then
Inc(Result, y);
end;
function rmod(const x, y: TASR): TASR; inline;
begin
Result := x - Floor64(x / y) * y;
end;
function modulo(const x, y: Integer): Integer; overload; inline;
begin
Result := imod(x, y);
end;
function modulo(const x, y: TASR): TASR; overload; inline;
begin
Result := rmod(x, y);
end;
function PrimeFactors(const N: TASI; AOnlyUnique: Boolean = False): TArray<TASI>;
var
i: Integer;
a: TASI;
begin
if N < 1 then
raise EMathException.Create('Cannot find the prime factors of a non-positive integer.');
SetLength(Result, 0);
if N = 1 then
Exit;
if Assigned(_IsPrime) and (N <= _IsPrime.Size - 1) and IsPrime(N) then
begin
SetLength(Result, 1);
Result[0] := N;
Exit;
end;
a := N;
ExpandPrimeCache(10000);
for i := 0 to _Primes.Count - 1 do
begin
if _Primes[i] > Sqrt(a) then
begin
if AOnlyUnique then
TArrBuilder<TASI>.AddUnique(Result, a)
else
TArrBuilder<TASI>.Add(Result, a);
Exit;
end;
while a mod _Primes[i] = 0 do
begin
if AOnlyUnique then
TArrBuilder<TASI>.AddUnique(Result, _Primes[i])
else
TArrBuilder<TASI>.Add(Result, _Primes[i]);
a := a div _Primes[i];
if a = 1 then Exit;
end
end;
if ExpandPrimeCache(Round(Sqrt(N))) then
Result := PrimeFactors(N, AOnlyUnique)
else
raise EMathException.Create('Couldn''t factor integer.');
end;
function PrimeFactorsWithMultiplicity(N: TASI): TArray<TIntWithMultiplicity>;
begin
Result := CollapseWithMultiplicity(PrimeFactors(N));
end;
function Radical(N: TASI): TASI;
var
p: TASI;
begin
Result := 1;
for p in PrimeFactors(N, True) do
Result := Result * p;
end;
function IsSquareFree(N: TASI): Boolean;
var
i: Integer;
a: TASI;
begin
N := Abs(N);
if N = 0 then
Exit(False);
if Assigned(_IsPrime) and (N <= _IsPrime.Size - 1) and IsPrime(N) then
Exit(True);
a := N;
ExpandPrimeCache(10000);
for i := 0 to _Primes.Count - 1 do
begin
if _Primes[i] > Sqrt(a) then
Exit(True);
if a mod _Primes[i] = 0 then
begin
a := a div _Primes[i];
if a = 1 then
Exit(True);
if a mod _Primes[i] = 0 then
Exit(False);
end
end;
if ExpandPrimeCache(Round(Sqrt(N))) then
Result := IsSquareFree(N)
else
raise EMathException.Create('Couldn''t factor integer.');
end;
function factorize(const N: TASI): TArray<TASI>;
var
neg: Boolean;
begin
if (N = -1) or (N = 0) or (N = 1) then
begin
Result := [N];
Exit;
end;
neg := N < 0;
Result := PrimeFactors(Abs(N));
if neg then
Result[0] := -Result[0];
end;
function GetFactorizedString(const N: TASI; AMinusSign: Char = '-';
AMultiplicationSign: Char = '*'; ASpace: Boolean = False): string;
begin
Result := string.Join(
IfThen(ASpace, ' ' + AMultiplicationSign + ' ', AMultiplicationSign),
Int64ArrToStrArr(factorize(N))
);
if Copy(Result, 1, 1) = '-' then
Result[1] := AMinusSign;
end;
function GetFactorizedString(const N: TASI; AFancy: Boolean): string; overload;
begin
if AFancy then
Result := GetFactorizedString(N, MINUS_SIGN, DOT_OPERATOR, False)
else
Result := GetFactorizedString(N);
end;
function divisors(const N: TASI): TArray<TASI>;
type
TPrimePowerList = TList<TASI>;
TPrimePowerListList = TObjectList<TPrimePowerList>;
var
i: Integer;
PrimeFactors: TArray<TASI>;
list: TPrimePowerListList;
LastPrime: TASI;
LastPrimePower: TASI;
PowerList: TPrimePowerList;
ResList: TList<TASI>;
Index: TArray<Integer>;
function CurrentProduct: TASI;
var
j: Integer;
begin
Result := 1;
for j := 0 to list.Count - 1 do
Result := Result * list[j][Index[j]];
end;
function NextIndex: Boolean;
function IncreaseDigit(Position: Integer): Boolean;
begin
Result := True;
if Index[Position] < list[Position].Count - 1 then
Inc(Index[Position])
else
if Position > 0 then
begin
Index[Position] := 0;
Result := IncreaseDigit(Position - 1);
end
else
Exit(False);
end;
begin
if list.Count > 0 then
Result := IncreaseDigit(list.Count - 1)
else
Result := False;
end;
begin
if N = 0 then
raise EMathException.Create('Cannot compute divisors of zero (all non-zero integers are divisors of zero).');
PrimeFactors := ASNum.PrimeFactors(Abs(N));
list := TPrimePowerListList.Create(True);
try
PowerList := nil;
LastPrime := 0;
LastPrimePower := 0;
for i := 0 to High(PrimeFactors) do
if (i = 0) or (PrimeFactors[i] <> LastPrime) then
begin
PowerList := TPrimePowerList.Create;
list.Add(PowerList);
PowerList.Add(1);
PowerList.Add(PrimeFactors[i]);
LastPrime := PrimeFactors[i];
LastPrimePower := LastPrime;
end
else
begin
LastPrimePower := LastPrimePower * LastPrime;
PowerList.Add(LastPrimePower);
end;
ResList := TList<TASI>.Create;
try
SetLength(Index, list.Count);
FillChar(Index[0], Length(Index) * SizeOf(Integer), 0);
repeat
ResList.Add(CurrentProduct)
until not NextIndex;
ResList.Sort;
Result := ResList.ToArray;
finally
ResList.Free;
end;
finally
list.Free;
end;
end;
procedure FactorAsSquareAsPossible(const N: Integer; out A, B: Integer);
var
i: Integer;
begin
if N < 1 then
raise EMathException.Create('FactorAsSquareAsPossible requires a positive integer as argument.');
for i := Ceil(Sqrt(N)) to N do
if N mod i = 0 then
begin
a := i;
b := N div a;
Exit;
end;
end;
function MöbiusMu(const N: TASI): Integer;
var
factors: TArray<TASI>;
i: Integer;
begin
Assert(INVALID_MÖBIUS_VALUE <> -1);
Assert(INVALID_MÖBIUS_VALUE <> 0);
Assert(INVALID_MÖBIUS_VALUE <> +1);
if _MöbiusCache = nil then
begin
SetLength(_MöbiusCache, 10*1024*1024);
for i := 0 to High(_MöbiusCache) do
_MöbiusCache[i] := INVALID_MÖBIUS_VALUE;
end;
if InRange(N, 1, High(_MöbiusCache)) and (_MöbiusCache[N] <> INVALID_MÖBIUS_VALUE) then
Exit(_MöbiusCache[N]);
factors := PrimeFactors(N);
for i := 1 to High(factors) do
if factors[i] = factors[i - 1] then
Exit(0);
Result := AltSgn(Length(factors));
if InRange(N, 1, High(_MöbiusCache)) then
_MöbiusCache[N] := Result;
end;
function Mertens(const N: TASI): Integer;
var
i: Integer;
begin
if N < 1 then
raise EMathException.Create('Cannot compute Mertens number for a non-positive index.');
if _MertensCache = nil then
begin
_MertensCache := TList<Integer>.Create;
_MertensCache.Add(0);
end;
if InRange(N, 0, _MertensCache.Count - 1) then
Exit(_MertensCache[N]);
Result := _MertensCache[_MertensCache.Count - 1];
for i := _MertensCache.Count - 1 + 1 to N do
begin
Inc(Result, MöbiusMu(i));
_MertensCache.Add(Result);
end;
end;
function IsCarolNumber(N: TASI): Boolean;
var
c, k: Integer;
begin
if (N = -1) or (N = 7) then
Exit(True);
if N < 7 then
Exit(False);
c := 0;
while Odd(N) do
begin
Inc(c);
N := N shr 1;
end;
k := c - 1;
if k <= 2 then
Exit(False);
if N = 0 then
Exit(False);
N := N shr 1;
c := 0;
while Odd(N) do
begin
Inc(c);
N := N shr 1;
end;
Result := (c = k - 2) and (N = 0);
end;
function RationalNumber(const ANumerator, ADenominator: TASI): TRationalNumber;
begin
Result := TRationalNumber.Create(ANumerator, ADenominator);
end;
function __ToFraction(const X: TASR): TRationalNumber;
const
MaxDecLen = 12;
pot: array[0..MaxDecLen] of TASI = (1, 10, 100, 1000, 10000, 100000,
1000000, 10000000, 100000000, 1000000000, 10000000000, 100000000000,
1000000000000);
MaxQLen = 100000;
var
i: Integer;
absX, fracX: TASR;
intX: Integer;
sgnX: Integer;
q: Integer;
begin
for i := 0 to MaxDecLen do
if IsInteger(pot[i] * X, 1E-16 * pot[i]) then
Exit(RationalNumber(round(pot[i] * X), pot[i]));
absX := abs(X);
intX := trunc(absX);
fracX := frac(absX);
sgnX := sign(X);
for q := 1 to MaxQLen do
if IsInteger(q * fracX) then
Exit(RationalNumber(sgnX * (intX * q + Round(fracX * q)), q));
Result.Denominator := 0;
end;
function ToFraction(const X: TASR): TRationalNumber;
begin
Result := ContinuedFractionToFraction(ContinuedFraction(X));
end;
function ToSymbolicForm(const X: TASR; APriority: TTSFPrio = tsfpSimplest): TSimpleSymbolicForm;
type
TSymbolRec = record
Sym: string;
Val: Extended;
end;
const
symbols: array[0..14] of TSymbolRec = (
(Sym: 'π'; Val: pi),
(Sym: '√π'; Val: SqrtPi),
(Sym: '√(2π)'; Val: Sqrt2Pi),
(Sym: '(√(2π))⁻¹'; Val: Sqrt2PiInv),
(Sym: '(√π)⁻¹'; Val: SqrtPiInv),
(Sym: 'π²'; Val: PiSq),
(Sym: 'π³'; Val: PiCb),
(Sym: 'π⁻¹'; Val: PiInv),
(Sym: 'π⁻²'; Val: PiInvSq),
(Sym: 'e'; Val: EulerConstant),
(Sym: '√e'; Val: SqrtEulerConstant),
(Sym: 'e²'; Val: EulerConstantSq),
(Sym: 'e³'; Val: EulerConstantCb),
(Sym: 'e⁻¹'; Val: EulerConstantInv),
(Sym: 'e⁻²'; Val: EulerConstantInvSq));
type
TPossibility = record
Denominator: TASI;
SSF: TSimpleSymbolicForm;
end;
function MakePossibility(const Fraction: TRationalNumber;
const SSF: TSimpleSymbolicForm): TPossibility;
begin
Result.Denominator := Fraction.Denominator;
Result.SSF := SSF;
end;
var
rn: TRationalNumber;
sr: TSymbolRec;
i: Integer;
possibilities: TList<TPossibility>;
const
REASONABLE_DENOM_UNIT_FACTOR = 5E6;
REASONABLE_DENOM_VARYING_FACTOR = 1E5;
SMALL_SQUARE_FREE_INTS = [2, 3, 5, 6, 7, 10, 11, 13, 14, 15, 17, 19, 21, 22,
23, 26, 29, 30, 31, 33, 34, 35, 37, 38, 39, 41, 42, 43, 46, 47, 51, 53, 55,
57, 58, 59, 61, 62, 65, 66, 67, 69, 70, 71, 73, 74, 77, 78, 79, 82, 83, 85,
86, 87, 89, 91, 93, 94, 95, 97];
begin
possibilities := TList<TPossibility>.Create;
try
rn := ToFraction(X);
if rn.valid and (rn.Denominator < REASONABLE_DENOM_UNIT_FACTOR) and SameValue2(X, rn) then
possibilities.Add(MakePossibility(rn, TSimpleSymbolicForm.Create(rn)));
for sr in symbols do
begin
rn := ToFraction(X / sr.Val);
if rn.valid and (rn.Denominator < REASONABLE_DENOM_VARYING_FACTOR) and SameValue2(X, TASR(rn) * sr.Val) then
possibilities.Add(MakePossibility(rn,
TSimpleSymbolicForm.Create(rn, sr.Sym, sr.Val)))
end;
for i in SMALL_SQUARE_FREE_INTS do
begin
rn := ToFraction(X / sqrt(i));
if rn.valid and (rn.Denominator < REASONABLE_DENOM_VARYING_FACTOR) and SameValue2(X, TASR(rn) * sqrt(i)) then
possibilities.Add(MakePossibility(rn,
TSimpleSymbolicForm.Create(rn, '√' + IntToStr(i), sqrt(i))))
end;
if possibilities.Count > 0 then
begin
case APriority of
tsfpSimplest:
possibilities.Sort(TComparer<TPossibility>.Construct(
function(const Left, Right: TPossibility): Integer
begin
Result := CompareValue(Left.Denominator, Right.Denominator);
end
));
tsfpMostExact:
possibilities.Sort(TComparer<TPossibility>.Construct(
function(const Left, Right: TPossibility): Integer
begin
Result := CompareValue(Abs(TASR(Left.SSF) - X), Abs(TASR(Right.SSF) - X));
end
));
end;
Result := possibilities.First.SSF;
end
else
Result.CreateInvalid(X);
finally
possibilities.Free;
end;
end;
function CToSymbolicForm(const z: TASC; APriority:
TTSFPrio = tsfpSimplest): TCSimpleSymbolicForm;
begin
Result.Re := ToSymbolicForm(z.Re, APriority);
Result.Im := ToSymbolicForm(z.Im, APriority);
end;
function IversonBracket(b: Boolean): Integer;
begin
if b then
Result := 1
else
Result := 0;
end;
function KroneckerDelta(i, j: Integer): Integer;
begin
Result := IversonBracket(i = j);
end;
function KroneckerDelta(i, j: TASI): Integer;
begin
Result := IversonBracket(i = j);
end;
function LegendreSymbol(a, p: TASI): Integer;
begin
if IsPrime(p) then
Result := JacobiSymbol(a, p)
else
raise EMathException.CreateFmt('Non-prime modulus for Legendre symbol: %d', [p]);
end;
function JacobiSymbol(a, n: TASI): Integer;
var
evenness: Integer;
begin
if not (Odd(n) and (n > 0)) then
raise EMathException.CreateFmt('Invalid modulus (not an odd positive integer) for Jacobi symbol: %d', [n]);
if not coprime(a, n) then
Exit(0);
if n = 1 then
Exit(1);
a := imod(a, n);
if a = 1 then
Exit(1);
evenness := 0;
while not Odd(a) do
begin
a := a div 2;
Inc(evenness);
end;
if evenness > 0 then
if Odd(Evenness) and ((n mod 8 = 3) or (n mod 8 = 5)) then
Exit(-JacobiSymbol(a, n))
else
Exit(JacobiSymbol(a, n));
if (n mod 4 = 3) and (a mod 4 = 3) then
Exit(-JacobiSymbol(n, a))
else
Exit(JacobiSymbol(n, a));
end;
function LegendrePrime2(const a: TASI): TASI; inline;
begin
if a mod 2 = 0 then
Result := 0
else if imod(a, 8) in [1, 7] then
Result := 1
else
Result := -1;
end;
function KroneckerSymbol(a, n: TASI): Integer;
var
PrimeFactors: TArray<TIntWithMultiplicity>;
Factors: TArray<TASI>;
i: Integer;
begin
if n = 0 then
if Abs(a) = 1 then
Exit(1)
else
Exit(0);
PrimeFactors := PrimeFactorsWithMultiplicity(Abs(n));
SetLength(Factors, Length(PrimeFactors));
for i := 0 to High(PrimeFactors) do
if PrimeFactors[i].Factor = 2 then
Factors[i] := intpow(LegendrePrime2(a), PrimeFactors[i].Multiplicity)
else
Factors[i] := intpow(JacobiSymbol(a, PrimeFactors[i].Factor), PrimeFactors[i].Multiplicity);
Result := product(Factors);
if (n < 0) and (a < 0) then
Result := -Result;
end;
function Cube(const Val: Integer): Integer; inline;
begin
Result := Val*Val*Val;
end;
function Forth(const Val: Integer): Integer; inline;
begin
Result := Val*Val*Val*Val;
end;
function ContinuedFraction(x: TASR; maxlen: Integer = 18): TArray<TASI>;
var
n: TASI;
f: TASR;
begin
while True do
begin
if not InRange(x, TASR(TASI.MinValue), TASR(TASI.MaxValue)) then
Break;
n := Round(x - 0.5 + 1E-5);
f := x - n;
TArrBuilder<TASI>.Add(Result, n);
if IsZero(f, Cube(Length(Result)) * 1E-6) or (Length(Result) = maxlen) then
Break
else
x := 1/f;
end;
end;
function ContinuedFraction(const x: TRationalNumber): TArray<TASI>;
var
a, b, q, r: TASI;
begin
a := x.Numerator;
b := x.Denominator;
if b < 0 then
begin
a := -a;
b := -b;
end;
repeat
q := a div b;
r := a mod b;
if (a < 0) and (r <> 0) then
begin
Dec(q);
Inc(r, b);
end;
TArrBuilder<TASI>.Add(Result, q);
a := b;
b := r;
until r = 0;
end;
function _CFBuild(const CF: TArray<TASI>; Index: Integer): TRationalNumber;
begin
Result := CF[Index];
if Index < High(CF) then
Result := Result + _CFBuild(CF, Index + 1).inv;
end;
function ContinuedFractionToFraction(const AContinuedFraction: TArray<TASI>): TRationalNumber;
begin
if Length(AContinuedFraction) = 0 then
FillChar(Result, SizeOf(Result), 0)
else
Result := _CFBuild(AContinuedFraction, 0);
end;
function Heaviside(const X: TASR): TASR; inline;
begin
if X < 0 then
Result := 0
else if X > 0 then
Result := 1
else
Result := 1/2;
end;
function Ramp(const X: TASR): TASR; inline;
begin
if X < 0 then
Result := 0
else
Result := X;
end;
function Rectfcn(const X: TASR): TASR; inline;
var
AbsX: TASR;
begin
AbsX := Abs(X);
if AbsX > 0.5 then
Result := 0
else if AbsX < 0.5 then
Result := 1
else
Result := 1/2;
end;
function Tri(const X: TASR): TASR; inline;
var
AbsX: TASR;
begin
AbsX := Abs(X);
if AbsX < 1 then
Result := 1 - AbsX
else
Result := 0;
end;
function SquareWaveUnit(const X: TASR): TASR;
begin
if X = 0 then
Result := 0
else if X < Pi then
Result := 1
else if X = Pi then
Result := 0
else
Result := -1;
end;
function SquareWave(const X: TASR): TASR;
begin
Result := SquareWaveUnit(rmod(X, TwoPi));
end;
function TriangleWaveUnit(const X: TASR): TASR;
begin
if X <= PiDiv2 then
Result := TwoDivPi * X
else if X <= 3*PiDiv2 then
Result := 2 - TwoDivPi * X
else
Result := -4 + TwoDivPi * X;
end;
function TriangleWave(const X: TASR): TASR;
begin
Result := TriangleWaveUnit(rmod(X, TwoPi));
end;
function SawtoothWaveUnit(const X: TASR): TASR;
begin
if X < Pi then
Result := PiInv * X
else if X = Pi then
Result := 0
else
Result := -2 + PiInv * X;
end;
function SawtoothWave(const X: TASR): TASR;
begin
Result := SawtoothWaveUnit(rmod(X, TwoPi));
end;
function differentiate(AFunction: TRealFunctionRef; const X, ε: TASR): TASR;
begin
Result := (AFunction(X + ε) - AFunction(X - ε)) / (2*ε);
end;
constructor TIntegrationCacheItem.Create(AX: TASR; AVal: TASR = NaN);
begin
X := AX;
Val := AVal;
end;
constructor TIntegrationParams.N(const AN: Integer);
begin
Self.FixedDelta := False;
Self.FN := AN;
end;
constructor TIntegrationParams.Delta(const ADelta: TASR);
begin
Self.FixedDelta := True;
Self.FDelta := ADelta;
end;
function integrate(AFunction: TRealFunctionRef; a, b: TASR;
const AParams: TIntegrationParams): TASR;
var
x: TASR;
N: Integer;
Delta: TASR;
HalfDelta: TASR;
prev, cur: TASR;
s, e: TASR;
begin
if a = b then
Exit(0);
if AParams.FixedDelta then
N := Ceil(abs(b - a) / AParams.FDelta)
else
N := AParams.FN;
Delta := (b - a) / N;
HalfDelta := Delta / 2;
if Delta < 0 then
Delta := -Delta;
s := min(a, b);
e := max(a, b);
e := e + Delta / 100;
Result := 0;
prev := AFunction(s);
x := s + Delta;
while x < e do
begin
cur := AFunction(x);
Result := Result + (prev + cur) * HalfDelta;
prev := cur;
x := x + Delta;
end;
end;
function integrate(AFunction: TRealFunctionRef; a, b: TASR): TASR;
begin
Result := integrate(AFunction, a, b, DefaultIntegrationParams);
end;
function integrate(AFunction: TComplexFunctionRef; a, b: TASR;
const AParams: TIntegrationParams): TASC;
var
x: TASR;
N: Integer;
Delta: TASR;
HalfDelta: TASR;
prev, cur: TASC;
s, e: TASR;
begin
if a = b then
Exit(0);
if AParams.FixedDelta then
N := ceil(abs(b - a) / AParams.FDelta)
else
N := AParams.FN;
Delta := (b - a) / N;
HalfDelta := Delta / 2;
if Delta < 0 then
Delta := -Delta;
s := min(a, b);
e := max(a, b);
e := e + Delta / 100;
Result := 0;
prev := AFunction(s);
x := s + Delta;
while x < e do
begin
cur := AFunction(x);
Result := Result + (prev + cur) * HalfDelta;
prev := cur;
x := x + Delta;
end;
end;
function integrate(AFunction: TComplexFunctionRef; a, b: TASR): TASC;
begin
Result := integrate(AFunction, a, b, DefaultIntegrationParams);
end;
function FillIntegrationCache(AFunction: TRealFunctionRef; a, b: TASR;
const CacheDelta: TASR;
var Cache: TIntegrationCache;
const AParams: TIntegrationParams): TASR;
var
x: TASR;
N: Integer;
Delta: TASR;
HalfDelta: TASR;
prev, cur: TASR;
OldLength, ActualLength: Integer;
OldEnd, OldEndVal: TASR;
begin
if (Length(Cache) > 0) and (Cache[High(Cache)].X >= b) then
Exit(NaN);
if a > b then
raise EMathException.Create('FillIntegrationCache: Invalid parameters (a > b).');
if (Length(Cache) > 0) and (Cache[0].X <> a) then
raise EMathException.Create('FillIntegrationCache: Invalid integration cache passed to function.');
if (Length(Cache) = 0) and (a = b) then
begin
SetLength(Cache, 1);
Cache[0].X := a;
Cache[0].Val := 0;
Exit(0);
end;
if AParams.FixedDelta then
N := Ceil((b - a) / AParams.FDelta)
else
N := AParams.FN;
Delta := (b - a) / N;
HalfDelta := Delta / 2;
b := b + Delta / 100;
if Length(Cache) = 0 then
begin
SetLength(Cache, ceil((b - a) / CacheDelta) + 1);
Cache[0].X := a;
Cache[0].Val := 0;
ActualLength := 1;
OldEnd := a;
OldEndVal := 0;
end
else
begin
OldLength := Length(Cache);
OldEnd := Cache[High(Cache)].X;
OldEndVal := Cache[High(Cache)].Val;
SetLength(Cache, OldLength + Ceil((b - OldEnd) / CacheDelta) + 1);
ActualLength := OldLength;
end;
Result := OldEndVal;
prev := AFunction(OldEnd);
x := OldEnd + Delta;
while x < b do
begin
cur := AFunction(x);
Result := Result + (prev + cur) * HalfDelta;
if x - Cache[ActualLength - 1].X >= CacheDelta then
begin
Cache[ActualLength].X := x;
Cache[ActualLength].Val := Result;
Inc(ActualLength);
end;
prev := cur;
x := x + Delta;
end;
Assert(ActualLength <= Length(Cache));
SetLength(Cache, ActualLength);
end;
function FillIntegrationCache(AFunction: TRealFunctionRef; a, b: TASR;
const CacheDelta: TASR; var Cache: TIntegrationCache): TASR;
begin
Result := FillIntegrationCache(AFunction, a, b, CacheDelta, Cache,
DefaultIntegrationParams);
end;
procedure StepwiseIntegrationCacheFill(AIntegrand: TRealFunctionRef;
var ACache: TIntegrationCache; ACacheDelta: TASR; const Steps: array of TASR;
const x: TASR; const a: TASR = 0);
var
b: TASR;
begin
for b in Steps do
if x <= b then
begin
FillIntegrationCache(AIntegrand, a, b, ACacheDelta, ACache);
Exit;
end;
end;
procedure StepwiseIntegrationCacheFill(AIntegrand: TRealFunctionRef;
var ACache: TIntegrationCache; ACacheDelta: TASR; const Steps: array of TASR;
const x: TASR; const AParams: TIntegrationParams; const a: TASR = 0);
var
b: TASR;
begin
for b in Steps do
if x <= b then
begin
FillIntegrationCache(AIntegrand, a, b, ACacheDelta, ACache, AParams);
Exit;
end;
end;
function ClearIntegrationCache(var ACache: TIntegrationCache): Integer;
begin
Result := Length(ACache);
SetLength(ACache, 0);
end;
function GetIntegrationCacheSize(const ACache: TIntegrationCache): Integer;
begin
Result := Length(ACache) * SizeOf(TIntegrationCacheItem);
end;
function CachedIntegration(AFunction: TRealFunctionRef; a, b: TASR;
const ACache: TIntegrationCache; const AParams: TIntegrationParams): TASR;
var
CacheIndex: Integer;
CacheItem: TIntegrationCacheItem;
Comparer: IComparer<TIntegrationCacheItem>;
ExactMatch: Boolean;
Params: TIntegrationParams;
sgn: TASR;
begin
sgn := 1;
if a = b then
Exit(0)
else if a > b then
begin
TSwapper<TASR>.Swap(a, b);
sgn := -1;
end;
if (Length(ACache) > 0) and (ACache[0].X = a) then
begin
if b <= ACache[High(ACache)].X then
begin
Comparer := TDelegatedComparer<TIntegrationCacheItem>.Create(
function(const Left, Right: TIntegrationCacheItem): Integer
begin
Result := Sign(Left.X - Right.X);
end);
ExactMatch := TArray.BinarySearch<TIntegrationCacheItem>(ACache,
TIntegrationCacheItem.Create(b),
CacheIndex,
Comparer);
if ExactMatch then
Exit(sgn * ACache[CacheIndex].Val)
else
CacheItem := ACache[CacheIndex - 1];
end
else
CacheItem := ACache[High(ACache)];
end
else
raise EMathException.Create('CachedIntegration: Invalid integration cache passed to function.');
Params := AParams;
if not Params.FixedDelta then
Params.FN := ceil(Params.FN * (b - CacheItem.X) / (b - a));
Result := CacheItem.Val + integrate(AFunction, CacheItem.X, b, Params);
if sgn < 0 then
Result := -Result;
end;
function CachedIntegration(AFunction: TRealFunctionRef; a, b: TASR;
const ACache: TIntegrationCache): TASR;
begin
Result := CachedIntegration(AFunction, a, b, ACache, DefaultIntegrationParams);
end;
function sum(const Vals: array of TASI): TASI;
var
i: Integer;
begin
Result := 0;
for i := 0 to High(Vals) do
Result := Result + Vals[i];
end;
function product(const Vals: array of TASI): TASI;
var
i: Integer;
begin
Result := 1;
for i := 0 to High(Vals) do
Result := Result * Vals[i];
end;
function accumulate(AFunction: TSequence<TASR>; a, b: Integer;
AStart: TASR; AAccumulator: TAccumulator<TASR>): TASR;
var
i: Integer;
begin
Result := AStart;
for i := a to b do
Result := AAccumulator(Result, AFunction(i));
end;
function accumulate(AFunction: TSequence<TASC>; a, b: Integer;
AStart: TASC; AAccumulator: TAccumulator<TASC>): TASC;
var
i: Integer;
begin
Result := AStart;
for i := a to b do
Result := AAccumulator(Result, AFunction(i));
end;
function sum(AFunction: TSequence<TASR>; a, b: Integer): TASR;
begin
Result := accumulate(AFunction, a, b, 0, ASR_PLUS)
end;
function sum(AFunction: TSequence<TASC>; a, b: Integer): TASC;
begin
Result := accumulate(AFunction, a, b, 0, ASC_PLUS)
end;
function ArithmeticMean(AFunction: TSequence<TASR>; a, b: Integer): TASR;
begin
Result := sum(AFunction, a, b) / NN(b - a + 1)
end;
function ArithmeticMean(AFunction: TSequence<TASC>; a, b: Integer): TASC;
begin
Result := sum(AFunction, a, b) / NN(b - a + 1)
end;
function GeometricMean(AFunction: TSequence<TASR>; a, b: Integer): TASR;
var
p: TASR;
begin
p := 1 / NN(b - a + 1);
Result :=
product(function(N: Integer): TASR
begin
Result := pow(AFunction(N), p)
end, a, b);
end;
function GeometricMean(AFunction: TSequence<TASC>; a, b: Integer): TASC;
begin
Result := cpow(product(AFunction, a, b), 1 / NN(b - a + 1));
end;
function HarmonicMean(AFunction: TSequence<TASR>; a, b: Integer): TASR;
begin
Result := 1 / (
ArithmeticMean(function(N: Integer): TASR
begin
Result := 1 / AFunction(N);
end, a, b)
);
end;
function HarmonicMean(AFunction: TSequence<TASC>; a, b: Integer): TASC;
begin
Result := 1 / (
ArithmeticMean(function(N: Integer): TASC
begin
Result := 1 / AFunction(N);
end, a, b)
);
end;
function product(AFunction: TSequence<TASR>; a, b: Integer): TASR;
begin
Result := accumulate(AFunction, a, b, 1, ASR_TIMES)
end;
function product(AFunction: TSequence<TASC>; a, b: Integer): TASC;
begin
Result := accumulate(AFunction, a, b, 1, ASC_TIMES)
end;
function max(AFunction: TSequence<TASR>; a, b: Integer): TASR;
var
i: Integer;
begin
if a > b then
raise EMathException.Create('Cannot find maximum value in a set of zero values.');
Result := AFunction(a);
for i := a + 1 to b do
if AFunction(i) > Result then
Result := AFunction(i);
end;
function min(AFunction: TSequence<TASR>; a, b: Integer): TASR;
var
i: Integer;
begin
if a > b then
raise EMathException.Create('Cannot find minimum value in a set of zero values.');
Result := AFunction(a);
for i := a + 1 to b do
if AFunction(i) < Result then
Result := AFunction(i);
end;
function exists(AFunction: TSequence<TASR>; a, b: Integer;
APredicate: TPredicate<TASR>): Boolean; overload;
var
i: Integer;
begin
for i := a to b do
if APredicate(AFunction(i)) then
Exit(True);
Result := False;
end;
function exists(AFunction: TSequence<TASC>; a, b: Integer;
APredicate: TPredicate<TASC>): Boolean; overload;
var
i: Integer;
begin
for i := a to b do
if APredicate(AFunction(i)) then
Exit(True);
Result := False;
end;
function count(AFunction: TSequence<TASR>; a, b: Integer;
APredicate: TPredicate<TASR>): Integer; overload;
var
i: Integer;
begin
Result := 0;
for i := a to b do
if APredicate(AFunction(i)) then
Inc(Result);
end;
function count(AFunction: TSequence<TASC>; a, b: Integer;
APredicate: TPredicate<TASC>): Integer; overload;
var
i: Integer;
begin
Result := 0;
for i := a to b do
if APredicate(AFunction(i)) then
Inc(Result);
end;
function count(AFunction: TSequence<TASR>; a, b: Integer;
AValue: TASR): Integer; overload;
var
i: Integer;
begin
Result := 0;
for i := a to b do
if SameValue(AFunction(i), AValue) then
Inc(Result);
end;
function count(AFunction: TSequence<TASC>; a, b: Integer;
AValue: TASC): Integer; overload;
var
i: Integer;
begin
Result := 0;
for i := a to b do
if CSameValue(AFunction(i), AValue) then
Inc(Result);
end;
function ForAll(AFunction: TSequence<TASR>; a, b: Integer;
APredicate: TPredicate<TASR>): Boolean; overload;
var
i: Integer;
begin
for i := a to b do
if not APredicate(AFunction(i)) then
Exit(False);
Result := True;
end;
function ForAll(AFunction: TSequence<TASC>; a, b: Integer;
APredicate: TPredicate<TASC>): Boolean; overload;
var
i: Integer;
begin
for i := a to b do
if not APredicate(AFunction(i)) then
Exit(False);
Result := True;
end;
function contains(AFunction: TSequence<TASR>; a, b: Integer;
const AValue: TASR): Boolean; overload;
var
i: Integer;
begin
for i := a to b do
if SameValue(AFunction(i), AValue) then
Exit(True);
Result := False;
end;
function contains(AFunction: TSequence<TASC>; a, b: Integer;
const AValue: TASC): Boolean; overload;
var
i: Integer;
begin
for i := a to b do
if CSameValue(AFunction(i), AValue) then
Exit(True);
Result := False;
end;
const
DEFAULT_CACHE_DELTA = 1E-4;
NUM_INTEGRATION_CACHES = 8;
var
_integration_cache_list: array[0..NUM_INTEGRATION_CACHES - 1] of PIntegrationCache;
_erf_cache: TIntegrationCache;
_fresnelc_cache: TIntegrationCache;
_fresnels_cache: TIntegrationCache;
_si_cache: TIntegrationCache;
_ci_cache: TIntegrationCache;
_li_from2_cache: TIntegrationCache;
_li_to1_cache: TIntegrationCache;
_li_Xto2_cache: TIntegrationCache;
procedure InitSpecialFunctionsIntegrationCacheList;
begin
_integration_cache_list[0] := @_erf_cache;
_integration_cache_list[1] := @_fresnelc_cache;
_integration_cache_list[2] := @_fresnels_cache;
_integration_cache_list[3] := @_ci_cache;
_integration_cache_list[4] := @_si_cache;
_integration_cache_list[5] := @_li_from2_cache;
_integration_cache_list[6] := @_li_to1_cache;
_integration_cache_list[7] := @_li_Xto2_cache;
end;
const
_erf_cache_delta = DEFAULT_CACHE_DELTA;
_fresnelc_cache_delta = DEFAULT_CACHE_DELTA;
_fresnels_cache_delta = DEFAULT_CACHE_DELTA;
_si_cache_delta = DEFAULT_CACHE_DELTA;
_ci_cache_delta = DEFAULT_CACHE_DELTA;
_li_from2_cache_delta = DEFAULT_CACHE_DELTA;
_li_to1_cache_delta = 1E-6;
_li_Xto2_cache_delta = 1E-6;
function GetSpecialFunctionsIntegrationCacheSize: Integer;
var
p: PIntegrationCache;
begin
Result := 0;
for p in _integration_cache_list do
Inc(Result, GetIntegrationCacheSize(p^));
end;
procedure ClearSpecialFunctionsIntegrationCaches;
var
p: PIntegrationCache;
begin
for p in _integration_cache_list do
ClearIntegrationCache(p^);
end;
function erf(const X: TASR): TASR;
var
integrand: TRealFunctionRef;
begin
if X = 0 then
Exit(0);
if X < 0 then
Exit(-erf(-X));
if X >= 6 then
Exit(1);
integrand := function(const t: TASR): TASR
begin
Result := exp(-t*t);
end;
if not Assigned(_erf_cache) then
FillIntegrationCache(integrand, 0, 6, _erf_cache_delta, _erf_cache);
Result := (2/sqrt(pi)) * CachedIntegration(integrand, 0, X, _erf_cache);
end;
function erfc(const X: TASR): TASR; inline;
begin
Result := 1 - erf(X);
end;
const
StepwiseCacheSequence: array[0..10] of TASR = (1, 5, 10, 25, 50, 75, 100, 200, 300, 400, 500);
StepwiseCacheSequenceZeroToOne: array[0..8] of TASR = (0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9);
StepwiseCacheSequenceOneToTwo: array[0..8] of TASR = (1.1, 1.2, 1.3, 1.4, 1.5, 1.6, 1.7, 1.8, 0.9);
function FresnelC(const X: TASR): TASR;
var
integrand: TRealFunctionRef;
begin
if X = 0 then
Exit(0);
if X < 0 then
Exit(-FresnelC(-X));
integrand := function(const t: TASR): TASR
begin
Result := cos(t*t);
end;
StepwiseIntegrationCacheFill(integrand, _fresnelc_cache, _fresnelc_cache_delta,
StepwiseCacheSequence, X);
Result := CachedIntegration(integrand, 0, X, _fresnelc_cache);
end;
function FresnelS(const X: TASR): TASR;
var
integrand: TRealFunctionRef;
begin
if X = 0 then
Exit(0);
if X < 0 then
Exit(-FresnelS(-X));
integrand := function(const t: TASR): TASR
begin
Result := sin(t*t);
end;
StepwiseIntegrationCacheFill(integrand, _fresnels_cache, _fresnels_cache_delta,
StepwiseCacheSequence, X);
Result := CachedIntegration(integrand, 0, X, _fresnels_cache);
end;
function Si(const X: TASR): TASR;
begin
if X = 0 then
Exit(0);
if X < 0 then
Exit(-Si(-X));
StepwiseIntegrationCacheFill(sinc, _si_cache, _si_cache_delta, StepwiseCacheSequence, X);
Result := CachedIntegration(sinc, 0, X, _si_cache);
end;
function Ci(const X: TASR): TASR;
var
integrand: TRealFunctionRef;
begin
if X <= 0 then
raise EMathException.Create('Cosine integral only defined for positive real numbers.');
integrand := function(const t: TASR): TASR
begin
if IsZero(t) then
Result := 0
else
Result := (cos(t) - 1) / t;
end;
StepwiseIntegrationCacheFill(integrand, _ci_cache, _ci_cache_delta,
StepwiseCacheSequence, X);
Result := EulerMascheroni + ln(x) + CachedIntegration(integrand, 0, X, _ci_cache);
end;
function LiFrom2(const X: TASR): TASR;
var
integrand: TRealFunctionRef;
begin
integrand := function(const t: TASR): TASR
begin
Result := 1 / ln(t);
end;
StepwiseIntegrationCacheFill(integrand, _li_from2_cache, _li_from2_cache_delta,
StepwiseCacheSequence, X, 2);
Result := CachedIntegration(integrand, 2, X, _li_from2_cache);
end;
function LiTo1(const X: TASR): TASR;
var
integrand: TRealFunctionRef;
begin
integrand := function(const t: TASR): TASR
begin
Result := 1 / ln(t);
end;
StepwiseIntegrationCacheFill(integrand, _li_to1_cache, _li_to1_cache_delta,
StepwiseCacheSequenceZeroToOne, X, TIntegrationParams.Delta(1E-8), Double.Epsilon);
Result := CachedIntegration(integrand, Double.Epsilon, X, _li_to1_cache,
TIntegrationParams.Delta(1E-8));
end;
function LiXTo2(const X: TASR): TASR;
var
integrand: TRealFunctionRef;
begin
integrand := function(const t: TASR): TASR
begin
Result := 1 / ln(2 - t);
end;
StepwiseIntegrationCacheFill(integrand, _li_Xto2_cache, _li_Xto2_cache_delta,
StepwiseCacheSequenceOneToTwo, 2 - X);
Result := CachedIntegration(integrand, 0, 2 - X, _li_Xto2_cache);
end;
function Li(const X: TASR): TASR;
const
Li2 = 1.045163780117492784844588889194613136522615;
var
integrand: TRealFunctionRef;
begin
integrand := function(const t: TASR): TASR
begin
Result := 1 / ln(t);
end;
if X >= 2 then
Result := Li2 + LiFrom2(X)
else if X > 1 then
Result := Li2 - LiXTo2(X)
else if IsZero(X) then
Result := 0
else if X < 1 then
Result := LiTo1(X)
else
Result := -Infinity;
end;
function Bessel(N: Integer; const X: TASR; const AParams: TIntegrationParams): TASR;
var
integrand: TRealFunctionRef;
begin
if X = 0 then
if N = 0 then
Exit(1)
else
Exit(0);
integrand := function(const t: TASR): TASR
begin
Result := cos(N * t - x * sin(t));
end;
Result := integrate(integrand, 0, pi, AParams) / pi;
end;
function Bessel(N: Integer; const X: TASR): TASR;
begin
Result := Bessel(N, X, DefaultIntegrationParams);
end;
function Bessel(N: Integer; const z: TASC; const AParams: TIntegrationParams): TASC;
var
integrand: TComplexFunctionRef;
zp: TASC;
begin
if z = 0 then
if N = 0 then
Exit(1)
else
Exit(0);
zp := z;
integrand := function(const t: TASC): TASC
begin
Result := ccos(N * t - zp * sin(t.Re));
end;
Result := integrate(integrand, 0, pi, AParams) / pi;
end;
function Bessel(N: Integer; const z: TASC): TASC;
begin
Result := Bessel(N, z, DefaultIntegrationParams);
end;
function Laguerre(N: Integer; const X: TASR): TASR;
begin
if N < 0 then
raise EMathException.Create('Laguerre polynomial not defined for negative n.');
Result := sum(function(k: Integer): TASR
begin
Result := binomial(N, k) * AltSgn(k) * IntPower(X, k) / factorial(k)
end, 0, N);
end;
function Laguerre(N: Integer; const z: TASC): TASC;
var
zp: TASC;
begin
if N < 0 then
raise EMathException.Create('Laguerre polynomial not defined for negative n.');
zp := z;
Result := sum(function(k: Integer): TASC
begin
Result := binomial(N, k) * AltSgn(k) * cpow(zp, k) / factorial(k)
end, 0, N);
end;
function Poly(const X: Extended; const Coefficients: array of Double;
const Degree: Integer): Extended; overload;
var
I: Integer;
begin
Result := Coefficients[Degree];
for I := Degree-1 downto Low(Coefficients) do
Result := Result * X + Coefficients[I];
end;
function Poly(const z: TASC; const Coefficients: array of Double;
const Degree: Integer): TASC; overload;
var
I: Integer;
begin
Result := Coefficients[Degree];
for I := Degree-1 downto Low(Coefficients) do
Result := Result * z + Coefficients[I];
end;
const
HermiteCoefficients: array[0..10] of array[0..10] of Double =
(
( 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
( 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0),
( -2, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0),
( 0, -12, 0, 8, 0, 0, 0, 0, 0, 0, 0),
( 12, 0, -48, 0, 16, 0, 0, 0, 0, 0, 0),
( 0, 120, 0, -160, 0, 32, 0, 0, 0, 0, 0),
( -120, 0, 720, 0, -480, 0, 64, 0, 0, 0, 0),
( 0, -1680, 0, 3360, 0, -1344, 0, 128, 0, 0, 0),
( 1680, 0, -13440, 0, 13440, 0, -3584, 0, 256, 0, 0),
( 0, 30240, 0, -80640, 0, 48384, 0, -9216, 0, 512, 0),
( -30240, 0, 302400, 0,-403200, 0, 161280, 0, -23040, 0, 1024)
);
function Hermite(N: Integer; const X: TASR): TASR;
begin
if not InRange(N, Low(HermiteCoefficients), High(HermiteCoefficients)) then
raise EMathError.Create('Hermite polynomial only implemented for non-negative n ≤ ' + High(HermiteCoefficients).ToString + '.');
Result := Poly(X, HermiteCoefficients[N], N);
end;
function Hermite(N: Integer; const z: TASC): TASC;
begin
if not InRange(N, Low(HermiteCoefficients), High(HermiteCoefficients)) then
raise EMathError.Create('Hermite polynomial only implemented for non-negative n ≤ ' + High(HermiteCoefficients).ToString + '.');
Result := Poly(z, HermiteCoefficients[N], N);
end;
function Legendre(N: Integer; const X: TASR): TASR;
begin
if N < 0 then
raise EMathException.Create('Legendre polynomial not defined for negative n.');
Result := sum(function(k: Integer): TASR
begin
Result := IntPower(binomial(N, k), 2) * IntPower(X - 1, N - k) * IntPower(X + 1, k)
end, 0, N) / IntPower(2, N);
end;
function Legendre(N: Integer; const z: TASC): TASC;
var
zp: TASC;
begin
if N < 0 then
raise EMathException.Create('Legendre polynomial not defined for negative n.');
zp := z;
Result := sum(function(k: Integer): TASC
begin
Result := IntPower(binomial(N, k), 2) * cpow(zp - 1, N - k) * cpow(zp + 1, k)
end, 0, N) / IntPower(2, N);
end;
const
_gamma_function_p: array[0..7] of TASR =
( 676.5203681218851,
-1259.1392167224028,
771.32342877765313,
-176.61502916214059,
12.507343278686905,
-0.13857109526572012,
9.9843695780195716E-6,
1.5056327351493116E-7);
function GammaFunction(const X: TASR): TASR;
var
Xp, w, t: TASR;
i: Integer;
begin
if (X <= 0) and IsIntegerEx(X) then
raise EMathException.Create('Gamma function not defined for non-positive integers.');
if X < 1/2 then
Exit(pi / (sin(pi*X) * GammaFunction(1 - X)));
if IsIntegerEx(X) then
Exit(factorial(round(X) - 1));
Xp := X - 1;
w := 0.99999999999980993;
for i := 0 to High(_gamma_function_p) do
w := w + _gamma_function_p[i] / (Xp + i + 1);
t := Xp + Length(_gamma_function_p) - 1/2;
Result := Sqrt2Pi * Math.Power(t, Xp + 1/2) * exp(-t) * w;
end;
function GammaFunction(const z: TASC): TASC;
var
Xp, w, t: TASC;
i: Integer;
begin
if IsZero(z.Im) and (z.Re <= 0) and IsIntegerEx(z.Re) then
raise EMathException.Create('Gamma function not defined for non-positive integers.');
if z.Re < 1/2 then
Exit(pi / (csin(pi*z) * GammaFunction(1 - z)));
Xp := z - 1;
w := 0.99999999999980993;
for i := 0 to High(_gamma_function_p) do
w := w + _gamma_function_p[i] / (Xp + i + 1);
t := Xp + Length(_gamma_function_p) - 1/2;
Result := Sqrt2Pi * cpow(t, Xp + 1/2) * cexp(-t) * w;
end;
function Chebyshev(N: Integer; const X: TASR): TASR;
begin
case N of
0:
Result := 1;
1:
Result := X;
2:
Result := 2*X*X - 1;
3:
Result := 4*X*X*X - 3*X;
4:
Result := 8*X*X*(X*X - 1) + 1;
5:
Result := (16*X*X - 20)*X*X*X + 5*X
else
if abs(x) <= 1 then
Result := cos(N * arccos(X))
else if x >= 1 then
Result := cosh(N * arccosh(X))
else
Result := AltSgn(N) * cosh(N * arccosh(-X));
end;
end;
function Chebyshev(N: Integer; const z: TASC): TASC;
begin
case N of
0:
Result := 1;
1:
Result := z;
2:
Result := 2*z*z - 1;
3:
Result := 4*z*z*z - 3*z;
4:
Result := 8*z*z*(z*z - 1) + 1;
5:
Result := (16*z*z - 20)*z*z*z + 5*z
else
Result := ccos(N * carccos(z))
end;
end;
function Bernstein(I, N: Integer; const X: TASR): TASR;
begin
Result := binomial(N, I) * IntPower(X, I) * IntPower(1 - X, N - I);
end;
function Bernstein(I, N: Integer; const z: TASC): TASC;
begin
Result := binomial(N, I) * cpow(z, I) * cpow(1 - z, N - I);
end;
var
MAX_CACHE_THOUSANDS: Integer;
_harmonic_numbers: array of TASR;
function HarmonicNumber(const N: TASI): TASR;
var
k: Integer;
f: Integer;
begin
if N <= 1000*1000 then
MAX_CACHE_THOUSANDS := 1000
else if N <= 10000*1000 then
MAX_CACHE_THOUSANDS := 10000
else if N <= 100000*1000 then
MAX_CACHE_THOUSANDS := 100000
else if N <= 1001000*1000 then
MAX_CACHE_THOUSANDS := 1000000
else
Exit(EulerMascheroni + Ln(TASR(N)));
if Length(_harmonic_numbers) < MAX_CACHE_THOUSANDS + 1 then
begin
SetLength(_harmonic_numbers, MAX_CACHE_THOUSANDS + 1);
_harmonic_numbers[0] := 0;
Result := 0;
for k := 1 to MAX_CACHE_THOUSANDS * 1000 do
begin
Result := Result + 1/k;
if k mod 1000 = 0 then
_harmonic_numbers[k div 1000] := Result;
end;
end;
if N < 0 then
raise EMathException.Create('To compute the Nth harmonic number, N must be a non-negative integer.');
f := Min(N div 1000, MAX_CACHE_THOUSANDS);
Result := _harmonic_numbers[f];
for k := 1000*f + 1 to N do
Result := Result + 1/k;
end;
constructor TRealVector.Create(const Components: array of TASR);
begin
SetLength(FComponents, Length(Components));
if Length(Components) > 0 then
Move(Components[0], FComponents[0], Length(Components) * SizeOf(TASR));
end;
constructor TRealVector.Create(ASize: Integer; const AVal: TASR);
var
i: Integer;
begin
if ASize < 0 then
raise EMathException.Create('Cannot create vector with negative dimension.');
SetLength(FComponents, ASize);
for i := 0 to High(FComponents) do
FComponents[i] := AVal;
end;
function TRealVector.GetDimension: Integer;
begin
Result := Length(FComponents);
end;
procedure TRealVector.SetDimension(const Value: Integer);
begin
if Value < 0 then
raise EMathException.Create('Cannot create vector with negative dimension.');
SetLength(FComponents, Value);
end;
function TRealVector.GetComponent(Index: Integer): TASR;
begin
Result := FComponents[Index];
end;
function TRealVector.SafeSort(AComparer: IComparer<TASR>): TRealVector;
begin
Result := Self;
if Dimension > 0 then
TSafeSorter<TASR>.Sort(FComponents, AComparer);
end;
procedure TRealVector.SetComponent(Index: Integer; const Value: TASR);
begin
FComponents[Index] := Value;
end;
function TRealVector.ToIntegerArray: TArray<Integer>;
var
i: Integer;
component: TASR;
begin
SetLength(Result, Dimension);
for i := 0 to Dimension - 1 do
begin
component := Self[i];
if IsInteger(component) then
Result[i] := Round(Component)
else
raise EMathException.Create('The vector is not an integer vector.');
end;
end;
class operator TRealVector.Negative(const u: TRealVector): TRealVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := -u[i];
end;
class operator TRealVector.Add(const u: TRealVector; const v: TRealVector): TRealVector;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
raise EMathException.Create('Cannot add two vectors of unequal dimension.');
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] + v[i];
end;
class operator TRealVector.Add(const u: TRealVector; const x: TASR): TRealVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] + x;
end;
class operator TRealVector.Subtract(const u: TRealVector; const v: TRealVector): TRealVector;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
raise EMathException.Create('Cannot subtract two vectors of unequal dimension.');
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] - v[i];
end;
class operator TRealVector.Subtract(const u: TRealVector; const x: TASR): TRealVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] - x;
end;
class operator TRealVector.Multiply(const u: TRealVector; const v: TRealVector): TASR;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
raise EMathException.Create('Cannot compute dot product of two vectors of unequal dimension.');
Result := 0;
for i := 0 to u.Dimension - 1 do
Result := Result + u[i] * v[i];
end;
class operator TRealVector.Multiply(const x: TASR; const u: TRealVector): TRealVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := x * u[i];
end;
class operator TRealVector.Multiply(const u: TRealVector; const x: TASR): TRealVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := x * u[i];
end;
class operator TRealVector.Divide(const u: TRealVector; const x: TASR): TRealVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] / x;
end;
class operator TRealVector.Equal(const u: TRealVector; const v: TRealVector): Boolean;
var
i: Integer;
begin
Result := u.Dimension = v.Dimension;
if Result then
for i := 0 to u.Dimension - 1 do
if u[i] <> v[i] then
Exit(False);
end;
class operator TRealVector.NotEqual(const u: TRealVector; const v: TRealVector): Boolean;
begin
Result := not (u = v);
end;
class operator TRealVector.LeftShift(const u: TRealVector; Val: Integer): TRealVector;
var
i: Integer;
begin
if Val < 0 then Exit(u shr -Val);
Result.Dimension := u.Dimension;
for i := 0 to Result.Dimension - 1 do
Result[i] := u[(i+Val) mod u.Dimension];
end;
class operator TRealVector.RightShift(const u: TRealVector; Val: Integer): TRealVector;
var
i: Integer;
begin
if Val < 0 then Exit(u shl -Val);
Result.Dimension := u.Dimension;
for i := 0 to Result.Dimension - 1 do
Result[(i+Val) mod Result.Dimension] := u[i];
end;
class operator TRealVector.Trunc(const u: TRealVector): TRealVector;
begin
Result := u.Apply(function(const X: TASR): TASR begin Result := System.Trunc(X) end);
end;
class operator TRealVector.Round(const u: TRealVector): TRealVector;
begin
Result := u.Apply(function(const X: TASR): TASR begin Result := System.Round(X) end);
end;
class operator TRealVector.LessThan(const u, v: TRealVector): Boolean;
begin
Result := (v - u).IsPositive;
end;
class operator TRealVector.LessThanOrEqual(const u, v: TRealVector): Boolean;
begin
Result := (v - u).IsNonNegative;
end;
class operator TRealVector.GreaterThan(const u, v: TRealVector): Boolean;
begin
Result := (u - v).IsPositive;
end;
class operator TRealVector.GreaterThanOrEqual(const u, v: TRealVector): Boolean;
begin
Result := (u - v).IsNonNegative;
end;
function TRealVector.IsZeroVector(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
for i := 0 to Dimension - 1 do
if not IsZero(FComponents[i], Epsilon) then
Exit(False);
Result := True;
end;
procedure TRealVector.Normalize;
var
_norm: TASR;
i: Integer;
begin
_norm := Norm;
if IsZero(_norm) then
raise EMathException.Create('Cannot normalize the zero vector.');
for i := 0 to Dimension - 1 do
FComponents[i] := FComponents[i] / _norm;
end;
function TRealVector.Normalized: TRealVector;
var
_norm: TASR;
i: Integer;
begin
_norm := Norm;
if IsZero(_norm) then
raise EMathException.Create('Cannot normalize the zero vector.');
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result[i] := Self[i] / _norm;
end;
function TRealVector.NormalizedIfNonzero: TRealVector;
var
_norm: TASR;
i: Integer;
begin
_norm := Norm;
if IsZero(_norm) then
Exit(Clone);
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result[i] := Self[i] / _norm;
end;
procedure TRealVector.NormalizeIfNonzero;
var
_norm: TASR;
i: Integer;
begin
_norm := Norm;
if not IsZero(_norm) then
for i := 0 to Dimension - 1 do
FComponents[i] := FComponents[i] / _norm;
end;
function TRealVector.Norm: TASR;
begin
Result := Sqrt(Self * Self);
end;
function TRealVector.NormSqr: TASR;
begin
Result := Self * Self;
end;
function TRealVector.pNorm(const p: TASR): TASR;
var
i: Integer;
begin
if p = 1 then
Exit(SumNorm);
if IsInfinite(p) and (Sign(p) = 1) then
Exit(MaxNorm);
Result := 0;
for i := 0 to Dimension - 1 do
Result := Result + Math.Power(System.Abs(Components[i]), p);
Result := Math.Power(Result, 1/p);
end;
function TRealVector.MaxNorm: TASR;
begin
Result := max(Self.Abs());
end;
function TRealVector.SumNorm: TASR;
begin
Result := sum(Self.Abs());
end;
procedure TRealVector.Swap(AIndex1, AIndex2: Integer);
begin
TSwapper<TASR>.Swap(FComponents[AIndex1], FComponents[AIndex2]);
end;
function TRealVector.kNorm(k: Integer): TASR;
begin
Result := sum(Abs.Sort(TASRComparer.StandardOrderDescending).TruncateAt(Min(k, Dimension)));
end;
function TRealVector.IsPositive(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
for i := 0 to Self.Dimension - 1 do
if (Data[i] < 0) or IsZero(Data[i], Epsilon) then
Exit(False);
Result := True;
end;
function TRealVector.IsNonNegative(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
for i := 0 to Self.Dimension - 1 do
if (Data[i] < 0) and not IsZero(Data[i], Epsilon) then
Exit(False);
Result := True;
end;
procedure TRealVector.Insert(AIndex: Integer; const AValue: TASR);
begin
TArrInserter<TASR>.Insert(FComponents, AIndex, AValue);
end;
function TRealVector.IsNegative(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
for i := 0 to Self.Dimension - 1 do
if (Data[i] > 0) or IsZero(Data[i], Epsilon) then
Exit(False);
Result := True;
end;
function TRealVector.IsNonPositive(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
for i := 0 to Self.Dimension - 1 do
if (Data[i] > 0) and not IsZero(Data[i], Epsilon) then
Exit(False);
Result := True;
end;
function TRealVector.Abs: TRealVector;
var
i: Integer;
begin
Result.Dimension := Dimension;
for i := 0 to Result.Dimension - 1 do
Result[i] := System.Abs(Self[i]);
end;
function TRealVector.TruncateAt(ALength: Integer): TRealVector;
begin
if not InRange(ALength, 1, Dimension) then
raise EMathException.Create('Cannot truncate vector at this index.');
Result := Clone;
Result.Dimension := ALength;
end;
function TRealVector.Reduce(AStep: Integer): TRealVector;
var
i: Integer;
begin
if AStep < 1 then
raise EMathException.Create('Cannot reduce vector using a non-positive step.');
Result.Dimension := Ceil(Self.Dimension / AStep);
for i := 0 to Result.Dimension - 1 do
Result[i] := Self[i * AStep];
end;
procedure TRealVector.Remove(const AIndices: array of Integer);
begin
TRemover<TASR>.Remove(FComponents, AIndices);
end;
procedure TRealVector.RemoveFirst(N: Integer);
begin
TRemover<TASR>.RemoveFirst(FComponents, N);
end;
function TRealVector.Clone: TRealVector;
begin
Result.Dimension := Dimension;
if Dimension > 0 then
Move(Self.Data[0], Result.Data[0], Result.Dimension * SizeOf(TASR));
end;
function TRealVector.Subvector(AFrom, ATo: Integer): TRealVector;
begin
AFrom := EnsureRange(AFrom, 0, Dimension - 1);
ATo := EnsureRange(ATo, 0, Dimension - 1);
Result.Dimension := ATo - AFrom + 1;
if Result.Dimension > 0 then
Move(Self.Data[AFrom], Result.Data[0], Result.Dimension * SizeOf(TASR));
end;
function TRealVector.Subvector(const AIndices: array of Integer): TRealVector;
var
i: Integer;
begin
Result.Dimension := Length(AIndices);
for i := 0 to High(AIndices) do
if InRange(AIndices[i], 0, Dimension - 1) then
Result[i] := Self[AIndices[i]]
else
raise EMathException.Create('Invalid subvector specification.');
end;
function TRealVector.Sort: TRealVector;
begin
Result := Self;
if Dimension > 0 then
TArray.Sort<TASR>(FComponents);
end;
function TRealVector.Sort(AComparer: IComparer<TASR>): TRealVector;
begin
Result := Self;
if Dimension > 0 then
TArray.Sort<TASR>(FComponents, AComparer);
end;
function TRealVector.ReverseSort: TRealVector;
begin
Result := Sort(TASRComparer.StandardOrderDescending);
end;
function TRealVector.Shuffle: TRealVector;
begin
TShuffler<TASR>.Shuffle(TArray<TASR>(FComponents));
Result := Self;
end;
function TRealVector.Unique: TRealVector;
var
i, j: Integer;
Dict: TDictionary<TASR, pointer>;
begin
Result.Dimension := Dimension;
j := 0;
Dict := TDictionary<TASR, pointer>.Create;
try
for i := 0 to Dimension - 1 do
begin
if not Dict.ContainsKey(Self[i]) then
begin
Result[j] := Self[i];
Inc(j);
Dict.Add(Self[i], nil);
end;
end;
Result.Dimension := j;
finally
Dict.Free;
end;
end;
function TRealVector.UniqueAdj: TRealVector;
var
i, j: Integer;
begin
Result.Dimension := Dimension;
if Result.Dimension = 0 then Exit;
Result[0] := Self[0];
j := 1;
for i := 1 to Dimension - 1 do
if Self[i] <> Result[j-1] then
begin
Result[j] := Self[i];
Inc(j);
end;
Result.Dimension := j;
end;
function TRealVector.UniqueEps(const Epsilon: TASR): TRealVector;
var
i, j: Integer;
begin
Result.Dimension := Dimension;
j := 0;
for i := 0 to Dimension - 1 do
if not contains(Result, Self[i], Epsilon, j) then
begin
Result[j] := Self[i];
Inc(j);
end;
Result.Dimension := j;
end;
function TRealVector.UniqueAdjEps(const Epsilon: TASR): TRealVector;
var
i, j: Integer;
begin
Result.Dimension := Dimension;
if Result.Dimension = 0 then Exit;
Result[0] := Self[0];
j := 1;
for i := 1 to Dimension - 1 do
if not SameValue(Self[i], Result[j-1], Epsilon) then
begin
Result[j] := Self[i];
Inc(j);
end;
Result.Dimension := j;
end;
function TRealVector.Reverse: TRealVector;
begin
Result := Self;
TReverser<TASR>.Reverse(TArray<TASR>(FComponents));
end;
procedure TRealVector.Append(const AValue: TASR);
begin
TArrBuilder<TASR>.Add(FComponents, AValue);
end;
function TRealVector.Apply(AFunction: TRealFunctionRef): TRealVector;
var
i: Integer;
begin
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result[i] := AFunction(Self[i]);
end;
procedure TRealVector.ExtendWith(const AValue: TRealVector);
begin
TArrExtender<TASR>.Extend(FComponents, AValue.FComponents);
end;
function TRealVector.Filter(APredicate: TPredicate<TASR>): TRealVector;
var
ActualLength: Integer;
i: Integer;
begin
Result.Dimension := Dimension;
ActualLength := 0;
for i := 0 to Dimension - 1 do
if APredicate(Self[i]) then
begin
Result[ActualLength] := Self[i];
Inc(ActualLength);
end;
Result.Dimension := ActualLength;
end;
function TRealVector.Replace(APredicate: TPredicate<TASR>; const ANewValue: TASR): TRealVector;
var
i: Integer;
begin
Result := Clone;
for i := 0 to Result.Dimension - 1 do
if APredicate(Result[i]) then
Result[i] := ANewValue;
end;
function TRealVector.Replace(const AOldValue, ANewValue: TASR; const Epsilon: Extended = 0): TRealVector;
var
i: Integer;
begin
Result := Clone;
for i := 0 to Result.Dimension - 1 do
if SameValueEx(Result[i], AOldValue, Epsilon) then
Result[i] := ANewValue;
end;
function TRealVector.Replace(const ANewValue: TASR): TRealVector;
begin
Result := TRealVector.Create(Dimension, ANewValue);
end;
function TRealVector.Defuzz(const Eps: Double): TRealVector;
var
i: Integer;
begin
Result := Self;
for i := 0 to Dimension - 1 do
if IsInteger(FComponents[i], Eps) then
FComponents[i] := Round(FComponents[i]);
end;
function TRealVector.str(const AOptions: TFormatOptions): string;
var
i: Integer;
begin
Result := '(';
if Length(FComponents) > 0 then
Result := Result + RealToStr(FComponents[0], AOptions);
for i := 1 to High(FComponents) do
Result := Result + ', ' + RealToStr(FComponents[i], AOptions);
Result := Result + ')';
end;
function ASC(const u: TRealVector): TASC; inline;
begin
Result.Re := u[0];
Result.Im := u[1];
end;
function ASR2(const u1, u2: TASR): TRealVector; inline;
begin
Result := TRealVector.Create([u1, u2]);
end;
function ASR2(const z: TASC): TRealVector; inline;
begin
Result := ASR2(z.Re, z.Im);
end;
function ASR3(const u1, u2, u3: TASR): TRealVector; inline;
begin
Result := TRealVector.Create([u1, u2, u3]);
end;
function ASR4(const u1, u2, u3, u4: TASR): TRealVector; inline;
begin
Result := TRealVector.Create([u1, u2, u3, u4]);
end;
function ASR5(const u1, u2, u3, u4, u5: TASR): TRealVector; inline;
begin
Result := TRealVector.Create([u1, u2, u3, u4, u5]);
end;
function ZeroVector(const Dimension: Integer): TRealVector;
begin
Result := TRealVector.Create(Dimension, 0);
end;
function RandomVector(const Dimension: Integer): TRealVector;
var
i: Integer;
begin
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result[i] := Random;
end;
function RandomIntVector(const Dimension, A, B: Integer): TRealVector;
var
i: Integer;
begin
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result[i] := RandomRange(A, B);
end;
function RandomVectorWithSigns(const Dimension: Integer): TRealVector;
var
i: Integer;
begin
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result[i] := 2*Random - 1;
end;
function SequenceVector(ALen: Integer; AStart: TASR = 1; AStep: TASR = 1): TRealVector;
var
val: TASR;
i: Integer;
begin
Result.Dimension := ALen;
val := AStart;
for i := 0 to Result.Dimension - 1 do
begin
Result[i] := val;
val := val + AStep;
end;
end;
function UnitVector(ADim, AIndex: Integer): TRealVector;
begin
Result := ZeroVector(ADim);
if InRange(AIndex, 0, ADim - 1) then
Result[AIndex] := 1
else
raise EMathException.Create('Invalid unit vector index.');
end;
function SameVector(const u, v: TRealVector; const Epsilon: Extended = 0): Boolean;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
Exit(False);
for i := 0 to u.Dimension - 1 do
if not SameValue(u[i], v[i], Epsilon) then
Exit(False);
Result := True;
end;
function SameVectorEx(const u, v: TRealVector; const Epsilon: Extended = 0): Boolean;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
Exit(False);
for i := 0 to u.Dimension - 1 do
if not SameValueEx(u[i], v[i], Epsilon) then
Exit(False);
Result := True;
end;
function AreParallel(const u, v: TRealVector; Epsilon: Extended = 0): Boolean;
var
factor: TASR;
i: Integer;
un, vn: TRealVector;
begin
if Epsilon = 0 then
Epsilon := 1E-12;
if u.Dimension <> v.Dimension then
raise EMathException.Create('Vectors are of different dimension.');
if u.IsZeroVector(Epsilon) or v.IsZeroVector(Epsilon) then
Exit(True);
un := u.Normalized;
vn := v.Normalized;
factor := 0;
for i := 0 to un.Dimension - 1 do
if not IsZero(un[i], Epsilon) and not IsZero(vn[i], Epsilon) then
begin
factor := vn[i] / un[i];
Break;
end;
if factor = 0 then
Exit(False);
for i := 0 to un.Dimension - 1 do
if not SameValue(factor * un[i], vn[i], Epsilon) then
Exit(False);
Result := True;
end;
function ArePerpendicular(const u, v: TRealVector; const Epsilon: Extended = 0): Boolean;
begin
Result := IsZero(u * v, Epsilon);
end;
function accumulate(const u: TRealVector; const AStart: TASR; AFunc: TAccumulator<TASR>): TASR;
var
i: Integer;
begin
Result := AStart;
for i := 0 to u.Dimension - 1 do
Result := AFunc(Result, u[i]);
end;
function sum(const u: TRealVector): TASR;
begin
Result := accumulate(u, 0, ASR_PLUS);
end;
function ArithmeticMean(const u: TRealVector): TASR;
begin
Result := sum(u) / u.Dimension;
end;
function GeometricMean(const u: TRealVector): TASR;
var
p: TASR;
begin
p := 1 / u.Dimension;
Result :=
product(u.Apply(function(const X: TASR): TASR
begin
Result := pow(X, p);
end));
end;
function HarmonicMean(const u: TRealVector): TASR;
begin
Result := 1 / ArithmeticMean(u.Apply(inv));
end;
function product(const u: TRealVector): TASR;
begin
Result := accumulate(u, 1, ASR_TIMES);
end;
function max(const u: TRealVector): TASR;
var
i: Integer;
begin
if u.Dimension = 0 then
raise EMathException.Create('Cannot find maximum component in a vector of dimension 0.');
Result := u[0];
for i := 1 to u.Dimension - 1 do
if u[i] > Result then
Result := u[i];
end;
function min(const u: TRealVector): TASR;
var
i: Integer;
begin
if u.Dimension = 0 then
raise EMathException.Create('Cannot find minimum component in a vector of dimension 0.');
Result := u[0];
for i := 1 to u.Dimension - 1 do
if u[i] < Result then
Result := u[i];
end;
function exists(const u: TRealVector; APredicate: TPredicate<TASR>): Boolean; overload;
var
i: Integer;
begin
Result := False;
for i := 0 to u.Dimension - 1 do
if APredicate(u[i]) then
Exit(true);
end;
function count(const u: TRealVector; APredicate: TPredicate<TASR>): Integer; overload;
var
i: Integer;
begin
Result := 0;
for i := 0 to u.Dimension - 1 do
if APredicate(u[i]) then
Inc(Result);
end;
function count(const u: TRealVector; const AValue: TASR): Integer; overload;
var
i: Integer;
begin
Result := 0;
for i := 0 to u.Dimension - 1 do
if SameValue(u[i], AValue) then
Inc(Result);
end;
function ForAll(const u: TRealVector; APredicate: TPredicate<TASR>): Boolean; overload;
var
i: Integer;
begin
for i := 0 to u.Dimension - 1 do
if not APredicate(u[i]) then
Exit(False);
Result := True;
end;
function contains(const u: TRealVector; const AValue: TASR;
const AEpsilon: TASR; ALen: Integer): Boolean; overload;
var
i: Integer;
begin
if ALen = -1 then
ALen := u.Dimension;
for i := 0 to ALen - 1 do
if SameValue(u[i], AValue, AEpsilon) then
Exit(True);
Result := False;
end;
function CrossProduct(const u, v: TRealVector): TRealVector;
begin
if (u.Dimension <> 3) or (v.Dimension <> 3) then
raise EMathException.Create('Vector cross product only defined in ℝ³.');
Result.Dimension := 3;
Result[0] := u[1] * v[2] - u[2] * v[1];
Result[1] := u[2] * v[0] - u[0] * v[2];
Result[2] := u[0] * v[1] - u[1] * v[0];
end;
function angle(const u, v: TRealVector): TASR;
begin
if not (u.Dimension = v.Dimension) then
raise EMathException.Create('Cannot compute angle between vectors of different dimension.');
var unorm := u.Norm;
var vnorm := v.Norm;
if (unorm = 0.0) or (vnorm = 0.0) then
raise EMathException.Create('Cannot compute angle to the zero vector.');
var alpha := (u / unorm) * (v / vnorm);
if SameValue(alpha, 1.0) then
Result := 0.0
else if SameValue(alpha, -1.0) then
Result := Pi
else
Result := arccos(alpha);
end;
function VectConcat(const u, v: TRealVector): TRealVector; overload;
begin
Result.Dimension := u.Dimension + v.Dimension;
if u.Dimension > 0 then
VectMove(u, 0, u.Dimension - 1, Result);
if v.Dimension > 0 then
VectMove(v, 0, v.Dimension - 1, Result, u.Dimension);
end;
constructor TComplexVector.Create(const Components: array of TASC);
begin
SetLength(FComponents, Length(Components));
if Length(Components) > 0 then
Move(Components[0], FComponents[0], Length(Components) * SizeOf(TASC));
end;
constructor TComplexVector.Create(ASize: Integer; const AVal: TASC);
var
i: Integer;
begin
if ASize < 0 then
raise EMathException.Create('Cannot create vector with negative dimension.');
SetLength(FComponents, ASize);
for i := 0 to High(FComponents) do
FComponents[i] := AVal;
end;
function TComplexVector.GetDimension: Integer;
begin
Result := Length(FComponents);
end;
procedure TComplexVector.SetDimension(const Value: Integer);
begin
if Value < 0 then
raise EMathException.Create('Cannot create vector with negative dimension.');
SetLength(FComponents, Value);
end;
function TComplexVector.GetComponent(Index: Integer): TASC;
begin
Result := FComponents[Index];
end;
function TComplexVector.SafeSort(AComparer: IComparer<TASC>): TComplexVector;
begin
Result := Self;
if Dimension > 0 then
TSafeSorter<TASC>.Sort(FComponents, AComparer);
end;
procedure TComplexVector.SetComponent(Index: Integer; const Value: TASC);
begin
FComponents[Index] := Value;
end;
class operator TComplexVector.Implicit(const u: TRealVector): TComplexVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i];
end;
procedure TComplexVector.Insert(AIndex: Integer; const AValue: TASC);
begin
TArrInserter<TASC>.Insert(FComponents, AIndex, AValue);
end;
class operator TComplexVector.Negative(const u: TComplexVector): TComplexVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := -u[i];
end;
class operator TComplexVector.Add(const u: TComplexVector; const v: TComplexVector): TComplexVector;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
raise EMathException.Create('Cannot add two vectors of unequal dimension.');
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] + v[i];
end;
class operator TComplexVector.Add(const u: TComplexVector; const z: TASC): TComplexVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] + z;
end;
class operator TComplexVector.Subtract(const u: TComplexVector; const v: TComplexVector): TComplexVector;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
raise EMathException.Create('Cannot subtract two vectors of unequal dimension.');
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] - v[i];
end;
class operator TComplexVector.Subtract(const u: TComplexVector; const z: TASC): TComplexVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] - z;
end;
class operator TComplexVector.Multiply(const u: TComplexVector; const v: TComplexVector): TASC;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
raise EMathException.Create('Cannot compute dot product of two vectors of unequal dimension.');
Result := 0;
for i := 0 to u.Dimension - 1 do
Result := Result + u[i] * v[i].Conjugate;
end;
class operator TComplexVector.Multiply(const z: TASC; const u: TComplexVector): TComplexVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := z * u[i];
end;
class operator TComplexVector.Multiply(const u: TComplexVector; const z: TASC): TComplexVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := z * u[i];
end;
class operator TComplexVector.Divide(const u: TComplexVector; const z: TASC): TComplexVector;
var
i: Integer;
begin
Result.Dimension := u.Dimension;
for i := 0 to u.Dimension - 1 do
Result[i] := u[i] / z;
end;
class operator TComplexVector.Equal(const u: TComplexVector; const v: TComplexVector): Boolean;
var
i: Integer;
begin
Result := u.Dimension = v.Dimension;
if Result then
for i := 0 to u.Dimension - 1 do
if u[i] <> v[i] then
Exit(False);
end;
class operator TComplexVector.NotEqual(const u: TComplexVector; const v: TComplexVector): Boolean;
begin
Result := not (u = v);
end;
class operator TComplexVector.LeftShift(const u: TComplexVector; Val: Integer): TComplexVector;
var
i: Integer;
begin
if Val < 0 then Exit(u shr -Val);
Result.Dimension := u.Dimension;
for i := 0 to Result.Dimension - 1 do
Result[i] := u[(i+Val) mod u.Dimension];
end;
class operator TComplexVector.RightShift(const u: TComplexVector; Val: Integer): TComplexVector;
var
i: Integer;
begin
if Val < 0 then Exit(u shl -Val);
Result.Dimension := u.Dimension;
for i := 0 to Result.Dimension - 1 do
Result[(i+Val) mod Result.Dimension] := u[i];
end;
class operator TComplexVector.Round(const u: TComplexVector): TComplexVector;
begin
Result := u.Apply(function(const X: TASC): TASC begin Result := Round(X) end);
end;
function TComplexVector.IsReal: Boolean;
var
i: Integer;
begin
for i := 0 to Dimension - 1 do
if not FComponents[i].IsReal then
Exit(False);
Result := True;
end;
function TComplexVector.IsZeroVector(const Epsilon: Extended = 0): Boolean;
var
i: Integer;
begin
for i := 0 to Dimension - 1 do
if not CIsZero(FComponents[i], Epsilon) then
Exit(False);
Result := True;
end;
function TComplexVector.kNorm(k: Integer): TASR;
begin
Result := sum(Abs.Sort(TASRComparer.StandardOrderDescending).TruncateAt(Min(k, Dimension)));
end;
procedure TComplexVector.Normalize;
var
_norm: TASR;
i: Integer;
begin
_norm := Norm;
if IsZero(_norm) then
raise EMathException.Create('Cannot normalize the zero vector.');
for i := 0 to Dimension - 1 do
FComponents[i] := FComponents[i] / _norm;
end;
function TComplexVector.Normalized: TComplexVector;
var
_norm: TASR;
i: Integer;
begin
_norm := Norm;
if IsZero(_norm) then
raise EMathException.Create('Cannot normalize the zero vector.');
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result[i] := Self[i] / _norm;
end;
function TComplexVector.NormalizedIfNonzero: TComplexVector;
var
_norm: TASR;
i: Integer;
begin
_norm := Norm;
if IsZero(_norm) then
Exit(Clone);
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result[i] := Self[i] / _norm;
end;
procedure TComplexVector.NormalizeIfNonzero;
var
_norm: TASR;
i: Integer;
begin
_norm := Norm;
if not IsZero(_norm) then
for i := 0 to Dimension - 1 do
FComponents[i] := FComponents[i] / _norm;
end;
function TComplexVector.Norm: TASR;
begin
Result := Sqrt((Self * Self).Re);
end;
function TComplexVector.NormSqr: TASR;
begin
Result := (Self * Self).Re;
end;
function TComplexVector.pNorm(const p: TASR): TASR;
var
i: Integer;
begin
if p = 1 then
Exit(SumNorm);
if p = Infinity then
Exit(MaxNorm);
Result := 0;
for i := 0 to Dimension - 1 do
Result := Result + Math.Power(Components[i].Modulus, p);
Result := Math.Power(Result, 1/p);
end;
function TComplexVector.MaxNorm: TASR;
begin
Result := max(Self.Abs());
end;
function TComplexVector.SumNorm: TASR;
begin
Result := sum(Self.Abs());
end;
procedure TComplexVector.Swap(AIndex1, AIndex2: Integer);
begin
TSwapper<TASC>.Swap(FComponents[AIndex1], FComponents[AIndex2]);
end;
function TComplexVector.Abs: TRealVector;
var
i: Integer;
begin
Result.Dimension := Dimension;
for i := 0 to Result.Dimension - 1 do
Result[i] := Self[i].Modulus;
end;
function TComplexVector.TruncateAt(ALength: Integer): TComplexVector;
begin
if not InRange(ALength, 1, Dimension) then
raise EMathException.Create('Cannot truncate vector at this index.');
Result := Clone;
Result.Dimension := ALength;
end;
function TComplexVector.Reduce(AStep: Integer): TComplexVector;
var
i: Integer;
begin
if AStep < 1 then
raise EMathException.Create('Cannot reduce vector using a non-positive step.');
Result.Dimension := Ceil(Dimension / AStep);
for i := 0 to Result.Dimension - 1 do
Result[i] := Self[i * AStep];
end;
procedure TComplexVector.Remove(const AIndices: array of Integer);
begin
TRemover<TASC>.Remove(FComponents, AIndices);
end;
procedure TComplexVector.RemoveFirst(N: Integer);
begin
TRemover<TASC>.RemoveFirst(FComponents, N);
end;
function TComplexVector.Clone: TComplexVector;
begin
Result.Dimension := Dimension;
if Dimension > 0 then
Move(Self.Data[0], Result.Data[0], Result.Dimension * SizeOf(TASC));
end;
function TComplexVector.Subvector(AFrom, ATo: Integer): TComplexVector;
begin
AFrom := EnsureRange(AFrom, 0, Dimension - 1);
ATo := EnsureRange(ATo, 0, Dimension - 1);
Result.Dimension := ATo - AFrom + 1;
if Result.Dimension > 0 then
Move(Self.Data[AFrom], Result.Data[0], Result.Dimension * SizeOf(TASC));
end;
function TComplexVector.Subvector(const AIndices: array of Integer): TComplexVector;
var
i: Integer;
begin
Result.Dimension := Length(AIndices);
for i := 0 to High(AIndices) do
if InRange(AIndices[i], 0, Dimension - 1) then
Result[i] := Self[AIndices[i]]
else
raise EMathException.Create('Invalid subvector specification.');
end;
function TComplexVector.Sort(AComparer: IComparer<TASC>): TComplexVector;
begin
Result := Self;
if Dimension > 0 then
TArray.Sort<TASC>(FComponents, AComparer);
end;
function TComplexVector.Shuffle: TComplexVector;
begin
TShuffler<TASC>.Shuffle(TArray<TASC>(FComponents));
Result := Self;
end;
function TComplexVector.Unique: TComplexVector;
var
i, j: Integer;
Dict: TDictionary<TASC, pointer>;
begin
Result.Dimension := Dimension;
j := 0;
Dict := TDictionary<TASC, pointer>.Create;
try
for i := 0 to Dimension - 1 do
begin
if not Dict.ContainsKey(Self[i]) then
begin
Result[j] := Self[i];
Inc(j);
Dict.Add(Self[i], nil);
end;
end;
Result.Dimension := j;
finally
Dict.Free;
end;
end;
function TComplexVector.UniqueAdj: TComplexVector;
var
i, j: Integer;
begin
Result.Dimension := Dimension;
if Result.Dimension = 0 then Exit;
Result[0] := Self[0];
j := 1;
for i := 1 to Dimension - 1 do
if Self[i] <> Result[j-1] then
begin
Result[j] := Self[i];
Inc(j);
end;
Result.Dimension := j;
end;
function TComplexVector.UniqueEps(const Epsilon: TASR): TComplexVector;
var
i, j: Integer;
begin
Result.Dimension := Dimension;
j := 0;
for i := 0 to Dimension - 1 do
if not contains(Result, Self[i], Epsilon, j) then
begin
Result[j] := Self[i];
Inc(j);
end;
Result.Dimension := j;
end;
function TComplexVector.UniqueAdjEps(const Epsilon: TASR): TComplexVector;
var
i, j: Integer;
begin
Result.Dimension := Dimension;
if Result.Dimension = 0 then Exit;
Result[0] := Self[0];
j := 1;
for i := 1 to Dimension - 1 do
if not CSameValue(Self[i], Result[j-1], Epsilon) then
begin
Result[j] := Self[i];
Inc(j);
end;
Result.Dimension := j;
end;
function TComplexVector.Reverse: TComplexVector;
begin
Result := Self;
TReverser<TASC>.Reverse(TArray<TASC>(FComponents));
end;
procedure TComplexVector.Append(const AValue: TASC);
begin
TArrBuilder<TASC>.Add(FComponents, AValue);
end;
function TComplexVector.Apply(AFunction: TComplexFunctionRef): TComplexVector;
var
i: Integer;
begin
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result[i] := AFunction(Self[i]);
end;
procedure TComplexVector.ExtendWith(const AValue: TComplexVector);
begin
TArrExtender<TASC>.Extend(FComponents, AValue.FComponents);
end;
function TComplexVector.Filter(APredicate: TPredicate<TASC>): TComplexVector;
var
ActualLength: Integer;
i: Integer;
begin
Result.Dimension := Dimension;
ActualLength := 0;
for i := 0 to Dimension - 1 do
if APredicate(Self[i]) then
begin
Result[ActualLength] := Self[i];
Inc(ActualLength);
end;
Result.Dimension := ActualLength;
end;
function TComplexVector.Replace(APredicate: TPredicate<TASC>;
const ANewValue: TASC): TComplexVector;
var
i: Integer;
begin
Result := Clone;
for i := 0 to Result.Dimension - 1 do
if APredicate(Result[i]) then
Result[i] := ANewValue;
end;
function TComplexVector.Replace(const AOldValue, ANewValue: TASC;
const Epsilon: Extended = 0): TComplexVector;
var
i: Integer;
begin
Result := Clone;
for i := 0 to Result.Dimension - 1 do
if CSameValueEx(Result[i], AOldValue, Epsilon) then
Result[i] := ANewValue;
end;
function TComplexVector.Replace(const ANewValue: TASC): TComplexVector;
begin
Result := TComplexVector.Create(Dimension, ANewValue);
end;
function TComplexVector.RealPart: TRealVector;
var
i: Integer;
begin
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result.Data[i] := Data[i].Re;
end;
function TComplexVector.ImaginaryPart: TRealVector;
var
i: Integer;
begin
Result.Dimension := Dimension;
for i := 0 to Dimension - 1 do
Result.Data[i] := Data[i].Im;
end;
function TComplexVector.Defuzz(const Eps: Double): TComplexVector;
var
i: Integer;
begin
Result := Self;
for i := 0 to Dimension - 1 do
Result[i] := Result[i].Defuzz(Eps);
end;
function TComplexVector.str(const AOptions: TFormatOptions): string;
var
i: Integer;
begin
Result := '(';
if Length(FComponents) > 0 then
Result := Result + ComplexToStr(FComponents[0], False, AOptions);
for i := 1 to High(FComponents) do
Result := Result + ', ' + ComplexToStr(FComponents[i], False, AOptions);
Result := Result + ')';
end;
function ASC2(const u1, u2: TASC): TComplexVector; inline;
begin
Result := TComplexVector.Create([u1, u2]);
end;
function ASC3(const u1, u2, u3: TASC): TComplexVector; inline;
begin
Result := TComplexVector.Create([u1, u2, u3]);
end;
function ASC4(const u1, u2, u3, u4: TASC): TComplexVector; inline;
begin
Result := TComplexVector.Create([u1, u2, u3, u4]);
end;
function ASC5(const u1, u2, u3, u4, u5: TASC): TComplexVector; inline;
begin
Result := TComplexVector.Create([u1, u2, u3, u4, u5]);
end;
function ComplexZeroVector(const Dimension: Integer): TComplexVector;
begin
Result := TComplexVector.Create(Dimension, 0);
end;
function SameVector(const u, v: TComplexVector; const Epsilon: Extended = 0): Boolean;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
Exit(False);
for i := 0 to u.Dimension - 1 do
if not CSameValue(u[i], v[i], Epsilon) then
Exit(False);
Result := True;
end;
function SameVectorEx(const u, v: TComplexVector; const Epsilon: Extended = 0): Boolean;
var
i: Integer;
begin
if u.Dimension <> v.Dimension then
Exit(False);
for i := 0 to u.Dimension - 1 do
if not CSameValueEx(u[i], v[i], Epsilon) then
Exit(False);
Result := True;
end;
function AreParallel(const u, v: TComplexVector; Epsilon: Extended = 0): Boolean;
var
factor: TASC;
i: Integer;
un, vn: TComplexVector;
begin
if Epsilon = 0 then
Epsilon := 1E-12;
if u.Dimension <> v.Dimension then
raise EMathException.Create('Vectors are of different dimension.');
if u.IsZeroVector(Epsilon) or v.IsZeroVector(Epsilon) then
Exit(True);
un := u.Normalized;
vn := v.Normalized;
factor := 0;
for i := 0 to un.Dimension - 1 do
if not CIsZero(un[i], Epsilon) and not CIsZero(vn[i], Epsilon) then
begin
factor := vn[i] / un[i];
Break;
end;
if factor = 0 then
Exit(False);
for i := 0 to un.Dimension - 1 do
if not CSameValue(factor * un[i], vn[i], Epsilon) then
Exit(False);
Result := True;
end;
function ArePerpendicular(const u, v: TComplexVector; const Epsilon: Extended = 0): Boolean;
begin
Result := CIsZero(u * v, Epsilon);
end;
function accumulate(const u: TComplexVector; const AStart: TASC; AFunc: TAccumulator<TASC>): TASC;
var
i: Integer;
begin
Result := AStart;
for i := 0 to u.Dimension - 1 do
Result := AFunc(Result, u[i]);
end;
function sum(const u: TComplexVector): TASC;
begin
Result := accumulate(u, 0, ASC_PLUS);
end;
function ArithmeticMean(const u: TComplexVector): TASC;
begin
Result := sum(u) / u.Dimension;
end;
function GeometricMean(const u: TComplexVector): TASC;
var
p: TASR;
begin
p := 1 / u.Dimension;
Result :=
product(u.Apply(function(const X: TASC): TASC
begin
Result := cpow(X, p);
end));
end;
function HarmonicMean(const u: TComplexVector): TASC;
begin
Result := 1 / ArithmeticMean(u.Apply(cinv));
end;
function product(const u: TComplexVector): TASC;
begin
Result := accumulate(u, 1, ASC_TIMES);
end;
function exists(const u: TComplexVector; APredicate: TPredicate<TASC>): Boolean; overload;
var
i: Integer;
begin
for i := 0 to u.Dimension - 1 do
if APredicate(u[i]) then
Exit(True);
Result := False;
end;
function count(const u: TComplexVector; APredicate: TPredicate<TASC>): Integer; overload;
var
i: Integer;
begin
Result := 0;
for i := 0 to u.Dimension - 1 do
if APredicate(u[i]) then
Inc(Result);
end;
function count(const u: TComplexVector; const AValue: TASC): Integer; overload;
var
i: Integer;
begin
Result := 0;
for i := 0 to u.Dimension - 1 do
if CSameValue(u[i], AValue) then
Inc(Result);
end;
function ForAll(const u: TComplexVector; APredicate: TPredicate<TASC>): Boolean; overload;
var
i: Integer;
begin
for i := 0 to u.Dimension - 1 do
if not APredicate(u[i]) then
Exit(False);
Result := True;
end;
function contains(const u: TComplexVector; const AValue: TASC;
const AEpsilon: TASR; ALen: Integer): Boolean; overload;
var
i: Integer;
begin
if ALen = -1 then
ALen := u.Dimension;
for i := 0 to ALen - 1 do
if CSameValue(u[i], AValue, AEpsilon) then
Exit(True);
Result := False;
end;
function CrossProduct(const u, v: TComplexVector): TComplexVector;
begin
if (u.Dimension <> 3) or (v.Dimension <> 3) then
raise EMathException.Create('Vector cross product only defined in ℂ³.');
Result.Dimension := 3;
Result[0] := u[1] * v[2] - u[2] * v[1];
Result[1] := u[2] * v[0] - u[0] * v[2];
Result[2] := u[0] * v[1] - u[1] * v[0];
end;
function angle(const u, v: TComplexVector): TASR;
begin
if not (u.Dimension = v.Dimension) then
raise EMathException.Create('Cannot compute angle between vectors of different dimension.');
Result := arccos((u*v).Re/(u.Norm * v.Norm));
end;
function VectConcat(const u, v: TComplexVector): TComplexVector; overload;
begin
Result.Dimension := u.Dimension + v.Dimension;
if u.Dimension > 0 then
VectMove(u, 0, u.Dimension - 1, Result);
if v.Dimension > 0 then
VectMove(v, 0, v.Dimension - 1, Result, u.Dimension);
end;
class function TDuplicateFinder<T>.ContainsDuplicates(Arr: array of T): Boolean;
var
i: Integer;
begin
TArray.Sort<T>(Arr);
Result := PresortedContainsDuplicates(Arr);
end;
class function TDuplicateFinder<T>.PresortedContainsDuplicates(const Arr: array of T): Boolean;
var
i: Integer;
begin
for i := 1 to High(Arr) do
if TEqualityComparer<T>.Default.Equals(Arr[i], Arr[i - 1]) then
Exit(True);
Result := False;
end;
constructor TMatrixSize.CreateUnsafe(Rows, Cols: Integer);
begin
FRows := Rows;
FCols := Cols;
end;
constructor TMatrixSize.Create(Rows: Integer; Cols: Integer);
begin
if (Rows <= 0) or (Cols <= 0) then
raise EMathException.Create('A matrix must have size at least 1×1.');
FRows := Rows;
FCols := Cols;
end;
constructor TMatrixSize.Create(Size: Integer);
begin
Create(Size, Size);
end;
function TMatrixSize.ElementCount: Integer;
begin
Result := FRows * FCols;
end;
function TMatrixSize.SmallestDimension: Integer;
begin
Result := Min(FRows, FCols);
end;
function TMatrixSize.TransposeSize: TMatrixSize;
begin
Result.FRows := Self.FCols;
Result.FCols := Self.FRows;
end;
function TMatrixSize.LessenedSize: TMatrixSize;
begin
Result.FRows := Self.FRows;
Result.FCols := Self.FCols - 1;
end;
class operator TMatrixSize.Implicit(const AMatrixSize: TMatrixSize): TSize;
begin
Result.Width := AMatrixSize.Cols;
Result.Height := AMatrixSize.Rows;
end;
class operator TMatrixSize.Implicit(const ASize: TSize): TMatrixSize;
begin
Result := TMatrixSize.Create(ASize.Height, ASize.Width);
end;
function TMatrixSize.IsSquare: Boolean;
begin
Result := FRows = FCols;
end;
class operator TMatrixSize.Implicit(S: Integer): TMatrixSize;
begin
Result := TMatrixSize.Create(S);
end;
class operator TMatrixSize.Equal(const S1, S2: TMatrixSize): Boolean;
begin
Result := (S1.FRows = S2.FRows) and (S1.FCols = S2.FCols);
end;
class operator TMatrixSize.NotEqual(const S1, S2: TMatrixSize): Boolean;
begin
Result := not (S1 = S2);
end;
class operator TMatrixSize.Add(const S1, S2: TMatrixSize): TMatrixSize;
begin
Result.FRows := S1.FRows + S2.FRows;
Result.FCols := S1.FCols + S2.FCols;
end;
function __sign(const P: TIndexArray): Integer;
var
i: Integer;
begin
Result := 1;
for i := 0 to High(P) do
if P[i] = -1 then
Exit(0)
else if P[i] <> i then
Result := -Result;
end;
const
_EmptyMatrix: TRealMatrix = (FSize: (FRows: 0; FCols: 0); FElements: nil;
FRowOpSeq: nil; FRowOpCount: 0; FRowOpFactor: 0; _FCollectRowOpData: False);
constructor TRealMatrix.CreateWithoutAllocation(const ASize: TMatrixSize);
begin
FSize := ASize;
FElements := nil;
_FCollectRowOpData := False;
end;
constructor TRealMatrix.CreateUninitialized(const ASize: TMatrixSize);
begin
Alloc(ASize);
end;
constructor TRealMatrix.Create(const AMatrix: TRealMatrix);
begin
Alloc(AMatrix.Size);
Move(AMatrix.Data[0], FElements[0], Length(Self.Data) * SizeOf(TASR));
end;
constructor TRealMatrix.Create(const Elements: array of TASRArray);
var
rc, cc: Integer;
i: Integer;
begin
rc := Length(Elements);
cc := 0;
if rc > 0 then
cc := Length(Elements[0]);
Alloc(rc, cc);
for i := 0 to rc - 1 do
begin
if Length(Elements[i]) <> cc then
raise EMathException.Create('Attempt to create a non-rectangular matrix.');
Move(Elements[i][0], FElements[i*cc], cc*SizeOf(Elements[i][0]));
end;
end;
constructor TRealMatrix.Create(const Elements: array of TASR; Cols: Integer = 1);
begin
if Cols <= 0 then
raise EMathException.Create('A matrix must have size at least 1×1.');
if Length(Elements) mod Cols <> 0 then
raise EMathException.Create('Attempt to create a non-rectangular matrix.');
Alloc(Length(Elements) div Cols, Cols);
Move(Elements[0], FElements[0], Length(Elements) * SizeOf(Elements[0]));
end;
constructor TRealMatrix.Create(const ASize: TMatrixSize; const AVal: TASR = 0);
var
i: Integer;
begin
Alloc(ASize);
for i := 0 to FSize.ElementCount - 1 do
FElements[i] := AVal;
end;
constructor TRealMatrix.CreateFromRows(const Rows: array of TRealVector);
var
rc, cc: Integer;
i: Integer;
begin
rc := Length(Rows);
cc := 0;
if rc > 0 then
cc := Rows[0].Dimension;
Alloc(rc, cc);
for i := 0 to rc - 1 do
begin
if Rows[i].Dimension <> cc then
raise EMathException.Create('Attempt to create a non-rectangular matrix.');
Move(Rows[i].Data[0], FElements[i*cc], cc*SizeOf(Rows[i][0]));
end;
end;
constructor TRealMatrix.CreateFromColumns(const Columns: array of TRealVector);
var
rc, cc: Integer;
i: Integer;
begin
cc := Length(Columns);
rc := 0;
if cc > 0 then
rc := Columns[0].Dimension;
Alloc(rc, cc);
for i := 0 to cc - 1 do
if Columns[i].Dimension <> rc then
raise EMathException.Create('Attempt to create a non-rectangular matrix.');
for i := 0 to FSize.ElementCount - 1 do
FElements[i] := Columns[i mod cc][i div cc];
end;
constructor TRealMatrix.Create(const u: TRealVector; const v: TRealVector);
var
i: Integer;
begin
Alloc(u.Dimension, v.Dimension);
for i := 0 to Size.ElementCount - 1 do
FElements[i] := u[i div Size.Cols] * v[i mod Size.Cols];
end;
constructor TRealMatrix.Create(const ASize: TMatrixSize; AFunction: TMatrixIndexFunction<TASR>);
var
i: Integer;
begin
Alloc(ASize);
for i := 0 to Size.ElementCount - 1 do
FElements[i] := AFunction(i div Size.Cols + 1, i mod Size.Cols + 1);
end;
constructor TRealMatrix.CreateDiagonal(const Elements: array of TASR);
var
i: Integer;
begin
Alloc(Length(Elements));
FillChar(FElements[0], Size.ElementCount * SizeOf(FElements[0]), 0);
for i := 0 to Size.Cols - 1 do
FElements[i * (Size.Cols + 1)] := Elements[i];
end;
constructor TRealMatrix.CreateDiagonal(const Elements: TRealVector);
begin
CreateDiagonal(Elements.Data);
end;
constructor TRealMatrix.CreateDiagonal(ASize: Integer; AVal: TASR = 1);
var
i: Integer;
begin
Alloc(ASize);
FillChar(FElements[0], Size.ElementCount * SizeOf(FElements[0]), 0);
for i := 0 to Size.Cols - 1 do
FElements[i * (Size.Cols + 1)] := AVal;
end;
constructor TRealMatrix.Create(const Blocks: array of TRealMatrix; Cols: Integer = 2);
var
Rows: Integer;
RowRows, RowTops, ColCols, ColLefts: array of Integer;
i: Integer;
j: Integer;
index: Integer;
begin
if Length(Blocks) = 0 then
raise EMathException.Create('Invalid block matrix construction: the number of blocks has to be at least 1.');
if Cols < 1 then
raise EMathException.Create('Invalid block matrix construction: the number of blocks per row has to be at least 1.');
if Cols > Length(Blocks) then
raise EMathException.Create('Invalid block matrix construction: too few blocks to fill the first row.');
Rows := Length(Blocks) div Cols;
if Length(Blocks) mod Cols <> 0 then
Inc(Rows);
SetLength(RowRows, Rows);
SetLength(RowTops, Rows + 1);
SetLength(ColCols, Cols);
SetLength(ColLefts, Cols + 1);
for i := 0 to Cols - 1 do
ColCols[i] := Blocks[i].Size.Cols;
ColLefts[0] := 0;
for i := 1 to Cols do
ColLefts[i] := ColLefts[i - 1] + ColCols[i - 1];
for i := 0 to Rows - 1 do
RowRows[i] := Blocks[i * Cols].Size.Rows;
RowTops[0] := 0;
for i := 1 to Rows do
RowTops[i] := RowTops[i - 1] + RowRows[i - 1];
index := 0;
for i := 0 to Rows - 1 do
for j := 0 to Cols - 1 do
begin
if index < Length(Blocks) then
with Blocks[index] do
if (Size.Rows <> RowRows[i]) or (Size.Cols <> ColCols[j]) or (Size.ElementCount < 1) then
raise EMathException.CreateFmt('Invalid block matrix construction: invalid block at position (%d, %d), index %d.', [i + 1, j + 1, index + 1]);
Inc(index);
end;
Alloc(RowTops[Rows], ColLefts[Cols]);
index := 0;
for i := 0 to Rows - 1 do
for j := 0 to Cols - 1 do
begin
if index < Length(Blocks) then
MatMove(Blocks[index], Self, Point(ColLefts[j], RowTops[i]))
else
begin
MatBlockFill(Self, Rect(ColLefts[j], RowTops[i], Size.Cols - 1, Size.Rows - 1), 0);
Break;
end;
Inc(index);
end;
end;
function TRealMatrix.GetElement(Row: Integer; Col: Integer): TASR;
begin
Result := FElements[Size.Cols * Row + Col];
end;
procedure TRealMatrix.SetElement(Row: Integer; Col: Integer; const Value: TASR);
begin
FElements[Size.Cols * Row + Col] := Value;
end;
procedure TRealMatrix.Alloc(ARows: Integer; ACols: Integer);
begin
FSize.Create(ARows, ACols);
SetLength(FElements, Size.ElementCount);
_FCollectRowOpData := False;
end;
procedure TRealMatrix.Alloc(ASize: Integer);
begin
FSize.Create(ASize);
SetLength(FElements, Size.ElementCount);
_FCollectRowOpData := False;
end;
procedure TRealMatrix.Alloc(const ASize: TMatrixSize);
begin
FSize := ASize;
SetLength(FElements, Size.ElementCount);
_FCollectRowOpData := False;
end;
function TRealMatrix.GetRowData(AIndex: Integer): PASR;
begin
Result := @FElements[Size.Cols * AIndex];
end;
function TRealMatrix.SafeGetRowData(AIndex: Integer): PASR;
begin
if not InRange(AIndex, 0, Size.Rows - 1) then
raise Exception.Create('The specified row does not exist.');
Result := GetRowData(AIndex);
end;
function TRealMatrix.SafeSort(AComparer: IComparer<TASR>): TRealMatrix;
begin
TRealVector(FElements).SafeSort(AComparer);
Result := Self;
end;
function TRealMatrix.GetMemorySize: Int64;
begin
Result := SizeOf(Self) + Length(FElements) * SizeOf(TASR) +
Length(FRowOpSeq) * SizeOf(TRealRowOperationRecord);
end;
function TRealMatrix.IsEmpty: Boolean;
begin
Result := Size.ElementCount = 0;
end;
procedure TRealMatrix.BeginCollectRowOpData;
begin
Assert(InitialRowOpSeqSize > 0);
SetLength(FRowOpSeq, InitialRowOpSeqSize);
FRowOpCount := 0;
FRowOpFactor := 1;
_FCollectRowOpData := True;
end;
procedure TRealMatrix.AddRowOpRecord(AType: TRowOperationType; ARow1,
ARow2: Integer; AFactor: TASR);
begin
Assert(_FCollectRowOpData);
if FRowOpCount = Length(FRowOpSeq) then
SetLength(FRowOpSeq, 2*FRowOpCount);
FRowOpSeq[FRowOpCount].RowOperationType := AType;
FRowOpSeq[FRowOpCount].Row1 := ARow1;
FRowOpSeq[FRowOpCount].Row2 := ARow2;
FRowOpSeq[FRowOpCount].Factor := AFactor;
Inc(FRowOpCount);
case AType of
roSwap:
FRowOpFactor := -FRowOpFactor;
roScale:
FRowOpFactor := FRowOpFactor * AFactor;
roAddMul: ;
end;
end;
function TRealMatrix.Eigenvalues2x2: TComplexVector;
var
a, b, c, d, ad, bc, avg, avgsq, disc: TASR;
begin
a := Self[0, 0];
b := Self[0, 1];
c := Self[1, 0];
d := Self[1, 1];
ad := a * d;
bc := b * c;
if SameValue2(a, -d) then
avg := 0
else
avg := (a + d) / 2;
avgsq := avg * avg;
if SameValue2(ad, bc) then
disc := avgsq
else
if SameValue2(avgsq, ad - bc) then
disc := 0
else
disc := avgsq - ad + bc;
if disc = 0 then
Exit( avg * ASC2(1, 1) );
if disc > 0 then
Exit( avg * ASC2(1, 1) + sqrt(disc) * ASC2(1, -1) );
Exit( avg * ASC2(1, 1) + sqrt(-disc) * ImaginaryUnit * ASC2(1, -1) );
end;
procedure TRealMatrix.DoQuickLU(out A: TRealMatrix; out P: TIndexArray);
var
y: Integer;
yp: Integer;
maxval, newval: TASR;
maxpos: Integer;
x: Integer;
row1, row2: PASR;
begin
if not IsSquare then
raise EMathException.Create('LU decomposition only implemented for square matrices.');
RequireNonEmpty;
A := Clone;
SetLength(P, Size.Rows);
for y := 0 to Size.Rows - 2 do
begin
row1 := A.RowData[y];
maxpos := A.Size.Rows - 1;
maxval := System.Abs(A[Size.Rows - 1, y]);
for yp := A.Size.Rows - 2 downto y do
begin
newval := System.Abs(A[yp, y]);
if newval > maxval then
begin
maxval := newval;
maxpos := yp;
end;
end;
if IsZero(maxval) then
P[y] := -1
else
begin
P[y] := maxpos;
if maxpos <> y then
A.RowSwap(maxpos, y);
for yp := y + 1 to Size.Rows - 1 do
begin
row2 := A.RowData[yp];
row2[y] := row2[y] / row1[y];
for x := y + 1 to Size.Cols - 1 do
row2[x] := row2[x] - row2[y] * row1[x];
end;
end;
DoYield;
end;
if IsZero(A.Data[A.Size.ElementCount - 1]) then
P[Size.Rows - 1] := -1
else
P[Size.Rows - 1] := Size.Rows - 1;
end;
class operator TRealMatrix.Implicit(const u: TRealVector): TRealMatrix;
begin
if u.Dimension = 0 then
Exit(_EmptyMatrix);
Result.Alloc(TMatrixSize.CreateUnsafe(u.Dimension, 1));
if u.Dimension > 0 then
Move(u.Data[0], Result.Data[0], u.Dimension * SizeOf(TASR));
end;
class operator TRealMatrix.Explicit(const A: TRealMatrix): TRealVector;
begin
if A.IsColumn then
Result := TRealVector(A.Data)
else
raise EMathException.Create('Cannot treat matrix as vector if it isn''t a column vector.');
end;
class operator TRealMatrix.Explicit(X: TASR): TRealMatrix;
const
ScalarSize: TMatrixSize = (FRows: 1; FCols: 1);
begin
Result.Alloc(ScalarSize);
Move(X, Result.Data[0], SizeOf(TASR));
end;
class operator TRealMatrix.Negative(const A: TRealMatrix): TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := -A.Data[i];
end;
class operator TRealMatrix.Add(const A, B: TRealMatrix): TRealMatrix;
var
i: Integer;
begin
if A.Size <> B.Size then
raise EMathException.Create('Cannot add two matrices of different sizes.');
Result := TRealMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] + B.Data[i];
end;
class operator TRealMatrix.Add(const A: TRealMatrix; const X: TASR): TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] + X;
end;
class operator TRealMatrix.Subtract(const A, B: TRealMatrix): TRealMatrix;
var
i: Integer;
begin
if A.Size <> B.Size then
raise EMathException.Create('Cannot subtract two matrices of different sizes.');
Result := TRealMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] - B.Data[i];
end;
class operator TRealMatrix.Subtract(const A: TRealMatrix; const X: TASR): TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] - X;
end;
class operator TRealMatrix.Multiply(const A, B: TRealMatrix): TRealMatrix;
var
i: Integer;
j: Integer;
k: Integer;
row1, row2: PASR;
begin
if A.Size.Cols <> B.Size.Rows then
raise EMathException.Create('When multiplying two matrices, the number of columns in the first matrix has to equal the number of rows in the second matrix.');
Result := TRealMatrix.CreateUninitialized(TMatrixSize.Create(A.Size.Rows, B.Size.Cols));
if (A.Size.ElementCount > 100000) and Assigned(GTYieldProc) then
begin
for i := 0 to Result.Size.Rows - 1 do
begin
row1 := Result.RowData[i];
row2 := A.RowData[i];
for j := 0 to Result.Size.Cols - 1 do
begin
row1[j] := 0;
for k := 0 to A.Size.Cols - 1 do
row1[j] := row1[j] + row2[k] * B[k, j];
if Assigned(GTYieldProc) then
GTYieldProc;
end;
end;
end
else
begin
for i := 0 to Result.Size.Rows - 1 do
begin
row1 := Result.RowData[i];
row2 := A.RowData[i];
for j := 0 to Result.Size.Cols - 1 do
begin
row1[j] := 0;
for k := 0 to A.Size.Cols - 1 do
row1[j] := row1[j] + row2[k] * B[k, j];
end;
end;
end;
end;
class operator TRealMatrix.Multiply(const X: TASR; const A: TRealMatrix): TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] * X;
end;
class operator TRealMatrix.Multiply(const A: TRealMatrix; const X: TASR): TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] * X;
end;
class operator TRealMatrix.Divide(const A: TRealMatrix; const X: TASR): TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] / X;
end;
class operator TRealMatrix.Equal(const A, B: TRealMatrix): Boolean;
begin
Result := (A.Size = B.Size) and (TRealVector(A.Data) = TRealVector(B.Data));
end;
class operator TRealMatrix.NotEqual(const A, B: TRealMatrix): Boolean;
begin
Result := not (A = B);
end;
class operator TRealMatrix.Trunc(const A: TRealMatrix): TRealMatrix;
begin
Result := A.Apply(function(const X: TASR): TASR begin Result := System.Trunc(X) end);
end;
class operator TRealMatrix.Round(const A: TRealMatrix): TRealMatrix;
begin
Result := A.Apply(function(const X: TASR): TASR begin Result := System.Round(X) end);
end;
class operator TRealMatrix.LessThan(const A, B: TRealMatrix): Boolean;
begin
Result := (B - A).IsPositive;
end;
class operator TRealMatrix.LessThanOrEqual(const A, B: TRealMatrix): Boolean;
begin
Result := (B - A).IsNonNegative;
end;
class operator TRealMatrix.GreaterThan(const A, B: TRealMatrix): Boolean;
begin
Result := (A - B).IsPositive;
end;
class operator TRealMatrix.GreaterThanOrEqual(const A, B: TRealMatrix): Boolean;
begin
Result := (A - B).IsNonNegative;
end;
function TRealMatrix.IsRow: Boolean;
begin
Result := Size.Rows = 1;
end;
function TRealMatrix.IsColumn: Boolean;
begin
Result := Size.Cols = 1;
end;
function TRealMatrix.IsSquare: Boolean;
begin
Result := Size.Rows = Size.Cols;
end;
function TRealMatrix.IsIdentity(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
if not IsSquare then Exit(False);
for i := 0 to Size.ElementCount - 1 do
if not SameValue(FElements[i], IversonBracket(i mod (Size.Cols + 1) = 0), Epsilon) then
Exit(False);
Result := True;
end;
function TRealMatrix.IsZeroMatrix(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
for i := 0 to Size.ElementCount - 1 do
if not IsZero(FElements[i], Epsilon) then
Exit(False);
Result := True;
end;
function TRealMatrix.IsDiagonal(const Epsilon: Extended): Boolean;
var
x, y: Integer;
row: PASR;
begin
for y := 0 to Size.Rows - 1 do
begin
row := RowData[y];
for x := 0 to Size.Cols - 1 do
if (y <> x) and not IsZero(row[x], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TRealMatrix.IsAntiDiagonal(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
row: PASR;
begin
if not IsSquare then Exit(False);
for y := 0 to Size.Rows - 1 do
begin
row := RowData[y];
for x := 0 to Size.Cols - 1 do
if (x <> Size.Cols - 1 - y) and not IsZero(row[x], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TRealMatrix.IsReversal(const Epsilon: Extended): Boolean;
var
x: TASR;
begin
Result := IsAntiDiagonal(Epsilon);
if Result then
for x in Antidiagonal.Data do
if not SameValue(x, 1, Epsilon) then
Exit(False);
end;
function TRealMatrix.IsUpperTriangular(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
row: PASR;
begin
for y := 1 to Size.Rows - 1 do
begin
row := RowData[y];
for x := 0 to Min(y, Size.Cols) - 1 do
if not IsZero(row[x], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TRealMatrix.IsLowerTriangular(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
row: PASR;
begin
for y := 0 to Size.Rows - 1 do
begin
row := RowData[y];
for x := y + 1 to Size.Cols - 1 do
if not IsZero(row[x], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TRealMatrix.IsTriangular(const Epsilon: Extended): Boolean;
begin
Result := IsUpperTriangular(Epsilon) or IsLowerTriangular(Epsilon);
end;
function TRealMatrix.PivotPos(ARow: Integer; const Epsilon: Extended): Integer;
var
x: Integer;
row: PASR;
begin
row := SafeRowData[ARow];
for x := 0 to Size.Cols - 1 do
if not IsZero(row[x], Epsilon) then
Exit(x);
Result := -1;
end;
function TRealMatrix.IsZeroRow(ARow: Integer; const Epsilon: Extended): Boolean;
begin
Result := PivotPos(ARow, Epsilon) = -1;
end;
function TRealMatrix.kNorm(const k: Integer): TASR;
begin
Result := TRealVector(FElements).kNorm(k);
end;
function TRealMatrix.IsEssentiallyZeroRow(ARow: Integer; const Epsilon: Extended): Boolean;
var
pp: Integer;
begin
pp := PivotPos(ARow, Epsilon);
Result := (pp = -1) or (pp = Size.Cols - 1);
end;
function TRealMatrix.IsRowEchelonForm(const Epsilon: Extended): Boolean;
var
y: Integer;
p, prep: Integer;
begin
prep := -1;
for y := Size.Rows - 1 downto 0 do
begin
p := PivotPos(y, Epsilon);
if (prep > -1) and ((p = -1) or (p >= prep)) then
Exit(False);
prep := p;
end;
Result := True;
end;
function TRealMatrix.IsReducedRowEchelonForm(const Epsilon: Extended): Boolean;
var
y: Integer;
p, prep: Integer;
yp: Integer;
begin
prep := -1;
for y := Size.Rows - 1 downto 0 do
begin
p := PivotPos(y, Epsilon);
if (prep > -1) and ((p = -1) or (p >= prep)) then
Exit(False);
if p > -1 then
begin
if not SameValue(Self[y, p], 1, Epsilon) then
Exit(False);
for yp := y - 1 downto 0 do
if not IsZero(Self[yp, p], Epsilon) then
Exit(False);
end;
prep := p;
end;
Result := True;
end;
function TRealMatrix.IsScalar(const Epsilon: Extended): Boolean;
var
val: TASR;
i: Integer;
begin
Result := IsSquare and IsDiagonal(Epsilon);
if not Result then
Exit;
if Size.ElementCount = 0 then
Exit(True);
val := FElements[0];
for i := 1 to Size.Rows - 1 do
if not SameValue(Self[i, i], val, Epsilon) then
Exit(False);
end;
function TRealMatrix.IsSymmetric(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self, Transpose, Epsilon);
end;
function TRealMatrix.IsSkewSymmetric(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self, -Transpose, Epsilon);
end;
function TRealMatrix.IsOrthogonal(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and (Self.Transpose * Self).IsIdentity(Epsilon);
end;
function TRealMatrix.IsNormal(const Epsilon: Extended): Boolean;
begin
Result := CommutesWith(Transpose, Epsilon);
end;
function TRealMatrix.IsBinary(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
for i := 0 to Size.ElementCount - 1 do
if not (SameValue(FElements[i], 0, Epsilon) or SameValue(FElements[i], 1, Epsilon)) then
Exit(False);
Result := True;
end;
function TRealMatrix.IsPermutation(const Epsilon: Extended): Boolean;
var
y, x: Integer;
c: Integer;
begin
Result := IsSquare and IsBinary(Epsilon);
if not Result then
Exit;
for y := 0 to Size.Rows - 1 do
begin
c := 0;
for x := 0 to Size.Cols - 1 do
if SameValue(Self[y, x], 1, Epsilon) then
Inc(c);
if c <> 1 then
Exit(False);
end;
for x := 0 to Size.Cols - 1 do
begin
c := 0;
for y := 0 to Size.Rows - 1 do
if SameValue(Self[y, x], 1, Epsilon) then
Inc(c);
if c <> 1 then
Exit(False);
end;
end;
function TRealMatrix.IsCirculant(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
row0, row: PASR;
begin
row0 := RowData[0];
for y := 1 to Size.Rows - 1 do
begin
row := RowData[y];
for x := 0 to Size.Cols - 1 do
if not SameValue(row0[x], row[(x + y) mod Size.Cols], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TRealMatrix.IsToeplitz(const Epsilon: Extended): Boolean;
var
r1, c1: TRealVector;
y: Integer;
x: Integer;
function virtarr(index: Integer): TASR;
begin
if index <= 0 then
Result := r1[-index]
else
Result := c1[index];
end;
begin
r1 := Self.Rows[0];
c1 := Self.Cols[0];
for y := 1 to Size.Rows - 1 do
for x := 1 to Size.Cols - 1 do
if not SameValue(Self[y, x], virtarr(y - x), Epsilon) then
Exit(False);
Result := True;
end;
function TRealMatrix.IsHankel(const Epsilon: Extended): Boolean;
var
r1, cl: TRealVector;
y: Integer;
x: Integer;
function virtarr(index: Integer): TASR;
begin
if index >= Self.Size.Cols then
Result := cl[index - Self.Size.Cols + 1]
else
Result := r1[index];
end;
begin
r1 := Rows[0];
cl := Cols[Size.Cols - 1];
for y := 1 to Size.Rows - 1 do
for x := 0 to Size.Cols - 2 do
if not SameValue(Self[y, x], virtarr(x + y), Epsilon) then
Exit(False);
Result := True;
end;
function TRealMatrix.IsUpperHessenberg(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
begin
for y := 2 to Size.Rows - 1 do
for x := 0 to Min(y - 2, Size.Cols - 1) do
if not IsZero(Self[y, x], Epsilon) then
Exit(False);
Result := True;
end;
function TRealMatrix.IsLowerHessenberg(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
begin
for x := 2 to Size.Cols - 1 do
for y := 0 to Min(x - 2, Size.Rows - 1) do
if not IsZero(Self[y, x], Epsilon) then
Exit(False);
Result := True;
end;
function TRealMatrix.IsTridiagonal(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and IsUpperHessenberg(Epsilon) and IsLowerHessenberg(Epsilon);
end;
function TRealMatrix.IsUpperBidiagonal(const Epsilon: Extended): Boolean;
begin
Result := IsTridiagonal(Epsilon) and Subdiagonal.IsZeroVector(Epsilon);
end;
function TRealMatrix.IsLowerBidiagonal(const Epsilon: Extended): Boolean;
begin
Result := IsTridiagonal(Epsilon) and Superdiagonal.IsZeroVector(Epsilon);
end;
function TRealMatrix.IsBidiagonal(const Epsilon: Extended): Boolean;
begin
Result := IsTridiagonal(Epsilon) and
(Subdiagonal.IsZeroVector(Epsilon) or Superdiagonal.IsZeroVector(Epsilon));
end;
function TRealMatrix.IsCentrosymmetric(const Epsilon: Extended): Boolean;
var
i, j: Integer;
begin
Result := IsSquare;
if not Result then
Exit;
for i := 0 to Size.Rows - 1 do
for j := 0 to Size.Rows - 1 do
if not SameValue(Self[i, j], Self[Size.Rows - 1 - i, Size.Rows - 1 - j], Epsilon) then
Exit(False);
Result := True;
end;
function TRealMatrix.IsVandermonde(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
begin
for y := 0 to Size.Rows - 1 do
begin
if not SameValue(Self[y, 0], 1, Epsilon) then
Exit(False);
for x := 2 to Size.Cols - 1 do
if not SameValue(Self[y, x], IntPower(Self[y, 1], x), Epsilon) then
Exit(False);
end;
Result := True;
end;
function TRealMatrix.CommutesWith(const A: TRealMatrix; const Epsilon: Extended): Boolean;
begin
Result := SameMatrixEx(Self * A, A * Self, Epsilon);
end;
function TRealMatrix.IsIdempotent(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self, Self * Self, Epsilon);
end;
function TRealMatrix.IsInvolution(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self * Self, IdentityMatrix(Size.Rows), Epsilon);
end;
function TRealMatrix.IsPositiveDefinite(const Epsilon: Extended): Boolean;
begin
Result := IsSymmetric(Epsilon) and eigenvalues.RealPart.IsPositive;
end;
function TRealMatrix.IsPositiveSemiDefinite(const Epsilon: Extended): Boolean;
begin
Result := IsSymmetric(Epsilon) and eigenvalues.RealPart.IsNonNegative;
end;
function TRealMatrix.IsNegativeDefinite(const Epsilon: Extended): Boolean;
begin
Result := IsSymmetric(Epsilon) and (-eigenvalues).RealPart.IsPositive;
end;
function TRealMatrix.IsNegativeSemiDefinite(const Epsilon: Extended): Boolean;
begin
Result := IsSymmetric(Epsilon) and (-eigenvalues).RealPart.IsNonNegative;
end;
function TRealMatrix.IsIndefinite(const Epsilon: Extended): Boolean;
begin
Result := IsSymmetric(Epsilon) and not (IsPositiveSemiDefinite or IsNegativeSemiDefinite);
end;
function TRealMatrix.IsNilpotent(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and (NilpotencyIndex(Epsilon) >= 0);
end;
function TRealMatrix.NilpotencyIndex(const Epsilon: Extended): Integer;
var
i: Integer;
A: TRealMatrix;
begin
if not IsSquare then
raise EMathException.Create('Cannot find nilpotency index of non-square matrix.');
if not IsZero(Trace, Epsilon) then
Exit(-1);
A := Self;
for i := 1 to Size.Rows do
if A.IsZeroMatrix(Epsilon) then
Exit(i)
else if i < Size.Rows then
A := A * Self;
Exit(-1);
end;
function TRealMatrix.IsDiagonallyDominant: Boolean;
var
y: Integer;
d, r: TASR;
begin
if not IsSquare then
Exit(False);
for y := 0 to Size.Rows - 1 do
begin
d := System.Abs(Self[y, y]);
r := DeletedAbsoluteRowSum(y);
if (d < r) and not SameValue(d, r) then
Exit(False);
end;
Result := True;
end;
function TRealMatrix.IsStrictlyDiagonallyDominant: Boolean;
var
y: Integer;
d, r: TASR;
begin
if not IsSquare then
Exit(False);
for y := 0 to Size.Rows - 1 do
begin
d := System.Abs(Self[y, y]);
r := DeletedAbsoluteRowSum(y);
if (d < r) or SameValue(d, r) then
Exit(False);
end;
Result := True;
end;
function TRealMatrix.IsPositive(const Epsilon: Extended): Boolean;
begin
Result := TRealVector(Data).IsPositive(Epsilon)
end;
function TRealMatrix.IsNonNegative(const Epsilon: Extended): Boolean;
begin
Result := TRealVector(Data).IsNonNegative(Epsilon)
end;
function TRealMatrix.IsNegative(const Epsilon: Extended): Boolean;
begin
Result := TRealVector(Data).IsNegative(Epsilon)
end;
function TRealMatrix.IsNonPositive(const Epsilon: Extended): Boolean;
begin
Result := TRealVector(Data).IsNonPositive(Epsilon)
end;
procedure TRealMatrix.MakeLowerTriangular;
var
i: Integer;
begin
for i := 0 to Size.SmallestDimension - 1 do
if Size.Cols - i > 1 then
FillChar(RowData[i][i + 1], (Size.Cols - i - 1) * SizeOf(TASR), 0);
end;
procedure TRealMatrix.MakeUpperTriangular;
var
i: Integer;
begin
for i := 1 to Size.Rows - 1 do
FillChar(RowData[i][0], Min(i, Size.Cols) * SizeOf(TASR), 0);
end;
procedure TRealMatrix.MakeUpperHessenberg;
var
i: Integer;
begin
for i := 2 to Size.Rows - 1 do
FillChar(RowData[i][0], Min(i - 1, Size.Cols) * SizeOf(TASR), 0);
end;
function TRealMatrix.Sqr: TRealMatrix;
begin
Result := Self * Self;
end;
function TRealMatrix.Transpose: TRealMatrix;
var
y: Integer;
x: Integer;
begin
Result := TRealMatrix.CreateUninitialized(Size.TransposeSize);
for y := 0 to Size.Rows - 1 do
for x := 0 to Size.Cols - 1 do
Result[x, y] := Self[y, x];
end;
function TRealMatrix.HermitianSquare: TRealMatrix;
begin
Result := Transpose * Self;
end;
function TRealMatrix.Modulus: TRealMatrix;
begin
Result := msqrt(HermitianSquare);
end;
function TRealMatrix.Determinant: TASR;
var
A: TRealMatrix;
P: TIndexArray;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute determinant of non-square matrix.');
DoQuickLU(A, P);
Result := product(A.MainDiagonal) * __sign(P);
end;
function TRealMatrix.Trace: TASR;
var
i: Integer;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute trace of non-square matrix.');
Result := 0;
for i := 0 to Size.Rows - 1 do
Result := Result + GetElement(i, i);
end;
procedure TRealMatrix.InplaceGramSchmidt(FirstCol, LastCol: Integer);
var
i, j: Integer;
v, w, c: TRealVector;
begin
if not InRange(FirstCol, 0, Size.Cols - 1) or not InRange(LastCol, FirstCol, Size.Cols - 1) then
raise EMathException.Create('InplaceGramSchmidt: Invalid column indices.');
if FirstCol = LastCol then
Exit;
for i := Succ(FirstCol) to LastCol do
begin
v := Cols[i];
w := v;
for j := FirstCol to i - 1 do
begin
c := Cols[j];
w := w - (v * c) * c;
end;
v := w;
for j := FirstCol to i - 1 do
begin
c := Cols[j];
w := w - (v * c) * c;
end;
w.NormalizeIfNonzero;
Cols[i] := w;
end;
end;
function TRealMatrix.Inverse: TRealMatrix;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute inverse of non-square matrix.');
Result := SysSolve(Self, IdentityMatrix(Size.Rows));
end;
function TRealMatrix.TryInvert(out AInverse: TRealMatrix): Boolean;
begin
Result := TrySysSolve(Self, IdentityMatrix(Size.Rows), AInverse);
end;
function TRealMatrix.Rank: Integer;
begin
Result := Size.Rows - RowEchelonForm.NumTrailingZeroRows;
end;
function TRealMatrix.Nullity: Integer;
begin
Result := Size.Cols - Rank;
end;
function TRealMatrix.ConditionNumber(p: Integer = 2): TASR;
begin
case p of
1:
Result := MaxColSumNorm * Inverse.MaxColSumNorm;
2:
Result := SpectralNorm * Inverse.SpectralNorm;
INFTY:
Result := MaxRowSumNorm * Inverse.MaxRowSumNorm;
else
raise EMathException.CreateFmt('ConditionNumber: Invalid norm: l%d.', [p]);
end;
end;
function TRealMatrix.IsSingular: Boolean;
begin
if not IsSquare then
raise EMathException.Create('IsSingular: Matrix is not square.');
Result := Rank < Size.Rows;
end;
function TRealMatrix.Norm: TASR;
begin
Result := TRealVector(FElements).Norm;
end;
function TRealMatrix.NormSqr: TASR;
begin
Result := TRealVector(FElements).NormSqr;
end;
function TRealMatrix.pNorm(const p: TASR): TASR;
begin
Result := TRealVector(FElements).pNorm(p);
end;
function TRealMatrix.MaxNorm: TASR;
begin
Result := TRealVector(FElements).MaxNorm;
end;
function TRealMatrix.SumNorm: TASR;
begin
Result := TRealVector(FElements).SumNorm;
end;
function TRealMatrix.MaxColSumNorm: TASR;
var
ColSums: TRealVector;
i: Integer;
begin
ColSums.Dimension := Size.Cols;
for i := 0 to Size.Cols - 1 do
ColSums[i] := sum(Cols[i].Abs());
Result := max(ColSums);
end;
function TRealMatrix.MaxRowSumNorm: TASR;
var
RowSums: TRealVector;
i: Integer;
begin
RowSums.Dimension := Size.Rows;
for i := 0 to Size.Rows - 1 do
RowSums[i] := sum(Rows[i].Abs());
Result := max(RowSums);
end;
function TRealMatrix.SpectralNorm: TASR;
begin
Result := SingularValues[0];
end;
function TRealMatrix.DeletedAbsoluteRowSum(ARow: Integer): TASR;
var
j, i: Integer;
begin
Result := 0;
j := ARow * Size.Cols;
for i := j to j + Size.Cols - 1 do
Result := Result + System.Abs(FElements[i]);
if ARow < Size.Cols then
Result := Result - System.Abs(FElements[j + ARow]);
end;
function TRealMatrix.RowSwap(ARow1: Integer; ARow2: Integer): TRealMatrix;
var
i: Integer;
offset1, offset2: Integer;
begin
offset1 := Size.Cols * ARow1;
offset2 := Size.Cols * ARow2;
for i := 0 to Size.Cols - 1 do
TSwapper<TASR>.Swap(FElements[offset1 + i], FElements[offset2 + i]);
Result := Self;
if _FCollectRowOpData then AddRowOpRecord(roSwap, ARow1, ARow2);
end;
function TRealMatrix.RowScale(ARow: Integer; AFactor: TASR): TRealMatrix;
var
i: Integer;
Row: PASR;
begin
Row := RowData[ARow];
for i := 0 to Size.Cols - 1 do
Row[i] := AFactor * Row[i];
Result := Self;
if _FCollectRowOpData then AddRowOpRecord(roScale, ARow, ARow, AFactor);
end;
function TRealMatrix.RowAddMul(ATarget: Integer; ASource: Integer; AFactor: TASR;
ADefuzz: Boolean = False; AFirstCol: Integer = 0): TRealMatrix;
var
i: Integer;
TargetRow, SourceRow: PASR;
begin
TargetRow := RowData[ATarget];
SourceRow := RowData[ASource];
for i := AFirstCol to Size.Cols - 1 do
TargetRow[i] := TargetRow[i] + AFactor * SourceRow[i];
Result := Self;
if _FCollectRowOpData then AddRowOpRecord(roAddMul, ATarget, ASource, AFactor);
if ADefuzz then
for i := AFirstCol to Size.Cols - 1 do
if IsZero(TargetRow[i]) then
TargetRow[i] := 0;
end;
function TRealMatrix.RowOp(const ARowOp: TRealRowOperationRecord): TRealMatrix;
begin
case ARowOp.RowOperationType of
roSwap:
Result := Self.RowSwap(ARowOp.Row1, ARowOp.Row2);
roScale:
Result := Self.RowScale(ARowOp.Row1, ARowOp.Factor);
roAddMul:
Result := Self.RowAddMul(ARowOp.Row1, ARowOp.Row2, ARowOp.Factor);
end;
end;
function TRealMatrix.RowEchelonForm(CollectRowOps: Boolean): TRealMatrix;
var
top: Integer;
x: Integer;
y, maxy: Integer;
maxval: TASR;
pivot: TASR;
begin
Result := Clone;
if CollectRowOps then
Result.BeginCollectRowOpData;
for top := 0 to Size.Rows - 2 do
begin
x := 0;
while x < Size.Cols do
begin
maxy := top;
maxval := System.Abs(Result[top, x]);
for y := top + 1 to Size.Rows - 1 do
if System.Abs(Result[y, x]) > maxval then
begin
maxy := y;
maxval := System.Abs(Result[y, x]);
end;
if IsZero(maxval) then
begin
Inc(x);
Continue;
end;
if maxy <> top then Result.RowSwap(top, maxy);
pivot := Result[top, x];
for y := top + 1 to Size.Rows - 1 do
if not IsZero(Result[y, x]) then
Result.RowAddMul(y, top, - Result[y, x] / pivot, True);
Break;
end;
end;
end;
function TRealMatrix.ReducedRowEchelonForm(CollectRowOps: Boolean): TRealMatrix;
var
y, p: Integer;
pivot: TASR;
yp: Integer;
begin
Result := RowEchelonForm(CollectRowOps);
for y := Result.Size.Rows - 1 downto 0 do
begin
p := Result.PivotPos(y);
if p = -1 then Continue;
pivot := Result[y, p];
if pivot <> 1 then
Result.RowScale(y, 1/pivot);
for yp := y - 1 downto 0 do
if not IsZero(Result[yp, p]) then
Result.RowAddMul(yp, y, -Result[yp, p], True);
end;
end;
function TRealMatrix.NumZeroRows(const AEpsilon: TASR): Integer;
var
i: Integer;
begin
Result := 0;
for i := 0 to Size.Rows - 1 do
if IsZeroRow(i, AEpsilon) then
Inc(Result);
end;
function TRealMatrix.NumTrailingZeroRows(const AEpsilon: TASR): Integer;
var
i: Integer;
begin
Result := 0;
for i := Size.Rows - 1 downto 0 do
if IsZeroRow(i, AEpsilon) then
Inc(Result)
else
Break;
end;
function TRealMatrix.GramSchmidt: TRealMatrix;
var
i: Integer;
v, w, c: TRealVector;
j: Integer;
cols: array of TRealVector;
begin
SetLength(cols, Size.Cols);
for i := 0 to Size.Cols - 1 do
cols[i] := Self.Cols[i];
for i := 0 to Size.Cols - 1 do
begin
v := cols[i];
w := v;
for j := 0 to i - 1 do
begin
c := cols[j];
w := w - (v * c) * c;
end;
v := w;
for j := 0 to i - 1 do
begin
c := cols[j];
w := w - (v * c) * c;
end;
w.NormalizeIfNonzero;
cols[i] := w;
end;
Result := TRealMatrix.CreateFromColumns(cols);
end;
function TRealMatrix.ColumnSpaceBasis: TRealMatrix;
var
A: TRealMatrix;
pivots: array of Integer;
i: Integer;
begin
A := RowEchelonForm;
SetLength(pivots, Size.Rows);
for i := 0 to High(pivots) do
pivots[i] := A.PivotPos(i);
Result := _EmptyMatrix;
for i := 0 to High(pivots) do
if pivots[i] <> -1 then
Result := Result.Augment(Cols[pivots[i]])
end;
function TRealMatrix.ColumnSpaceProjection(const AVector: TRealVector): TRealVector;
var
Basis: TRealMatrix;
Coords: TRealVector;
BasisT: TRealMatrix;
begin
if Size.Cols = 0 then
Exit(ZeroVector(AVector.Dimension));
Basis := ColumnSpaceBasis;
BasisT := Basis.Transpose;
Coords := SysSolve((BasisT * Basis).Augment(BasisT * AVector));
Result := TRealVector((Basis * Coords).Data);
end;
function TRealMatrix.DistanceFromColumnSpace(const AVector: TRealVector): TASR;
begin
if Size.Cols = 0 then
Exit(AVector.Norm);
Result := (AVector - ColumnSpaceProjection(AVector)).Norm;
end;
function TRealMatrix.SimilarHessenberg(A2x2Bulge: Boolean = False): TRealMatrix;
var
k: Integer;
col: TRealVector;
tau: TASR;
gamma: TASR;
uk: TRealVector;
Ident, Q: TRealMatrix;
begin
if not IsSquare then
raise EMathException.Create('Cannot find similar Hessenberg matrix of non-square matrix.');
Ident := IdentityMatrix(Size.Rows);
Result := Clone;
for k := 0 to Size.Rows - 2 - 1 do
begin
col.Dimension := Size.Rows - k - 1;
MatMoveColToVect(Result, k, k + 1, Size.Rows - 1, col);
GetHouseholderMap(col, tau, gamma, uk);
if IsZero(gamma) then
Q := Ident
else
Q := DirectSum(IdentityMatrix(k + 1), IdentityMatrix(col.Dimension) - TRealMatrix.Create(gamma * uk, uk));
Result := Q * Result * Q;
DoYield;
end;
end;
function TRealMatrix.UnsortedEigenvalues: TComplexVector;
var
A, Q: TRealMatrix;
FirstCol, u: TRealVector;
tau, gamma: TASR;
n, e: Integer;
i: Integer;
c: Integer;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute eigenvalues of non-square matrix.');
if IsEmpty then
Exit(TComplexVector.Create([]));
if Size = Mat1x1 then
Exit(TComplexVector.Create([Self[0, 0]]));
if Size = Mat2x2 then
Exit(Eigenvalues2x2);
n := Size.Rows;
e := n - 1;
if n > 500 then
raise Exception.Create('Matrix too big.');
A := SimilarHessenberg(False);
c := 0;
while True do
begin
for i := 0 to e - 1 do
if IsZero(A[i + 1, i]) then
Exit(VectConcat(
A.LeadingPrincipalSubmatrix(i + 1).UnsortedEigenvalues,
A.Submatrix(CreateIntSequence(i + 1, e)).UnsortedEigenvalues
));
FirstCol := ZeroVector(Size.Rows);
FirstCol[0] := ((A[0, 0] - A[e-1, e-1]) * (A[0, 0] - A[e, e]) - A[e, e-1] * A[e-1, e]) / A[1, 0] + A[0, 1];
FirstCol[1] := A[0, 0] + A[1, 1] - A[e-1, e-1] - A[e, e];
FirstCol[2] := A[2, 1];
GetHouseholderMap(FirstCol, tau, gamma, u);
if IsZero(gamma) then
Q := IdentityMatrix(n)
else
Q := IdentityMatrix(n) - TRealMatrix.Create(gamma * u, u);
A := (Q * A * Q).SimilarHessenberg(True);
Inc(c);
if c > 100 then
Break;
DoYield;
end;
raise EMathException.Create('Couldn''t compute eigenvalues.');
end;
function TRealMatrix.spectrum: TComplexVector;
begin
Result := eigenvalues;
end;
function TRealMatrix.eigenvectors(out AEigenvalues: TRealVector;
out AEigenvectors: TRealMatrix; ASkipVerify: Boolean = False): Boolean;
const
LIMIT = 10000;
var
A, Q, R: TRealMatrix;
i, j, k: Integer;
lambda: TASR;
E: TArray<TRealVector>;
EigenspaceFirstIndex,
EigenspaceLastIndex: Integer;
EV: TComplexVector;
begin
if IsDiagonal then
begin
AEigenvalues := MainDiagonal;
AEigenvectors := IdentityMatrix(Size.Rows);
Exit(True);
end;
Result := False;
if IsSymmetric then
begin
A := Self;
AEigenvectors := IdentityMatrix(Size.Rows);
i := 0;
repeat
A.QR(Q, R);
A := R * Q;
AEigenvectors := AEigenvectors * Q;
Inc(i);
DoYield;
until A.IsUpperTriangular or (i = LIMIT);
AEigenvalues := A.MainDiagonal.Defuzz;
Result := (i < LIMIT) or A.IsUpperTriangular(1E-6);
end;
if not Result then
begin
try
EV := eigenvalues;
if EV.IsReal then
AEigenvalues := EV.RealPart
else
Exit(False);
SetLength(E, AEigenvalues.Dimension);
for i := 0 to High(E) do
E[i] := EigenvectorOf(AEigenvalues[i]);
AEigenvectors := TRealMatrix.CreateFromColumns(E);
Result := True;
except
Result := False;
end;
end;
if Result then
begin
if IsSymmetric then
begin
lambda := 0;
EigenspaceFirstIndex := 0;
for i := 0 to AEigenvalues.Dimension do
begin
if (i = AEigenvalues.Dimension) or (i > 0) and not SameValue(AEigenvalues[i], lambda) then
begin
EigenspaceLastIndex := Pred(i);
if EigenspaceLastIndex > EigenspaceFirstIndex then
AEigenvectors.InplaceGramSchmidt(EigenspaceFirstIndex, EigenspaceLastIndex);
EigenspaceFirstIndex := i;
end;
if i < AEigenvalues.Dimension then
lambda := AEigenvalues[i];
end;
end;
for i := 0 to AEigenvectors.Size.Cols - 1 do
begin
for j := 0 to AEigenvectors.Size.Rows - 1 do
if AEigenvectors[j, i] > 0 then
Break
else if AEigenvectors[j, i] < 0 then
begin
for k := 0 to AEigenvectors.Size.Rows - 1 do
AEigenvectors[k, i] := -AEigenvectors[k, i];
Break;
end;
end;
end;
if Result and not ASkipVerify then
begin
if AEigenvectors.IsSingular then
Exit(False);
for i := 0 to Size.Cols - 1 do
if not IsEigenpair(AEigenvalues[i], AEigenvectors.Cols[i], 1E-6) then
Exit(False);
end;
end;
function TRealMatrix.IsEigenvector(const u: TRealVector; const Epsilon: Extended = 0): Boolean;
var
im: TRealVector;
begin
if not IsSquare then
raise EMathException.Create('Non-square matrix cannot have eigenvectors.');
if u.Dimension <> Size.Cols then
raise EMathException.Create('Vector is of wrong dimension.');
if u.IsZeroVector(Epsilon) then Exit(False);
im := TRealVector((Self * u).Data);
Result := AreParallel(u, im, Epsilon);
end;
function TRealMatrix.EigenvalueOf(const u: TRealVector; const Epsilon: Extended = 0): TASR;
begin
if not TryEigenvalueOf(u, Result, Epsilon) then
raise EMathException.Create('A vector which isn''t an eigenvector has no associated eigenvalue.');
end;
function TRealMatrix.TryEigenvalueOf(const u: TRealVector; out AEigenvalue: TASR;
const Epsilon: Extended = 0): Boolean;
var
i: Integer;
im: TRealVector;
begin
if not IsEigenvector(u, Epsilon) then
Exit(False);
Result := True;
im := TRealVector((Self * u).Data);
if im.IsZeroVector(Epsilon) then
begin
AEigenvalue := 0;
Exit;
end;
for i := 0 to u.Dimension - 1 do
if not IsZero(u[i], Epsilon) and not IsZero(im[i], Epsilon) then
begin
AEigenvalue := im[i] / u[i];
Exit;
end;
raise EMathException.Create('Couldn''t compute associated eigenvalue of given eigenvector.');
end;
function TRealMatrix.IsEigenpair(const lambda: TASR; const u: TRealVector;
const Epsilon: Extended): Boolean;
begin
if not IsSquare then
raise EMathException.Create('Non-square matrix cannot have eigenvectors.');
if u.Dimension <> Size.Cols then
raise EMathException.Create('Vector is of wrong dimension.');
Result := SameVectorEx(TRealVector((Self * u).Data), lambda * u, Epsilon) and not u.IsZeroVector(Epsilon);
end;
function TRealMatrix.EigenvectorOf(const lambda: TASR): TRealVector;
var
pertlambda: TASR;
A: TRealMatrix;
i: Integer;
j: Integer;
Done: Boolean;
u: TRealVector;
begin
if not IsSquare then
raise EMathException.Create('EigenvectorOf: The matrix isn''t square.');
pertlambda := lambda;
i := 0;
while not (Self - pertlambda * IdentityMatrix(Size.Rows)).TryInvert(A) do
begin
if i = 100 then
raise EMathException.Create('EigenvectorOf: Couldn''t invert matrix for inverse iteration.');
Inc(i);
pertlambda := lambda + 10*i * System.Abs(lambda) * ExtendedResolution * (2*Random - 1);
end;
for i := 1 to 10 do
begin
Result := RandomVector(Size.Rows);
j := 0;
repeat
Result := TRealVector(A * Result).Normalized;
Done := IsEigenpair(lambda, Result);
Inc(j)
until Done or (j > 10);
if Done then
begin
u := TRealVector(A * TRealVector(Result)).Normalized;
u := TRealVector(A * TRealVector(u)).Normalized;
u := TRealVector(A * TRealVector(u)).Normalized;
if Result.Norm > 0.001 then
begin
for j := 0 to Result.Dimension - 1 do
if System.Abs(u[j]) < 1E-18 then
u[j] := 0
end
else
for j := 0 to Result.Dimension - 1 do
if System.Abs(u[j]) < 1E-50 then
u[j] := 0;
if IsEigenpair(lambda, u) then
Result := u;
for j := 0 to Result.Dimension - 1 do
if Result[j] > 0 then
Break
else if Result[j] < 0 then
begin
Result := -Result;
Break;
end;
Exit;
end;
end;
raise EMathException.Create('EigenvectorOf: Couldn''t compute associated eigenvector.');
end;
function TRealMatrix.SpectralRadius: TASR;
begin
Result := max(spectrum.Abs());
end;
function TRealMatrix.SingularValues: TRealVector;
begin
Result := HermitianSquare
.eigenvalues
.RealPart
.ReverseSort
.TruncateAt(Size.SmallestDimension)
.Apply(sqrt);
end;
function TRealMatrix.Abs: TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(Size);
for i := 0 to Size.ElementCount - 1 do
Result.Data[i] := System.Abs(FElements[i]);
end;
function TRealMatrix.Defuzz(const Eps: Double): TRealMatrix;
begin
Result := Self;
TRealVector(FElements).Defuzz(Eps);
end;
function TRealMatrix.Clone: TRealMatrix;
begin
Result := TRealMatrix.CreateUninitialized(Size);
if Length(FElements) > 0 then
Move(FElements[0], Result.FElements[0], Length(FElements) * SizeOf(TASR));
end;
function TRealMatrix.Vectorization: TRealVector;
begin
Result := TRealVector(Transpose.Data);
end;
function TRealMatrix.AsVector: TRealVector;
begin
Result := TRealVector.Create(Data);
end;
function TRealMatrix.Augment(const A: TRealMatrix): TRealMatrix;
var
y: Integer;
x: Integer;
begin
if IsEmpty then
Exit(A.Clone);
if Size.Rows <> A.Size.Rows then
raise EMathException.Create('Cannot augment matrix with different number of rows.');
Result := TRealMatrix.CreateUninitialized(TMatrixSize.Create(Size.Rows, Size.Cols + A.Size.Cols));
for y := 0 to Size.Rows - 1 do
for x := 0 to Size.Cols - 1 do
Result.Elements[y, x] := Self[y, x];
for y := 0 to Size.Rows - 1 do
for x := 0 to A.Size.Cols - 1 do
Result.Elements[y, Size.Cols + x] := A[y, x];
end;
function TRealMatrix.Augment: TRealMatrix;
begin
Result := Augment(ZeroVector(Size.Rows));
end;
function TRealMatrix.GetRow(ARow: Integer): TRealVector;
begin
if not InRange(ARow, 0, Size.Rows - 1) then
raise EMathException.Create('The specified row does not exist.');
Result.Dimension := Size.Cols;
Move(FElements[ARow * Result.Dimension], Result.Data[0], Result.Dimension * SizeOf(TASR));
end;
function TRealMatrix.GetCol(ACol: Integer): TRealVector;
var
i: Integer;
begin
if not InRange(ACol, 0, Size.Cols - 1) then
raise EMathException.Create('The specified column does not exist.');
Result.Dimension := Size.Rows;
for i := 0 to Result.Dimension - 1 do
Result[i] := Self[i, ACol];
end;
procedure TRealMatrix._DoSetRow(ARowIndex: Integer; const ARow: TRealVector);
var
i: Integer;
j: Integer;
begin
if Length(ARow.Data) <> Size.Cols then
raise EMathException.Create('Incorrect length of array.');
if not InRange(ARowIndex, 0, Size.Rows - 1) then
raise EMathException.Create('The specified row does not exist.');
j := Length(ARow.Data) * ARowIndex;
for i := 0 to Length(ARow.Data) - 1 do
FElements[j + i] := ARow[i];
end;
procedure TRealMatrix.SetRow(ARowIndex: Integer; const ARow: array of TASR);
var
dummy: TASRArray;
begin
SetLength(dummy, Length(ARow));
if Length(ARow) > 0 then
Move(ARow[0], dummy[0], Length(ARow) * SizeOf(TASR));
_DoSetRow(ARowIndex, TRealVector(dummy));
end;
procedure TRealMatrix._DoSetCol(AColIndex: Integer; const ACol: TRealVector);
var
i: Integer;
begin
if Length(ACol.Data) <> Size.Rows then
raise EMathException.Create('Incorrect length of array.');
if not InRange(AColIndex, 0, Size.Cols - 1) then
raise EMathException.Create('The specified column does not exist.');
for i := 0 to Length(ACol.Data) - 1 do
Self[i, AColIndex] := ACol[i];
end;
function TRealMatrix.GetFirstCol: TRealVector;
begin
Result := Cols[0];
end;
procedure TRealMatrix.SetFirstCol(const ACol: TRealVector);
begin
Cols[0] := ACol;
end;
function TRealMatrix.GetLastCol: TRealVector;
begin
Result := Cols[Size.Cols - 1];
end;
procedure TRealMatrix.SetLastCol(const ACol: TRealVector);
begin
Cols[Size.Cols - 1] := ACol;
end;
procedure TRealMatrix.SetCol(AColIndex: Integer; const ACol: array of TASR);
var
dummy: TASRArray;
begin
SetLength(dummy, Length(ACol));
if Length(ACol) > 0 then
Move(ACol[0], dummy[0], Length(ACol) * SizeOf(TASR));
_DoSetCol(AColIndex, TRealVector(dummy));
end;
function TRealMatrix.GetMainDiagonal: TRealVector;
var
i: Integer;
q: Integer;
begin
q := Size.SmallestDimension;
Result.Dimension := q;
for i := 0 to q - 1 do
Result[i] := Self[i, i];
end;
procedure TRealMatrix.SetMainDiagonal(const ADiagonal: TRealVector);
var
i: Integer;
q: Integer;
begin
q := Size.SmallestDimension;
if ADiagonal.Dimension <> q then
raise EMathException.Create('Incorrect number of elements in diagonal.');
for i := 0 to q - 1 do
Self[i, i] := ADiagonal[i];
end;
function TRealMatrix.GetSuperDiagonal: TRealVector;
var
i: Integer;
q: Integer;
begin
if Size.Cols > Size.Rows then
q := Size.Rows
else
q := Size.Cols - 1;
Result.Dimension := q;
for i := 0 to Result.Dimension - 1 do
Result[i] := Self[i, i + 1];
end;
procedure TRealMatrix.SetSuperDiagonal(const ADiagonal: TRealVector);
var
i: Integer;
q: Integer;
begin
if Size.Cols > Size.Rows then
q := Size.Rows
else
q := Size.Cols - 1;
if ADiagonal.Dimension <> q then
raise EMathException.Create('Incorrect number of elements in superdiagonal.');
for i := 0 to ADiagonal.Dimension - 1 do
Self[i, i + 1] := ADiagonal[i];
end;
function TRealMatrix.GetSubDiagonal: TRealVector;
var
i: Integer;
q: Integer;
begin
if Size.Rows > Size.Cols then
q := Size.Cols
else
q := Size.Rows - 1;
Result.Dimension := q;
for i := 0 to Result.Dimension - 1 do
Result[i] := Self[i + 1, i];
end;
procedure TRealMatrix.SetSubDiagonal(const ADiagonal: TRealVector);
var
i: Integer;
q: Integer;
begin
if Size.Rows > Size.Cols then
q := Size.Cols
else
q := Size.Rows - 1;
if ADiagonal.Dimension <> q then
raise EMathException.Create('Incorrect number of elements in subdiagonal.');
for i := 0 to ADiagonal.Dimension - 1 do
Self[i + 1, i] := ADiagonal[i];
end;
procedure TRealMatrix.SetSize(const Value: TMatrixSize);
begin
FElements := nil;
Alloc(Value);
end;
function TRealMatrix.GetAntiDiagonal: TRealVector;
var
i: Integer;
begin
if not IsSquare then
raise EMathException.Create('A non-square matrix has no antidiagonal.');
Result.Dimension := Size.Rows;
for i := 0 to Size.Rows - 1 do
Result[i] := Self[i, Size.Cols - 1 - i];
end;
procedure TRealMatrix.SetAntiDiagonal(const ADiagonal: TRealVector);
var
i: Integer;
begin
if not IsSquare then
raise EMathException.Create('A non-square matrix has no antidiagonal.');
if ADiagonal.Dimension <> Size.Rows then
raise EMathException.Create('Incorrect number of elements in antidiagonal.');
for i := 0 to Size.Rows - 1 do
Self[i, Size.Cols - 1 - i] := ADiagonal[i];
end;
function TRealMatrix.Submatrix(ARowToRemove: Integer; AColToRemove: Integer;
AAllowEmpty: Boolean): TRealMatrix;
var
y: Integer;
x: Integer;
resy, resx: Integer;
begin
if not (InRange(ARowToRemove, 0, Size.Rows - 1) and InRange(AColToRemove, 0, Size.Cols - 1)) then
raise EMathException.Create('Invalid row or column index in call to function Submatrix.');
if AAllowEmpty and (IsRow or IsColumn) then
Exit(_EmptyMatrix);
Result := TRealMatrix.CreateUninitialized(TMatrixSize.Create(Size.Rows - 1, Size.Cols - 1));
resy := 0;
for y := 0 to Size.Rows - 1 do
begin
if y = ARowToRemove then
Continue;
resx := 0;
for x := 0 to Size.Cols - 1 do
begin
if x = AColToRemove then
Continue;
Result.Elements[resy, resx] := Self[y, x];
Inc(resx);
end;
Inc(resy);
end;
end;
function TRealMatrix.Submatrix(const ARows: array of Integer;
const ACols: array of Integer): TRealMatrix;
procedure InvalidArg;
begin
raise EMathException.Create('Invalid index arrays passed to function Submatrix.');
end;
var
i: Integer;
y, x: Integer;
begin
for i := 0 to High(ARows) do
if not InRange(ARows[i], 0, Size.Rows - 1) then
InvalidArg;
for i := 0 to High(ACols) do
if not InRange(ACols[i], 0, Size.Cols - 1) then
InvalidArg;
Result := TRealMatrix.CreateUninitialized(TMatrixSize.Create(Length(ARows), Length(ACols)));
for y := 0 to Result.Size.Rows - 1 do
for x := 0 to Result.Size.Cols - 1 do
Result[y, x] := Self[ARows[y], ACols[x]];
end;
function TRealMatrix.Submatrix(const ARows: array of Integer): TRealMatrix;
begin
Result := Submatrix(ARows, ARows);
end;
function TRealMatrix.LeadingPrincipalSubmatrix(const ASize: Integer): TRealMatrix;
begin
Result := Submatrix(CreateIntSequence(0, ASize - 1));
end;
function TRealMatrix.Lessened: TRealMatrix;
var
y: Integer;
x: Integer;
begin
if Size.Cols = 1 then
raise EMathException.Create('Cannot lessen a single-column matrix.');
Result := TRealMatrix.CreateUninitialized(Size.LessenedSize);
for y := 0 to Result.Size.Rows - 1 do
for x := 0 to Result.Size.Cols - 1 do
Result[y, x] := Self[y, x];
end;
function TRealMatrix.Minor(ARow: Integer; ACol: Integer): TASR;
begin
Result := Submatrix(ARow, ACol).Determinant;
end;
function TRealMatrix.Cofactor(ARow: Integer; ACol: Integer): TASR;
begin
Result := AltSgn(ARow + ACol) * Minor(ARow, ACol);
end;
function TRealMatrix.CofactorMatrix: TRealMatrix;
var
y: Integer;
x: Integer;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute cofactor matrix of non-square matrix.');
Result := TRealMatrix.CreateUninitialized(Size);
for y := 0 to Size.Rows - 1 do
for x := 0 to Size.Cols - 1 do
begin
Result[y, x] := Cofactor(y, x);
DoYield;
end;
end;
function TRealMatrix.AdjugateMatrix: TRealMatrix;
begin
Result := CofactorMatrix.Transpose;
end;
procedure TRealMatrix.LU(out P, L, U: TRealMatrix);
function RowPermutationMatrix(n, i, j: Integer): TRealMatrix;
begin
Result := IdentityMatrix(n);
Result[i, i] := 0;
Result[j, j] := 0;
Result[i, j] := 1;
Result[j, i] := 1;
end;
var
A: TRealMatrix;
Pvect: TIndexArray;
i: Integer;
begin
DoQuickLU(A, Pvect);
L := A.Clone;
L.MakeLowerTriangular;
L.MainDiagonal := TRealVector.Create(L.Size.Rows, 1);
U := A.Clone;
U.MakeUpperTriangular;
P := IdentityMatrix(Size.Rows);
for i := 0 to High(Pvect) do
if Pvect[i] <> -1 then
P := RowPermutationMatrix(Size.Rows, i, Pvect[i]) * P;
end;
function TRealMatrix.Cholesky(out R: TRealMatrix): Boolean;
var
i, j, k: Integer;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute Cholesky decomposition of non-square matrix.');
R := Clone;
for i := 0 to Size.Rows - 1 do
begin
for k := 0 to i - 1 do
R[i, i] := R[i, i] - R[k, i] * R[k, i];
if (R[i, i] < 0) or IsZero(R[i, i]) then
Exit(False);
R[i, i] := sqrt(R[i, i]);
for j := i + 1 to Size.Rows - 1 do
begin
for k := 0 to i - 1 do
R[i, j] := R[i, j] - R[k, i] * R[k, j];
R[i, j] := R[i, j] / R[i, i];
end;
DoYield;
end;
R.MakeUpperTriangular;
Result := True;
end;
procedure TRealMatrix.GetHouseholderMap(const AVect: TRealVector;
out tau, gamma: TASR; out u: TRealVector);
var
beta: TASR;
begin
beta := max(AVect.Abs());
if IsZero(beta) then
begin
tau := 0;
gamma := 0;
u := ZeroVector(AVect.Dimension);
end
else
begin
u := AVect / beta;
tau := u.Norm;
if u[0] < 0 then
tau := -tau;
u[0] := u[0] + tau;
gamma := u[0] / tau;
u := u / u[0];
u[0] := 1;
tau := tau * beta;
end;
end;
procedure TRealMatrix.QR(out Q: TRealMatrix; out R: TRealMatrix);
var
k: Integer;
col: TRealVector;
tau: TASR;
gamma: TASR;
u: TRealVector;
Qk: TRealMatrix;
begin
if Size.Cols > Size.Rows then
raise EMathException.Create('QR decomposition only implemented for square and tall matrices.');
R := Clone;
Q := IdentityMatrix(R.Size.Rows);
for k := 0 to Min(Size.Rows - 2, Size.Cols - 1) do
begin
col.Dimension := Size.Rows - k;
MatMoveColToVect(R, k, k, Size.Rows - 1, col);
GetHouseholderMap(col, tau, gamma, u);
if IsZero(gamma) then
Qk := IdentityMatrix(col.Dimension)
else
Qk := IdentityMatrix(col.Dimension) - TRealMatrix.Create(gamma * u, u);
MatMulBlockInplaceL(R,
Rect(
k,
k,
Min(k + Qk.Size.Cols, R.Size.Cols) - 1,
Min(k + Qk.Size.Rows, R.Size.Rows) - 1
),
Qk);
R[k, k] := -tau;
MatMulBottomRight(Q, Qk);
DoYield;
end;
R.MakeUpperTriangular;
end;
procedure TRealMatrix.Hessenberg(out A, U: TRealMatrix);
var
k: Integer;
col: TRealVector;
tau: TASR;
gamma: TASR;
uk: TRealVector;
Ident, Q: TRealMatrix;
begin
if not IsSquare then
raise EMathException.Create('Cannot find similar Hessenberg matrix of non-square matrix.');
Ident := IdentityMatrix(Size.Rows);
A := Clone;
U := IdentityMatrix(Size.Rows);
for k := 0 to Size.Rows - 2 - 1 do
begin
col.Dimension := Size.Rows - k - 1;
MatMoveColToVect(A, k, k + 1, Size.Rows - 1, col);
GetHouseholderMap(col, tau, gamma, uk);
if IsZero(gamma) then
Q := Ident
else
Q := DirectSum(IdentityMatrix(k + 1), IdentityMatrix(col.Dimension) - TRealMatrix.Create(gamma * uk, uk));
A := Q * A * Q;
U := U * Q;
end;
end;
function TRealMatrix.Apply(AFunction: TRealFunctionRef): TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(Size);
for i := 0 to Result.Size.ElementCount - 1 do
Result.Data[i] := AFunction(FElements[i]);
end;
function TRealMatrix.Replace(APredicate: TPredicate<TASR>; const ANewValue: TASR): TRealMatrix;
begin
Result := TRealMatrix.CreateUninitialized(Size);
Result.Data := TASRArray(TRealVector(Self.Data).Replace(APredicate, ANewValue));
end;
function TRealMatrix.Replace(const AOldValue, ANewValue: TASR; const Epsilon: Extended): TRealMatrix;
begin
Result := TRealMatrix.CreateUninitialized(Size);
Result.Data := TASRArray(TRealVector(Self.Data).Replace(AOldValue, ANewValue, Epsilon));
end;
function TRealMatrix.Replace(const ANewValue: TASR): TRealMatrix;
begin
Result := TRealMatrix.Create(Size, ANewValue);
end;
procedure TRealMatrix.RequireNonEmpty;
begin
if IsEmpty then
raise Exception.Create('Matrix is empty.');
end;
function TRealMatrix.str(const AOptions: TFormatOptions): string;
var
y: Integer;
x: Integer;
begin
Result := '(';
for y := 0 to Size.Rows - 1 do
begin
Result := Result + '(';
for x := 0 to Size.Cols - 1 do
begin
Result := Result + RealToStr(Elements[y, x], AOptions);
if x < Size.Cols - 1 then
Result := Result + ', '
end;
Result := Result + ')';
if y < Size.Rows - 1 then
Result := Result + ', '
end;
Result := Result + ')';
end;
procedure TRealMatrix.AddRow(const ARow: array of TASR);
var
i, j: Integer;
begin
if Length(ARow) <> Size.Cols then
raise EMathException.Create('Cannot add row to matrix since the number of columns doesn''t match.');
Alloc(Size.Rows + 1, Size.Cols);
j := Size.Cols * (Size.Rows - 1);
for i := 0 to Length(ARow) - 1 do
begin
FElements[j] := ARow[i];
Inc(j);
end;
end;
function TRealMatrix.Sort(AComparer: IComparer<TASR>): TRealMatrix;
begin
TRealVector(FElements).Sort(AComparer);
Result := Self;
end;
function TRealMatrix.eigenvalues: TComplexVector;
begin
Result := UnsortedEigenvalues.Sort(TASCComparer.ModulusArgumentDescending);
end;
function TRealMatrix.Shuffle: TRealMatrix;
begin
TRealVector(FElements).Shuffle;
Result := Self;
end;
function TRealMatrix.Reverse: TRealMatrix;
begin
Result := Self;
TRealVector(FElements).Reverse;
end;
function mpow(const A: TRealMatrix; const N: Integer): TRealMatrix;
var
i: Integer;
begin
if not A.IsSquare then
raise EMathException.Create('Cannot compute power of non-square matrix.');
if N < 0 then
Exit(mpow(A.Inverse, -N));
Result := IdentityMatrix(A.Size.Rows);
for i := 1 to N do
Result := Result * A;
end;
function msqrt(const A: TRealMatrix): TRealMatrix;
var
T: TRealMatrix;
u: TRealVector;
begin
if not A.IsPositiveSemiDefinite then
raise EMathException.Create('Matrix square root only defined for positive semidefinite symmetric matrices.');
if not A.eigenvectors(u, T, True) then
raise EMathException.Create('msqrt: Couldn''t diagonalize the matrix.');
T := T.GramSchmidt;
Result := T * diag(u.Apply(sqrt).Data) * T.Transpose;
if not SameMatrixEx(Result.Sqr, A, 1E-8) then
raise EMathException.Create('Couldn''t compute matrix square root.');
end;
function SameMatrix(const A, B: TRealMatrix; const Epsilon: Extended): Boolean;
begin
Result := (A.Size = B.Size) and SameVector(TRealVector(A.Data), TRealVector(B.Data), Epsilon);
end;
function SameMatrixEx(const A, B: TRealMatrix; const Epsilon: Extended): Boolean;
begin
Result := (A.Size = B.Size) and SameVectorEx(TRealVector(A.Data), TRealVector(B.Data), Epsilon);
end;
function ZeroMatrix(const ASize: TMatrixSize): TRealMatrix; inline;
begin
Result := TRealMatrix.Create(ASize, 0);
end;
function IdentityMatrix(ASize: Integer): TRealMatrix;
begin
if ASize = 0 then Exit(_EmptyMatrix);
Result := TRealMatrix.CreateDiagonal(ASize, 1);
end;
function ReversalMatrix(ASize: Integer): TRealMatrix;
begin
Result := TRealMatrix.Create(TMatrixSize.Create(ASize), 0);
Result.AntiDiagonal := TRealVector.Create(ASize, 1);
end;
function RandomMatrix(const ASize: TMatrixSize): TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(ASize);
for i := 0 to Result.Size.ElementCount - 1 do
Result.Data[i] := Random;
end;
function RandomIntMatrix(const ASize: TMatrixSize; a, b: Integer): TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(ASize);
for i := 0 to Result.Size.ElementCount - 1 do
Result.Data[i] := RandomRange(a, b);
end;
function diag(const AElements: array of TASR): TRealMatrix;
begin
Result := TRealMatrix.CreateDiagonal(AElements);
end;
function diag(const AElements: TRealVector): TRealMatrix;
begin
Result := TRealMatrix.CreateDiagonal(AElements);
end;
function OuterProduct(const u, v: TRealVector): TRealMatrix; inline;
begin
Result := TRealMatrix.Create(u, v);
end;
function CirculantMatrix(const AElements: array of TASR): TRealMatrix;
var
y: Integer;
x: Integer;
row: PASR;
begin
Result := TRealMatrix.CreateUninitialized(Length(AElements));
for y := 0 to Result.Size.Rows - 1 do
begin
row := Result.RowData[y];
for x := 0 to Result.Size.Cols - 1 do
row[x] := AElements[(Length(AElements) + x - y) mod Result.Size.Cols];
end;
end;
function ToeplitzMatrix(const AFirstRow, AFirstCol: array of TASR): TRealMatrix;
function virtarr(index: Integer): TASR;
begin
if index <= 0 then
Result := AFirstRow[-index]
else
Result := AFirstCol[index];
end;
var
y: Integer;
x: Integer;
begin
if (Length(AFirstRow) = 0) or (Length(AFirstCol) = 0) then
raise EMathException.Create('The given vectors must be of dimension one or greater.');
if not SameValueEx(AFirstRow[0], AFirstCol[0]) then
raise EMathException.Create('The first element of the first row must equal the first element of the first column.');
Result := TRealMatrix.CreateUninitialized(TMatrixSize.Create(Length(AFirstCol), Length(AFirstRow)));
for y := 0 to Result.Size.Rows - 1 do
for x := 0 to Result.Size.Cols - 1 do
Result[y, x] := virtarr(y - x);
end;
function HankelMatrix(const AFirstRow, ALastCol: array of TASR): TRealMatrix;
function virtarr(index: Integer): TASR;
begin
if index >= Length(AFirstRow) then
Result := ALastCol[index - Length(AFirstRow) + 1]
else
Result := AFirstRow[index];
end;
var
y: Integer;
x: Integer;
begin
if (Length(AFirstRow) = 0) or (Length(ALastCol) = 0) then
raise EMathException.Create('The specified vectors must be of dimension one or greater.');
if not SameValueEx(AFirstRow[High(AFirstRow)], ALastCol[0]) then
raise EMathException.Create('The last element of the first row must equal the first element of the last column.');
Result := TRealMatrix.CreateUninitialized(TMatrixSize.Create(Length(ALastCol), Length(AFirstRow)));
for y := 0 to Result.Size.Rows - 1 do
for x := 0 to Result.Size.Cols - 1 do
Result[y, x] := virtarr(y + x);
end;
function BackwardShiftMatrix(ASize: Integer): TRealMatrix;
begin
Result := TRealMatrix.Create(TMatrixSize.Create(ASize), 0);
Result.Superdiagonal := TRealVector.Create(ASize - 1, 1);
end;
function ForwardShiftMatrix(ASize: Integer): TRealMatrix;
begin
Result := TRealMatrix.Create(TMatrixSize.Create(ASize), 0);
Result.Subdiagonal := TRealVector.Create(ASize - 1, 1);
end;
function VandermondeMatrix(const AElements: array of TASR; ACols: Integer): TRealMatrix;
var
y: Integer;
x: Integer;
row: PASR;
begin
if ACols <= 0 then
ACols := Length(AElements);
Result := TRealMatrix.CreateUninitialized(TMatrixSize.Create(Length(AElements), ACols));
for y := 0 to Result.Size.Rows - 1 do
begin
row := Result.RowData[y];
if ACols >= 1 then
row[0] := 1;
if ACols >= 2 then
row[1] := AElements[y];
for x := 2 to Result.Size.Cols - 1 do
row[x] := IntPower(AElements[y], x);
end;
end;
function HilbertMatrix(const ASize: TMatrixSize): TRealMatrix;
var
y: Integer;
x: Integer;
row: PASR;
begin
Result := TRealMatrix.CreateUninitialized(ASize);
for y := 0 to ASize.Rows - 1 do
begin
row := Result.RowData[y];
for x := 0 to ASize.Cols - 1 do
row[x] := 1 / (y + x + 1);
end;
end;
function RotationMatrix(AAngle: TASR; ADim: Integer = 2; AIndex1: Integer = 0;
AIndex2: Integer = 1): TRealMatrix;
var
i, j: Integer;
s, c: Extended;
begin
i := min(AIndex1, AIndex2);
j := max(AIndex1, AIndex2);
if not InRange(i, 0, ADim - 1) or not InRange(j, 0, ADim - 1) or (i = j) then
raise EMathException.Create('Invalid coordinate indices.');
Result := IdentityMatrix(ADim);
SinCos(AAngle, s, c);
Result[i, i] := c;
Result[j, i] := s;
Result[i, j] := -s;
Result[j, j] := c;
end;
function OrthogonalVector(const u: TRealVector): TRealVector;
var
c: Integer;
i, j: Integer;
NonZeroIndices: array[0..2] of Integer;
MinVal: TASR;
MinIndex: Integer;
begin
if u.Dimension <> 3 then
raise Exception.Create('OrthogonalVector: Only implemented in R^3.');
MinIndex := 0;
MinVal := 0;
c := 0;
for i := 0 to 2 do
if not IsZero(u[i]) then
begin
NonZeroIndices[c] := i;
Inc(c);
if (i = 0) or (Abs(u[i]) < MinVal) then
begin
MinIndex := i;
MinVal := Abs(u[i]);
end;
end;
case c of
0:
Exit(ASR3(1, 0, 0));
1:
Exit(UnitVector(3, (NonZeroIndices[0] + 1) mod 3));
2:
for i := 0 to 2 do
if (i <> NonZeroIndices[0]) and (i <> NonZeroIndices[1]) then
Exit(UnitVector(3, i));
3:
begin
i := (MinIndex - 1 + 3) mod 3;
j := (MinIndex + 1 ) mod 3;
Result.Dimension := 3;
Result[i] := u[j];
Result[MinIndex] := 0.0;
Result[j] := -u[i];
Result.Normalize;
end;
else
raise Exception.Create('ASNum.OrthogonalVector: Internal error.');
end;
end;
function RotationMatrix(AAngle: TASR; AAxis: TRealVector): TRealMatrix; overload;
var
A, T: TRealMatrix;
u, v, w: TRealVector;
begin
if AAxis.Dimension <> 3 then
raise Exception.Create('Axis to rotate about must be given by a three-dimensional vector.');
if AAxis.IsZeroVector then
raise Exception.Create('Cannot rotate about the zero vector.');
u := AAxis.Normalized;
v := OrthogonalVector(u);
w := CrossProduct(u, v);
T := TRealMatrix.CreateFromColumns([u, v, w]);
A := RotationMatrix(AAngle, 3, 1, 2);
Result := T * A * T.Transpose;
end;
function ReflectionMatrix(const u: TRealVector): TRealMatrix;
begin
if u.IsZeroVector then
raise EMathException.Create('Vector cannot be zero.');
Result := IdentityMatrix(u.Dimension) - 2 * OuterProduct(u, u) / u.NormSqr;
end;
function QuickReflectionMatrix(const u: TRealVector): TRealMatrix;
begin
Result := IdentityMatrix(u.Dimension) - 2 * OuterProduct(u, u);
end;
function HadamardProduct(const A, B: TRealMatrix): TRealMatrix;
var
i: Integer;
begin
if A.Size <> B.Size then
raise EMathException.Create('Hadamard product only defined for matrices of the same size.');
Result := TRealMatrix.CreateUninitialized(A.Size);
for i := 0 to Result.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] * B.Data[i];
end;
function DirectSum(const A, B: TRealMatrix): TRealMatrix;
begin
Result := DirectSum([A, B]);
end;
function DirectSum(const Blocks: array of TRealMatrix): TRealMatrix; overload;
var
i: Integer;
cols, rows: Integer;
x, y: Integer;
begin
cols := 0;
rows := 0;
for i := 0 to High(Blocks) do
begin
Inc(cols, Blocks[i].Size.Cols);
Inc(rows, Blocks[i].Size.Rows);
end;
Result := TRealMatrix.CreateUninitialized(TMatrixSize.CreateUnsafe(rows, cols));
x := 0;
y := 0;
for i := 0 to High(Blocks) do
begin
MatMove(Blocks[i], Result, Point(x, y));
MatBlockFill(Result,
Rect(x + Blocks[i].Size.Cols, y, Result.Size.Cols - 1, y + Blocks[i].Size.Rows - 1),
0);
MatBlockFill(Result,
Rect(x, y + Blocks[i].Size.Rows, x + Blocks[i].Size.Cols - 1, Result.Size.Rows - 1),
0);
Inc(x, Blocks[i].Size.Cols);
Inc(y, Blocks[i].Size.Rows);
end;
end;
function Commute(const A, B: TRealMatrix; const Epsilon: Extended): Boolean;
begin
Result := A.CommutesWith(B, Epsilon);
end;
function accumulate(const A: TRealMatrix; AStart: TASR;
AAccumulator: TAccumulator<TASR>): TASR;
begin
Result := accumulate(TRealVector(A.Data), AStart, AAccumulator);
end;
function sum(const A: TRealMatrix): TASR; inline;
begin
Result := sum(TRealVector(A.Data));
end;
function ArithmeticMean(const A: TRealMatrix): TASR; inline;
begin
Result := ArithmeticMean(TRealVector(A.Data));
end;
function GeometricMean(const A: TRealMatrix): TASR; inline;
begin
Result := GeometricMean(TRealVector(A.Data));
end;
function HarmonicMean(const A: TRealMatrix): TASR; inline;
begin
Result := HarmonicMean(TRealVector(A.Data));
end;
function product(const A: TRealMatrix): TASR; inline;
begin
Result := product(TRealVector(A.Data));
end;
function max(const A: TRealMatrix): TASR; inline;
begin
Result := max(TRealVector(A.Data));
end;
function min(const A: TRealMatrix): TASR; inline;
begin
Result := min(TRealVector(A.Data));
end;
function exists(const A: TRealMatrix; APredicate: TPredicate<TASR>): Boolean;
begin
Result := exists(TRealVector(A.Data), APredicate);
end;
function count(const A: TRealMatrix; APredicate: TPredicate<TASR>): Integer;
begin
Result := count(TRealVector(A.Data), APredicate);
end;
function count(const A: TRealMatrix; const AValue: TASR): Integer; inline;
begin
Result := count(TRealVector(A.Data), AValue);
end;
function ForAll(const A: TRealMatrix; APredicate: TPredicate<TASR>): Boolean;
begin
Result := ForAll(TRealVector(A.Data), APredicate);
end;
function contains(const A: TRealMatrix; AValue: TASR): Boolean; inline;
begin
Result := contains(TRealVector(A.Data), AValue);
end;
function TryForwardSubstitution(const A: TRealMatrix; const Y: TRealVector;
out Solution: TRealVector; IsUnitDiagonal: Boolean = False): Boolean;
var
i: Integer;
row: PASR;
j: Integer;
begin
if not A.IsSquare then
raise EMathException.Create('ForwardSubstitution: Coefficient matrix isn''t square.');
if A.Size.Cols <> Y.Dimension then
raise EMathException.Create('ForwardSubstitution: RHS is of wrong dimension.');
Solution.Dimension := Y.Dimension;
for i := 0 to A.Size.Rows - 1 do
begin
row := A.RowData[i];
Solution[i] := Y[i];
for j := 0 to i - 1 do
Solution[i] := Solution[i] - row[j] * Solution[j];
if not IsUnitDiagonal then
begin
if IsZero(row[i]) then
Exit(False)
else
Solution[i] := Solution[i] / row[i];
end;
end;
Result := True;
end;
function ForwardSubstitution(const A: TRealMatrix; const Y: TRealVector;
IsUnitDiagonal: Boolean = False): TRealVector;
begin
if not TryForwardSubstitution(A, Y, Result, IsUnitDiagonal) then
raise EMathException.Create('ForwardSubstitution: Matrix is singular.')
end;
function TryBackSubstitution(const A: TRealMatrix; const Y: TRealVector;
out Solution: TRealVector): Boolean;
var
i: Integer;
row: PASR;
j: Integer;
begin
if not A.IsSquare then
raise EMathException.Create('BackSubstitution: Coefficient matrix isn''t square.');
if A.Size.Cols <> Y.Dimension then
raise EMathException.Create('BackSubstitution: RHS is of wrong dimension.');
Solution.Dimension := Y.Dimension;
for i := A.Size.Rows - 1 downto 0 do
begin
row := A.RowData[i];
Solution[i] := Y[i];
for j := i + 1 to A.Size.Cols - 1 do
Solution[i] := Solution[i] - row[j] * Solution[j];
if IsZero(row[i]) then
Exit(False)
else
Solution[i] := Solution[i] / row[i];
end;
Result := True;
end;
function BackSubstitution(const A: TRealMatrix; const Y: TRealVector): TRealVector;
begin
if not TryBackSubstitution(A, Y, Result) then
raise EMathException.Create('BackSubstitution: Matrix is singular.')
end;
function TryLUSysSolve(const A: TRealMatrix; const P: TIndexArray;
const Y: TRealVector; out Solution: TRealVector): Boolean; overload;
var
b, c: TRealVector;
i: Integer;
begin
if Y.Dimension <> Length(P) then
raise EMathException.Create('TryLUSysSolve: RHS is of wrong dimension.');
b := Y.Clone;
for i := 0 to High(P) do
if (P[i] <> -1) and (P[i] <> i) then
TSwapper<TASR>.Swap(b.Data[i], b.Data[P[i]]);
Result := TryForwardSubstitution(A, b, c, True) and
TryBackSubstitution(A, c, Solution);
end;
function LUSysSolve(const A: TRealMatrix; const P: TIndexArray;
const Y: TRealVector): TRealVector; overload;
var
b: TRealVector;
i: Integer;
begin
if Y.Dimension <> Length(P) then
raise EMathException.Create('LUSysSolve: RHS is of wrong dimension.');
b := Y.Clone;
for i := 0 to High(P) do
if (P[i] <> -1) and (P[i] <> i) then
TSwapper<TASR>.Swap(b.Data[i], b.Data[P[i]]);
b := ForwardSubstitution(A, b, True);
Result := BackSubstitution(A, b);
end;
function TrySysSolve(const A: TRealMatrix; const Y: TRealVector;
out Solution: TRealVector): Boolean;
var
LU: TRealMatrix;
P: TIndexArray;
begin
A.DoQuickLU(LU, P);
Result := TryLUSysSolve(LU, P, Y, Solution);
end;
function TrySysSolve(const A: TRealMatrix; const Y: TRealMatrix;
out Solution: TRealMatrix): Boolean;
var
LU: TRealMatrix;
P: TIndexArray;
i: Integer;
sol: TRealVector;
begin
A.DoQuickLU(LU, P);
Solution := TRealMatrix.CreateUninitialized(Y.Size);
for i := 0 to Y.Size.Cols - 1 do
if TryLUSysSolve(LU, P, Y.Cols[i], sol) then
Solution.Cols[i] := sol
else
Exit(False);
Result := True;
end;
function SysSolve(const AAugmented: TRealMatrix): TRealVector;
begin
Result := SysSolve(AAugmented.Lessened, AAugmented.LastColumn);
end;
function SysSolve(const A: TRealMatrix; const Y: TRealVector): TRealVector;
var
LU: TRealMatrix;
P: TIndexArray;
begin
if not A.IsSquare then
raise EMathException.Create('Coefficient matrix isn''t square.');
A.DoQuickLU(LU, P);
Result := LUSysSolve(LU, P, Y);
end;
function SysSolve(const A: TRealMatrix; const Y: TRealMatrix): TRealMatrix; overload;
var
LU: TRealMatrix;
P: TIndexArray;
i: Integer;
begin
if not A.IsSquare then
raise EMathException.Create('Coefficient matrix isn''t square.');
A.DoQuickLU(LU, P);
Result := TRealMatrix.CreateUninitialized(Y.Size);
for i := 0 to Y.Size.Cols - 1 do
begin
Result.Cols[i] := LUSysSolve(LU, P, Y.Cols[i]);
DoYield;
end;
end;
function LeastSquaresPolynomialFit(const X, Y: TRealVector; ADegree: Integer): TRealVector;
var
A, At: TRealMatrix;
begin
if X.Dimension <> Y.Dimension then
raise EMathException.Create('LeastSquaresPolynomialFit: X and Y vectors must have the same dimension.');
if ADegree < 0 then
raise EMathException.Create('LeastSquaresPolynomialFit: Polynomial degree must be non-negative.');
A := VandermondeMatrix(X.Data, ADegree + 1);
At := A.Transpose;
Result := SysSolve(At * A, TRealVector(At * Y));
end;
procedure VectMove(const ASource: TRealVector; const AFrom, ATo: Integer;
var ATarget: TRealVector; const ATargetFrom: Integer = 0);
begin
Move(ASource.Data[AFrom], ATarget.Data[ATargetFrom],
(ATo - AFrom + 1) * SizeOf(TASR));
end;
procedure VectMoveToMatCol(const ASource: TRealVector; const AFrom, ATo: Integer;
var ATarget: TRealMatrix; const ATargetCol: Integer;
const ATargetFirstRow: Integer = 0);
var
index: Integer;
i: Integer;
begin
index := ATargetFirstRow * ATarget.Size.Cols + ATargetCol;
for i := AFrom to ATo do
begin
ATarget.Data[index] := ASource[i];
Inc(index, ATarget.Size.Cols);
end;
end;
procedure VectMoveToMatRow(const ASource: TRealVector; const AFrom, ATo: Integer;
var ATarget: TRealMatrix; const ATargetRow: Integer;
const ATargetFirstCol: Integer = 0);
begin
Move(ASource.Data[AFrom], ATarget.RowData[ATargetRow][ATargetFirstCol],
(ATo - AFrom + 1) * SizeOf(TASR));
end;
procedure MatMove(const ASource: TRealMatrix; const ARect: TRect;
var ATarget: TRealMatrix; const ATargetTopLeft: TPoint);
var
y: Integer;
begin
for y := 0 to ARect.Bottom - ARect.Top do
Move(ASource.RowData[ARect.Top + y][ARect.Left],
ATarget.RowData[ATargetTopLeft.Y + y][ATargetTopLeft.X],
(ARect.Right - ARect.Left + 1) * SizeOf(TASR));
end;
procedure MatMove(const ASource: TRealMatrix; var ATarget: TRealMatrix;
const ATargetTopLeft: TPoint); overload;
begin
MatMove(ASource, Rect(0, 0, ASource.Size.Cols - 1, ASource.Size.Rows - 1),
ATarget, ATargetTopLeft);
end;
procedure MatMoveColToVect(const ASource: TRealMatrix; const AColumn: Integer;
const AFrom, ATo: Integer; var ATarget: TRealVector;
const ATargetFrom: Integer = 0);
var
index: Integer;
i: Integer;
begin
index := AColumn + AFrom * ASource.Size.Cols;
for i := ATargetFrom to ATargetFrom + ATo - AFrom do
begin
ATarget.Data[i] := ASource.Data[index];
Inc(index, ASource.Size.Cols);
end;
end;
procedure MatMoveRowToVect(const ASource: TRealMatrix; const ARow: Integer;
const AFrom, ATo: Integer; var ATarget: TRealVector;
const ATargetFrom: Integer = 0);
begin
Move(ASource.RowData[ARow][AFrom], ATarget.Data[ATargetFrom],
(ATo - AFrom + 1) * SizeOf(TASR));
end;
procedure MatMulBlockInplaceL(var ATarget: TRealMatrix; const ARect: TRect;
const AFactor: TRealMatrix);
var
prod: TRealMatrix;
Large: Boolean;
i, j, k: Integer;
row1, row2: PASR;
begin
prod := TRealMatrix.CreateUninitialized(
TMatrixSize.Create(AFactor.Size.Rows, ARect.Right - ARect.Left + 1));
Large := prod.Size.ElementCount > 100000;
for i := 0 to prod.Size.Rows - 1 do
begin
row1 := prod.RowData[i];
row2 := AFactor.RowData[i];
for j := 0 to prod.Size.Cols - 1 do
begin
row1[j] := 0;
for k := 0 to AFactor.Size.Cols - 1 do
row1[j] := row1[j] + row2[k] * ATarget[ARect.Top + k, ARect.Left + j];
end;
if Large then
DoYield;
end;
MatMove(prod, ATarget, ARect.TopLeft);
end;
procedure MatMulBlockInplaceL(var ATarget: TRealMatrix; const ATopLeft: TPoint;
const AFactor: TRealMatrix);
begin
MatMulBlockInplaceL(ATarget,
Rect(ATopLeft.X, ATopLeft.Y,
ATopLeft.X + AFactor.Size.Cols - 1, ATopLeft.Y + AFactor.Size.Rows - 1),
AFactor);
end;
procedure MatMulBottomRight(var ATarget: TRealMatrix; const AFactor: TRealMatrix);
var
prod: TRealMatrix;
n, m, d: Integer;
Large: Boolean;
y, x: Integer;
k: Integer;
row1, row2: PASR;
begin
n := ATarget.Size.Rows;
m := AFactor.Size.Rows;
Large := n * m > 100000;
d := n - m;
prod := TRealMatrix.CreateUninitialized(TMatrixSize.Create(n, m));
for y := 0 to n - 1 do
begin
row1 := prod.RowData[y];
row2 := ATarget.RowData[y];
for x := 0 to m - 1 do
begin
row1[x] := 0;
for k := 0 to m - 1 do
row1[x] := row1[x] + row2[d + k] * AFactor[k, x];
end;
if Large then
DoYield;
end;
MatMove(prod, ATarget, Point(d, 0));
end;
procedure MatBlockFill(var ATarget: TRealMatrix; const ARect: TRect;
const Value: TASR);
var
y: Integer;
row: PASR;
x: Integer;
begin
for y := ARect.Top to ARect.Bottom do
begin
row := ATarget.RowData[y];
for x := ARect.Left to ARect.Right do
row[x] := Value;
end;
end;
const
_EmptyComplexMatrix: TComplexMatrix = (FSize: (FRows: 0; FCols: 0); FElements: nil;
FRowOpSeq: nil; FRowOpCount: 0; FRowOpFactor: (Re: 0; Im: 0); _FCollectRowOpData: False);
constructor TComplexMatrix.CreateUninitialized(const ASize: TMatrixSize);
begin
Alloc(ASize);
end;
constructor TComplexMatrix.Create(const AMatrix: TComplexMatrix);
begin
Alloc(AMatrix.Size);
Move(AMatrix.Data[0], FElements[0], Length(Self.Data) * SizeOf(TASC));
end;
constructor TComplexMatrix.Create(const Elements: array of TASCArray);
var
rc, cc: Integer;
i: Integer;
begin
rc := Length(Elements);
cc := 0;
if rc > 0 then
cc := Length(Elements[0]);
Alloc(rc, cc);
for i := 0 to rc - 1 do
begin
if Length(Elements[i]) <> cc then
raise EMathException.Create('Attempt to create a non-rectangular matrix.');
Move(Elements[i][0], FElements[i*cc], cc*SizeOf(Elements[i][0]));
end;
end;
constructor TComplexMatrix.Create(const Elements: array of TASC; Cols: Integer = 1);
begin
if Cols <= 0 then
raise EMathException.Create('A matrix must have size at least 1×1.');
if Length(Elements) mod Cols <> 0 then
raise EMathException.Create('Attempt to create a non-rectangular matrix.');
Alloc(Length(Elements) div Cols, Cols);
Move(Elements[0], FElements[0], Length(Elements) * SizeOf(Elements[0]));
end;
constructor TComplexMatrix.Create(const ASize: TMatrixSize; const AVal: TASC);
var
i: Integer;
begin
Alloc(ASize);
for i := 0 to FSize.ElementCount - 1 do
FElements[i] := AVal;
end;
constructor TComplexMatrix.CreateFromRows(const Rows: array of TComplexVector);
var
rc, cc: Integer;
i: Integer;
begin
rc := Length(Rows);
cc := 0;
if rc > 0 then
cc := Rows[0].Dimension;
Alloc(rc, cc);
for i := 0 to rc - 1 do
begin
if Rows[i].Dimension <> cc then
raise EMathException.Create('Attempt to create a non-rectangular matrix.');
Move(Rows[i].Data[0], FElements[i*cc], cc*SizeOf(Rows[i][0]));
end;
end;
constructor TComplexMatrix.CreateFromColumns(const Columns: array of TComplexVector);
var
rc, cc: Integer;
i: Integer;
begin
cc := Length(Columns);
rc := 0;
if cc > 0 then
rc := Columns[0].Dimension;
Alloc(rc, cc);
for i := 0 to cc - 1 do
if Columns[i].Dimension <> rc then
raise EMathException.Create('Attempt to create a non-rectangular matrix.');
for i := 0 to FSize.ElementCount - 1 do
FElements[i] := Columns[i mod cc][i div cc];
end;
constructor TComplexMatrix.Create(const u: TComplexVector; const v: TComplexVector);
var
i: Integer;
begin
Alloc(u.Dimension, v.Dimension);
for i := 0 to Size.ElementCount - 1 do
FElements[i] := u[i div Size.Cols] * v[i mod Size.Cols].Conjugate;
end;
constructor TComplexMatrix.Create(const ASize: TMatrixSize; AFunction: TMatrixIndexFunction<TASC>);
var
i: Integer;
begin
Alloc(ASize);
for i := 0 to Size.ElementCount - 1 do
FElements[i] := AFunction(i div Size.Cols + 1, i mod Size.Cols + 1);
end;
constructor TComplexMatrix.CreateDiagonal(const Elements: array of TASC);
var
i: Integer;
begin
Alloc(Length(Elements));
FillChar(FElements[0], Size.ElementCount * SizeOf(FElements[0]), 0);
for i := 0 to Size.Cols - 1 do
FElements[i * (Size.Cols + 1)] := Elements[i];
end;
constructor TComplexMatrix.CreateDiagonal(const Elements: TComplexVector);
begin
CreateDiagonal(Elements.Data);
end;
constructor TComplexMatrix.CreateDiagonal(ASize: Integer; AVal: TASC);
var
i: Integer;
begin
Alloc(ASize);
FillChar(FElements[0], Size.ElementCount * SizeOf(FElements[0]), 0);
for i := 0 to Size.Cols - 1 do
FElements[i * (Size.Cols + 1)] := AVal;
end;
constructor TComplexMatrix.Create(const Blocks: array of TComplexMatrix; Cols: Integer = 2);
var
Rows: Integer;
RowRows, RowTops, ColCols, ColLefts: array of Integer;
i: Integer;
j: Integer;
index: Integer;
begin
if Length(Blocks) = 0 then
raise EMathException.Create('Invalid block matrix construction: the number of blocks has to be at least 1.');
if Cols < 1 then
raise EMathException.Create('Invalid block matrix construction: the number of blocks per row has to be at least 1.');
if Cols > Length(Blocks) then
raise EMathException.Create('Invalid block matrix construction: too few blocks to fill the first row.');
Rows := Length(Blocks) div Cols;
if Length(Blocks) mod Cols <> 0 then
Inc(Rows);
SetLength(RowRows, Rows);
SetLength(RowTops, Rows + 1);
SetLength(ColCols, Cols);
SetLength(ColLefts, Cols + 1);
for i := 0 to Cols - 1 do
ColCols[i] := Blocks[i].Size.Cols;
ColLefts[0] := 0;
for i := 1 to Cols do
ColLefts[i] := ColLefts[i - 1] + ColCols[i - 1];
for i := 0 to Rows - 1 do
RowRows[i] := Blocks[i * Cols].Size.Rows;
RowTops[0] := 0;
for i := 1 to Rows do
RowTops[i] := RowTops[i - 1] + RowRows[i - 1];
index := 0;
for i := 0 to Rows - 1 do
for j := 0 to Cols - 1 do
begin
if index < Length(Blocks) then
with Blocks[index] do
if (Size.Rows <> RowRows[i]) or (Size.Cols <> ColCols[j]) or (Size.ElementCount < 1) then
raise EMathException.CreateFmt('Invalid block matrix construction: invalid block at position (%d, %d), index %d.', [i + 1, j + 1, index + 1]);
Inc(index);
end;
Alloc(RowTops[Rows], ColLefts[Cols]);
index := 0;
for i := 0 to Rows - 1 do
for j := 0 to Cols - 1 do
begin
if index < Length(Blocks) then
MatMove(Blocks[index], Self, Point(ColLefts[j], RowTops[i]))
else
begin
MatBlockFill(Self, Rect(ColLefts[j], RowTops[i], Self.Size.Cols - 1, Self.Size.Rows - 1), 0);
break;
end;
Inc(index);
end;
end;
function TComplexMatrix.GetElement(Row: Integer; Col: Integer): TASC;
begin
Result := FElements[Size.Cols * Row + Col];
end;
procedure TComplexMatrix.SetElement(Row: Integer; Col: Integer; const Value: TASC);
begin
FElements[Size.Cols * Row + Col] := Value;
end;
procedure TComplexMatrix.Alloc(ARows: Integer; ACols: Integer);
begin
FSize.Create(ARows, ACols);
SetLength(FElements, Size.ElementCount);
_FCollectRowOpData := False;
end;
procedure TComplexMatrix.Alloc(ASize: Integer);
begin
FSize.Create(ASize);
SetLength(FElements, Size.ElementCount);
_FCollectRowOpData := False;
end;
procedure TComplexMatrix.Alloc(const ASize: TMatrixSize);
begin
FSize := ASize;
SetLength(FElements, Size.ElementCount);
_FCollectRowOpData := False;
end;
function TComplexMatrix.GetRowData(AIndex: Integer): PASC;
begin
Result := @FElements[Size.Cols * AIndex];
end;
function TComplexMatrix.SafeGetRowData(AIndex: Integer): PASC;
begin
if not InRange(AIndex, 0, Size.Rows - 1) then
raise Exception.Create('The specified row does not exist.');
Result := GetRowData(AIndex);
end;
function TComplexMatrix.SafeSort(AComparer: IComparer<TASC>): TComplexMatrix;
begin
TComplexVector(FElements).SafeSort(AComparer);
Result := Self;
end;
function TComplexMatrix.GetMemorySize: Int64;
begin
Result := SizeOf(Self) + Length(FElements) * SizeOf(TASC) +
Length(FRowOpSeq) * SizeOf(TComplexRowOperationRecord);
end;
function TComplexMatrix.IsEmpty: Boolean;
begin
Result := Size.ElementCount = 0;
end;
procedure TComplexMatrix.BeginCollectRowOpData;
begin
Assert(InitialRowOpSeqSize > 0);
SetLength(FRowOpSeq, InitialRowOpSeqSize);
FRowOpCount := 0;
FRowOpFactor := 1;
_FCollectRowOpData := True;
end;
procedure TComplexMatrix.AddRowOpRecord(AType: TRowOperationType; ARow1,
ARow2: Integer; AFactor: TASC);
begin
Assert(_FCollectRowOpData);
if FRowOpCount = Length(FRowOpSeq) then
SetLength(FRowOpSeq, 2*FRowOpCount);
FRowOpSeq[FRowOpCount].RowOperationType := AType;
FRowOpSeq[FRowOpCount].Row1 := ARow1;
FRowOpSeq[FRowOpCount].Row2 := ARow2;
FRowOpSeq[FRowOpCount].Factor := AFactor;
Inc(FRowOpCount);
case AType of
roSwap:
FRowOpFactor := -FRowOpFactor;
roScale:
FRowOpFactor := FRowOpFactor * AFactor;
roAddMul: ;
end;
end;
function TComplexMatrix.Eigenvalues2x2: TComplexVector;
var
a, b, c, d, ad, bc, avg, avgsq, disc, rt: TASC;
begin
a := Self[0, 0];
b := Self[0, 1];
c := Self[1, 0];
d := Self[1, 1];
ad := a * d;
bc := b * c;
if SameValue2(a, -d) then
avg := 0
else
avg := (a + d) / 2;
avgsq := avg * avg;
if SameValue2(ad, bc) then
disc := avgsq
else
if SameValue2(avgsq, ad - bc) then
disc := 0
else
disc := avgsq - ad + bc;
if disc = 0 then
Exit( avg * ASC2(1, 1) );
rt := csqrt(disc);
Exit( avg * ASC2(1, 1) + rt * ASC2(1, -1) );
end;
procedure TComplexMatrix.DoQuickLU(out A: TComplexMatrix; out P: TIndexArray);
var
y: Integer;
yp: Integer;
maxval, newval: TASR;
maxpos: Integer;
x: Integer;
row1, row2: PASC;
begin
if not IsSquare then
raise EMathException.Create('LU decomposition only implemented for square matrices.');
RequireNonEmpty;
A := Clone;
SetLength(P, Size.Rows);
for y := 0 to Size.Rows - 2 do
begin
row1 := A.RowData[y];
maxpos := A.Size.Rows - 1;
maxval := A[Size.Rows - 1, y].ModSqr;
for yp := A.Size.Rows - 2 downto y do
begin
newval := A[yp, y].ModSqr;
if newval > maxval then
begin
maxval := newval;
maxpos := yp;
end;
end;
if CIsZero(maxval) then
P[y] := -1
else
begin
P[y] := maxpos;
if maxpos <> y then
A.RowSwap(maxpos, y);
for yp := y + 1 to Size.Rows - 1 do
begin
row2 := A.RowData[yp];
row2[y] := row2[y] / row1[y];
for x := y + 1 to Size.Cols - 1 do
row2[x] := row2[x] - row2[y] * row1[x];
end;
end;
DoYield;
end;
if CIsZero(A.Data[A.Size.ElementCount - 1]) then
P[Size.Rows - 1] := -1
else
P[Size.Rows - 1] := Size.Rows - 1;
end;
class operator TComplexMatrix.Implicit(const u: TComplexVector): TComplexMatrix;
begin
if u.Dimension = 0 then
Exit(_EmptyMatrix);
Result.Alloc(TMatrixSize.CreateUnsafe(u.Dimension, 1));
if u.Dimension > 0 then
Move(u.Data[0], Result.Data[0], u.Dimension * SizeOf(TASC));
end;
class operator TComplexMatrix.Implicit(const A: TRealMatrix): TComplexMatrix;
var
i: Integer;
begin
Result.Alloc(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i];
end;
class operator TComplexMatrix.Explicit(const A: TComplexMatrix): TComplexVector;
begin
if A.IsColumn then
Result := TComplexVector(A.Data)
else
raise EMathException.Create('Cannot treat matrix as vector if it isn''t a column vector.');
end;
class operator TComplexMatrix.Explicit(X: TASC): TComplexMatrix;
const
ScalarSize: TMatrixSize = (FRows: 1; FCols: 1);
begin
Result.Alloc(ScalarSize);
Move(X, Result.Data[0], SizeOf(TASC));
end;
class operator TComplexMatrix.Negative(const A: TComplexMatrix): TComplexMatrix;
var
i: Integer;
begin
Result := TComplexMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := -A.Data[i];
end;
class operator TComplexMatrix.Add(const A, B: TComplexMatrix): TComplexMatrix;
var
i: Integer;
begin
if A.Size <> B.Size then
raise EMathException.Create('Cannot add two matrices of different sizes.');
Result := TComplexMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] + B.Data[i];
end;
class operator TComplexMatrix.Add(const A: TComplexMatrix; const X: TASC): TComplexMatrix;
var
i: Integer;
begin
Result := TComplexMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] + X;
end;
class operator TComplexMatrix.Subtract(const A, B: TComplexMatrix): TComplexMatrix;
var
i: Integer;
begin
if A.Size <> B.Size then
raise EMathException.Create('Cannot subtract two matrices of different sizes.');
Result := TComplexMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] - B.Data[i];
end;
class operator TComplexMatrix.Subtract(const A: TComplexMatrix; const X: TASC): TComplexMatrix;
var
i: Integer;
begin
Result := TComplexMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] - X;
end;
class operator TComplexMatrix.Multiply(const A, B: TComplexMatrix): TComplexMatrix;
var
i: Integer;
j: Integer;
k: Integer;
row1, row2: PASC;
begin
if A.Size.Cols <> B.Size.Rows then
raise EMathException.Create('When multiplying two matrices, the number of columns in the first matrix has to equal the number of rows in the second matrix.');
Result := TComplexMatrix.CreateUninitialized(TMatrixSize.Create(A.Size.Rows, B.Size.Cols));
for i := 0 to Result.Size.Rows - 1 do
begin
row1 := Result.RowData[i];
row2 := A.RowData[i];
for j := 0 to Result.Size.Cols - 1 do
begin
row1[j] := 0;
for k := 0 to A.Size.Cols - 1 do
row1[j] := row1[j] + row2[k] * B[k, j];
end;
end;
end;
class operator TComplexMatrix.Multiply(const X: TASC; const A: TComplexMatrix): TComplexMatrix;
var
i: Integer;
begin
Result := TComplexMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] * X;
end;
class operator TComplexMatrix.Multiply(const A: TComplexMatrix; const X: TASC): TComplexMatrix;
var
i: Integer;
begin
Result := TComplexMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] * X;
end;
class operator TComplexMatrix.Divide(const A: TComplexMatrix; const X: TASC): TComplexMatrix;
var
i: Integer;
begin
Result := TComplexMatrix.CreateUninitialized(A.Size);
for i := 0 to A.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] / X;
end;
class operator TComplexMatrix.Equal(const A, B: TComplexMatrix): Boolean;
begin
Result := (A.Size = B.Size) and (TComplexVector(A.Data) = TComplexVector(B.Data));
end;
class operator TComplexMatrix.NotEqual(const A, B: TComplexMatrix): Boolean;
begin
Result := not (A = B);
end;
class operator TComplexMatrix.Trunc(const A: TComplexMatrix): TComplexMatrix;
begin
Result := A.Apply(function(const X: TASC): TASC begin Result := System.Trunc(X) end);
end;
class operator TComplexMatrix.Round(const A: TComplexMatrix): TComplexMatrix;
begin
Result := A.Apply(function(const X: TASC): TASC begin Result := System.Round(X) end);
end;
function TComplexMatrix.IsRow: Boolean;
begin
Result := Size.Rows = 1;
end;
function TComplexMatrix.IsColumn: Boolean;
begin
Result := Size.Cols = 1;
end;
function TComplexMatrix.IsSquare: Boolean;
begin
Result := Size.Rows = Size.Cols;
end;
function TComplexMatrix.IsIdentity(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
if not IsSquare then Exit(False);
for i := 0 to Size.ElementCount - 1 do
if not CSameValue(FElements[i], IversonBracket(i mod (Size.Cols + 1) = 0), Epsilon) then
Exit(False);
Result := True;
end;
function TComplexMatrix.IsZeroMatrix(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
for i := 0 to Size.ElementCount - 1 do
if not CIsZero(FElements[i], Epsilon) then
Exit(False);
Result := True;
end;
function TComplexMatrix.IsDiagonal(const Epsilon: Extended): Boolean;
var
x, y: Integer;
row: PASC;
begin
for y := 0 to Size.Rows - 1 do
begin
row := RowData[y];
for x := 0 to Size.Cols - 1 do
if (y <> x) and not CIsZero(row[x], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TComplexMatrix.IsAntiDiagonal(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
row: PASC;
begin
if not IsSquare then Exit(False);
for y := 0 to Size.Rows - 1 do
begin
row := RowData[y];
for x := 0 to Size.Cols - 1 do
if (x <> Size.Cols - 1 - y) and not CIsZero(row[x], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TComplexMatrix.IsReversal(const Epsilon: Extended): Boolean;
var
x: TASC;
begin
Result := IsAntiDiagonal(Epsilon);
if Result then
for x in Antidiagonal.Data do
if not CSameValue(x, 1, Epsilon) then
Exit(False);
end;
function TComplexMatrix.IsUpperTriangular(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
row: PASC;
begin
for y := 1 to Size.Rows - 1 do
begin
row := RowData[y];
for x := 0 to Min(y, Size.Cols) - 1 do
if not CIsZero(row[x], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TComplexMatrix.IsLowerTriangular(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
row: PASC;
begin
for y := 0 to Size.Rows - 1 do
begin
row := RowData[y];
for x := y + 1 to Size.Cols - 1 do
if not CIsZero(row[x], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TComplexMatrix.IsTriangular(const Epsilon: Extended): Boolean;
begin
Result := IsUpperTriangular(Epsilon) or IsLowerTriangular(Epsilon);
end;
function TComplexMatrix.PivotPos(ARow: Integer; const Epsilon: Extended): Integer;
var
x: Integer;
row: PASC;
begin
row := SafeRowData[ARow];
for x := 0 to Size.Cols - 1 do
if not CIsZero(row[x], Epsilon) then
Exit(x);
Result := -1;
end;
function TComplexMatrix.IsZeroRow(ARow: Integer; const Epsilon: Extended): Boolean;
begin
Result := PivotPos(ARow, Epsilon) = -1;
end;
function TComplexMatrix.kNorm(const k: Integer): TASR;
begin
Result := TComplexVector(FElements).kNorm(k);
end;
function TComplexMatrix.IsEssentiallyZeroRow(ARow: Integer; const Epsilon: Extended): Boolean;
var
pp: Integer;
begin
pp := PivotPos(ARow, Epsilon);
Result := (pp = -1) or (pp = Size.Cols - 1);
end;
function TComplexMatrix.IsRowEchelonForm(const Epsilon: Extended): Boolean;
var
y: Integer;
p, prep: Integer;
begin
prep := -1;
for y := Size.Rows - 1 downto 0 do
begin
p := PivotPos(y, Epsilon);
if (prep > -1) and ((p = -1) or (p >= prep)) then
Exit(False);
prep := p;
end;
Result := True;
end;
function TComplexMatrix.IsReducedRowEchelonForm(const Epsilon: Extended): Boolean;
var
y: Integer;
p, prep: Integer;
yp: Integer;
begin
prep := -1;
for y := Size.Rows - 1 downto 0 do
begin
p := PivotPos(y, Epsilon);
if (prep > -1) and ((p = -1) or (p >= prep)) then
Exit(False);
if p > -1 then
begin
if not CSameValue(Self[y, p], 1, Epsilon) then
Exit(False);
for yp := y - 1 downto 0 do
if not CIsZero(Self[yp, p], Epsilon) then
Exit(False);
end;
prep := p;
end;
Result := True;
end;
function TComplexMatrix.IsScalar(const Epsilon: Extended): Boolean;
var
val: TASC;
i: Integer;
begin
Result := IsSquare and IsDiagonal(Epsilon);
if not Result then
Exit;
if Size.ElementCount = 0 then
Exit(True);
val := FElements[0];
for i := 1 to Size.Rows - 1 do
if not CSameValue(Self[i, i], val, Epsilon) then
Exit(False);
end;
function TComplexMatrix.IsSymmetric(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self, Transpose, Epsilon);
end;
function TComplexMatrix.IsSkewSymmetric(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self, -Transpose, Epsilon);
end;
function TComplexMatrix.IsHermitian(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self, Adjoint, Epsilon);
end;
function TComplexMatrix.IsSkewHermitian(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self, -Adjoint, Epsilon);
end;
function TComplexMatrix.IsOrthogonal(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and (Transpose * Self).IsIdentity(Epsilon);
end;
function TComplexMatrix.IsUnitary(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and (Adjoint * Self).IsIdentity(Epsilon);
end;
function TComplexMatrix.IsNormal(const Epsilon: Extended): Boolean;
begin
Result := CommutesWith(Adjoint, Epsilon);
end;
function TComplexMatrix.IsBinary(const Epsilon: Extended): Boolean;
var
i: Integer;
begin
for i := 0 to Size.ElementCount - 1 do
if not (CSameValue(FElements[i], 0, Epsilon) or CSameValue(FElements[i], 1, Epsilon)) then
Exit(False);
Result := True;
end;
function TComplexMatrix.IsPermutation(const Epsilon: Extended): Boolean;
var
y, x: Integer;
c: Integer;
begin
Result := IsSquare and IsBinary(Epsilon);
if not Result then
Exit;
for y := 0 to Size.Rows - 1 do
begin
c := 0;
for x := 0 to Size.Cols - 1 do
if CSameValue(Self[y, x], 1, Epsilon) then
Inc(c);
if c <> 1 then
Exit(False);
end;
for x := 0 to Size.Cols - 1 do
begin
c := 0;
for y := 0 to Size.Rows - 1 do
if CSameValue(Self[y, x], 1, Epsilon) then
Inc(c);
if c <> 1 then
Exit(False);
end;
end;
function TComplexMatrix.IsCirculant(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
row0, row: PASC;
begin
row0 := RowData[0];
for y := 1 to Size.Rows - 1 do
begin
row := RowData[y];
for x := 0 to Size.Cols - 1 do
if not CSameValue(row0[x], row[(x + y) mod Size.Cols], Epsilon) then
Exit(False);
end;
Result := True;
end;
function TComplexMatrix.IsToeplitz(const Epsilon: Extended): Boolean;
var
r1, c1: TComplexVector;
y: Integer;
x: Integer;
function virtarr(index: Integer): TASC;
begin
if index <= 0 then
Result := r1[-index]
else
Result := c1[index];
end;
begin
r1 := Self.Rows[0];
c1 := Self.Cols[0];
for y := 1 to Size.Rows - 1 do
for x := 1 to Size.Cols - 1 do
if not CSameValue(Self[y, x], virtarr(y - x), Epsilon) then
Exit(False);
Result := True;
end;
function TComplexMatrix.IsHankel(const Epsilon: Extended): Boolean;
var
r1, cl: TComplexVector;
y: Integer;
x: Integer;
function virtarr(index: Integer): TASC;
begin
if index >= Size.Cols then
Result := cl[index - Size.Cols + 1]
else
Result := r1[index];
end;
begin
r1 := Self.Rows[0];
cl := Self.Cols[Self.Size.Cols - 1];
for y := 1 to Size.Rows - 1 do
for x := 0 to Size.Cols - 2 do
if not CSameValue(Self[y, x], virtarr(x + y), Epsilon) then
Exit(False);
Result := True;
end;
function TComplexMatrix.IsUpperHessenberg(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
begin
for y := 2 to Size.Rows - 1 do
for x := 0 to Min(y - 2, Size.Cols - 1) do
if not CIsZero(Self[y, x], Epsilon) then
Exit(False);
Result := True;
end;
function TComplexMatrix.IsLowerHessenberg(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
begin
for x := 2 to Size.Cols - 1 do
for y := 0 to Min(x - 2, Size.Rows - 1) do
if not CIsZero(Self[y, x], Epsilon) then
Exit(False);
Result := True;
end;
function TComplexMatrix.IsTridiagonal(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and IsUpperHessenberg(Epsilon) and IsLowerHessenberg(Epsilon);
end;
function TComplexMatrix.IsUpperBidiagonal(const Epsilon: Extended): Boolean;
begin
Result := IsTridiagonal(Epsilon) and Subdiagonal.IsZeroVector(Epsilon);
end;
function TComplexMatrix.IsLowerBidiagonal(const Epsilon: Extended): Boolean;
begin
Result := IsTridiagonal(Epsilon) and Superdiagonal.IsZeroVector(Epsilon);
end;
function TComplexMatrix.IsBidiagonal(const Epsilon: Extended): Boolean;
begin
Result := IsTridiagonal(Epsilon) and
(Subdiagonal.IsZeroVector(Epsilon) or Superdiagonal.IsZeroVector(Epsilon));
end;
function TComplexMatrix.IsCentrosymmetric(const Epsilon: Extended): Boolean;
var
i, j: Integer;
begin
Result := IsSquare;
if not Result then
Exit;
for i := 0 to Size.Rows - 1 do
for j := 0 to Size.Rows - 1 do
if not CSameValue(Self[i, j], Self[Size.Rows - 1 - i, Size.Rows - 1 - j], Epsilon) then
Exit(False);
Result := True;
end;
function TComplexMatrix.IsVandermonde(const Epsilon: Extended): Boolean;
var
y: Integer;
x: Integer;
begin
for y := 0 to Size.Rows - 1 do
begin
if not CSameValue(Self[y, 0], 1, Epsilon) then
Exit(False);
for x := 2 to Size.Cols - 1 do
if not CSameValue(Self[y, x], cpow(Self[y, 1], x), Epsilon) then
Exit(False);
end;
Result := True;
end;
function TComplexMatrix.CommutesWith(const A: TComplexMatrix; const Epsilon: Extended): Boolean;
begin
Result := SameMatrixEx(Self * A, A * Self, Epsilon);
end;
function TComplexMatrix.IsIdempotent(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self, Self * Self, Epsilon);
end;
function TComplexMatrix.IsInvolution(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and SameMatrixEx(Self * Self, ComplexIdentityMatrix(Size.Rows), Epsilon);
end;
function TComplexMatrix.IsPositiveDefinite(const Epsilon: Extended): Boolean;
begin
Result := IsHermitian(Epsilon) and eigenvalues.RealPart.IsPositive;
end;
function TComplexMatrix.IsPositiveSemiDefinite(const Epsilon: Extended): Boolean;
begin
Result := IsHermitian(Epsilon) and eigenvalues.RealPart.IsNonNegative;
end;
function TComplexMatrix.IsNegativeDefinite(const Epsilon: Extended): Boolean;
begin
Result := IsHermitian(Epsilon) and (-eigenvalues).RealPart.IsPositive;
end;
function TComplexMatrix.IsNegativeSemiDefinite(const Epsilon: Extended): Boolean;
begin
Result := IsHermitian(Epsilon) and (-eigenvalues).RealPart.IsNonNegative;
end;
function TComplexMatrix.IsIndefinite(const Epsilon: Extended): Boolean;
begin
Result := IsHermitian(Epsilon) and not (IsPositiveSemiDefinite or IsNegativeSemiDefinite);
end;
function TComplexMatrix.IsNilpotent(const Epsilon: Extended): Boolean;
begin
Result := IsSquare and (NilpotencyIndex(Epsilon) >= 0);
end;
function TComplexMatrix.NilpotencyIndex(const Epsilon: Extended): Integer;
var
i: Integer;
A: TComplexMatrix;
begin
if not IsSquare then
raise EMathException.Create('Cannot find nilpotency index of non-square matrix.');
if not CIsZero(Trace, Epsilon) then
Exit(-1);
A := Self;
for i := 1 to Size.Rows do
if A.IsZeroMatrix(Epsilon) then
Exit(i)
else if i < Size.Rows then
A := A * Self;
Exit(-1);
end;
function TComplexMatrix.IsDiagonallyDominant: Boolean;
var
y: Integer;
d, r: TASR;
begin
if not IsSquare then
Exit(False);
for y := 0 to Size.Rows - 1 do
begin
d := Self[y, y].Modulus;
r := DeletedAbsoluteRowSum(y);
if (d < r) and not SameValue(d, r) then
Exit(False);
end;
Result := True;
end;
function TComplexMatrix.IsStrictlyDiagonallyDominant: Boolean;
var
y: Integer;
d, r: TASR;
begin
if not IsSquare then
Exit(False);
for y := 0 to Size.Rows - 1 do
begin
d := Self[y, y].Modulus;
r := DeletedAbsoluteRowSum(y);
if (d < r) or SameValue(d, r) then
Exit(False);
end;
Result := True;
end;
function TComplexMatrix.RealPart: TRealMatrix;
begin
Result := TRealMatrix.CreateWithoutAllocation(Size);
Result.Data := TComplexVector(Data).RealPart.Data;
end;
function TComplexMatrix.ImaginaryPart: TRealMatrix;
begin
Result := TRealMatrix.CreateWithoutAllocation(Size);
Result.Data := TComplexVector(Data).ImaginaryPart.Data;
end;
procedure TComplexMatrix.MakeLowerTriangular;
var
i: Integer;
begin
for i := 0 to Size.SmallestDimension - 1 do
if Size.Cols - i > 1 then
FillChar(RowData[i][i + 1], (Size.Cols - i - 1) * SizeOf(TASC), 0);
end;
procedure TComplexMatrix.MakeUpperTriangular;
var
i: Integer;
begin
for i := 1 to Size.Rows - 1 do
FillChar(RowData[i][0], Min(i, Size.Cols) * SizeOf(TASC), 0);
end;
procedure TComplexMatrix.MakeUpperHessenberg;
var
i: Integer;
begin
for i := 2 to Size.Rows - 1 do
FillChar(RowData[i][0], Min(i - 1, Size.Cols) * SizeOf(TASC), 0);
end;
function TComplexMatrix.Sqr: TComplexMatrix;
begin
Result := Self * Self;
end;
function TComplexMatrix.Transpose: TComplexMatrix;
var
y: Integer;
x: Integer;
begin
Result := TComplexMatrix.CreateUninitialized(Size.TransposeSize);
for y := 0 to Size.Rows - 1 do
for x := 0 to Size.Cols - 1 do
Result[x, y] := Self[y, x];
end;
function TComplexMatrix.Adjoint: TComplexMatrix;
var
y: Integer;
x: Integer;
begin
Result := TComplexMatrix.CreateUninitialized(Size.TransposeSize);
for y := 0 to Size.Rows - 1 do
for x := 0 to Size.Cols - 1 do
Result[x, y] := Self[y, x].Conjugate;
end;
function TComplexMatrix.HermitianSquare: TComplexMatrix;
begin
Result := Adjoint * Self;
end;
function TComplexMatrix.Modulus: TComplexMatrix;
begin
Result := msqrt(HermitianSquare);
end;
function TComplexMatrix.Determinant: TASC;
var
A: TComplexMatrix;
P: TIndexArray;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute determinant of non-square matrix.');
DoQuickLU(A, P);
Result := product(A.MainDiagonal) * __sign(P);
end;
function TComplexMatrix.Trace: TASC;
var
i: Integer;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute trace of non-square matrix.');
Result := 0;
for i := 0 to Size.Rows - 1 do
Result := Result + GetElement(i, i);
end;
procedure TComplexMatrix.InplaceGramSchmidt(FirstCol, LastCol: Integer);
var
i, j: Integer;
v, w, c: TComplexVector;
begin
if not InRange(FirstCol, 0, Size.Cols - 1) or not InRange(LastCol, FirstCol, Size.Cols - 1) then
raise EMathException.Create('InplaceGramSchmidt: Invalid column indices.');
if FirstCol = LastCol then
Exit;
for i := Succ(FirstCol) to LastCol do
begin
v := Cols[i];
w := v;
for j := FirstCol to i - 1 do
begin
c := Cols[j];
w := w - (v * c) * c;
end;
v := w;
for j := FirstCol to i - 1 do
begin
c := Cols[j];
w := w - (v * c) * c;
end;
w.NormalizeIfNonzero;
Cols[i] := w;
end;
end;
function TComplexMatrix.Inverse: TComplexMatrix;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute inverse of non-square matrix.');
Result := SysSolve(Self, ComplexIdentityMatrix(Size.Rows));
end;
function TComplexMatrix.TryInvert(out AInverse: TComplexMatrix): Boolean;
begin
Result := TrySysSolve(Self, ComplexIdentityMatrix(Size.Rows), AInverse);
end;
function TComplexMatrix.Rank: Integer;
begin
Result := Size.Rows - RowEchelonForm.NumTrailingZeroRows;
end;
function TComplexMatrix.Nullity: Integer;
begin
Result := Size.Cols - Rank;
end;
function TComplexMatrix.ConditionNumber(p: Integer = 2): TASR;
begin
case p of
1:
Result := MaxColSumNorm * Inverse.MaxColSumNorm;
2:
Result := SpectralNorm * Inverse.SpectralNorm;
INFTY:
Result := MaxRowSumNorm * Inverse.MaxRowSumNorm;
else
raise EMathException.CreateFmt('ConditionNumber: Invalid norm: l%d.', [p]);
end;
end;
function TComplexMatrix.IsSingular: Boolean;
begin
if not IsSquare then
raise EMathException.Create('TComplexMatrix.IsSingular: Matrix is not square.');
Result := Rank < Size.Rows;
end;
function TComplexMatrix.Norm: TASR;
begin
Result := TComplexVector(FElements).Norm;
end;
function TComplexMatrix.NormSqr: TASR;
begin
Result := TComplexVector(FElements).NormSqr;
end;
function TComplexMatrix.pNorm(const p: TASR): TASR;
begin
Result := TComplexVector(FElements).pNorm(p);
end;
function TComplexMatrix.MaxNorm: TASR;
begin
Result := TComplexVector(FElements).MaxNorm;
end;
function TComplexMatrix.SumNorm: TASR;
begin
Result := TComplexVector(FElements).SumNorm;
end;
function TComplexMatrix.MaxColSumNorm: TASR;
var
ColSums: TRealVector;
i: Integer;
begin
ColSums.Dimension := Size.Cols;
for i := 0 to Size.Cols - 1 do
ColSums[i] := sum(Cols[i].Abs());
Result := max(ColSums);
end;
function TComplexMatrix.MaxRowSumNorm: TASR;
var
RowSums: TRealVector;
i: Integer;
begin
RowSums.Dimension := Size.Rows;
for i := 0 to Size.Rows - 1 do
RowSums[i] := sum(Rows[i].Abs());
Result := max(RowSums);
end;
function TComplexMatrix.SpectralNorm: TASR;
begin
Result := SingularValues[0];
end;
function TComplexMatrix.DeletedAbsoluteRowSum(ARow: Integer): TASR;
var
j, i: Integer;
begin
Result := 0;
j := ARow * Size.Cols;
for i := j to j + Size.Cols - 1 do
Result := Result + FElements[i].Modulus;
if ARow < Size.Cols then
Result := Result - FElements[j + ARow].Modulus;
end;
function TComplexMatrix.RowSwap(ARow1: Integer; ARow2: Integer): TComplexMatrix;
var
i: Integer;
offset1, offset2: Integer;
begin
offset1 := Size.Cols * ARow1;
offset2 := Size.Cols * ARow2;
for i := 0 to Size.Cols - 1 do
TSwapper<TASC>.Swap(FElements[offset1 + i], FElements[offset2 + i]);
Result := Self;
if _FCollectRowOpData then AddRowOpRecord(roSwap, ARow1, ARow2, 0);
end;
function TComplexMatrix.RowScale(ARow: Integer; AFactor: TASC): TComplexMatrix;
var
i: Integer;
Row: PASC;
begin
Row := RowData[ARow];
for i := 0 to Size.Cols - 1 do
Row[i] := AFactor * Row[i];
Result := Self;
if _FCollectRowOpData then AddRowOpRecord(roScale, ARow, ARow, AFactor);
end;
function TComplexMatrix.RowAddMul(ATarget: Integer; ASource: Integer; AFactor: TASC;
ADefuzz: Boolean = False; AFirstCol: Integer = 0): TComplexMatrix;
var
i: Integer;
TargetRow, SourceRow: PASC;
begin
TargetRow := RowData[ATarget];
SourceRow := RowData[ASource];
for i := AFirstCol to Size.Cols - 1 do
TargetRow[i] := TargetRow[i] + AFactor * SourceRow[i];
Result := Self;
if _FCollectRowOpData then AddRowOpRecord(roAddMul, ATarget, ASource, AFactor);
if ADefuzz then
for i := AFirstCol to Size.Cols - 1 do
if CIsZero(TargetRow[i]) then
TargetRow[i] := 0;
end;
function TComplexMatrix.RowOp(const ARowOp: TComplexRowOperationRecord): TComplexMatrix;
begin
case ARowOp.RowOperationType of
roSwap:
Result := Self.RowSwap(ARowOp.Row1, ARowOp.Row2);
roScale:
Result := Self.RowScale(ARowOp.Row1, ARowOp.Factor);
roAddMul:
Result := Self.RowAddMul(ARowOp.Row1, ARowOp.Row2, ARowOp.Factor);
end;
end;
function TComplexMatrix.RowEchelonForm(CollectRowOps: Boolean): TComplexMatrix;
var
top: Integer;
x: Integer;
y, maxy: Integer;
maxval: TASR;
pivot: TASC;
begin
Result := Clone;
if CollectRowOps then
Result.BeginCollectRowOpData;
for top := 0 to Size.Rows - 2 do
begin
x := 0;
while x < Size.Cols do
begin
maxy := top;
maxval := Result[top, x].Modulus;
for y := top + 1 to Size.Rows - 1 do
if Result[y, x].Modulus > maxval then
begin
maxy := y;
maxval := Result[y, x].Modulus;
end;
if IsZero(maxval) then
begin
Inc(x);
Continue;
end;
if maxy <> top then Result.RowSwap(top, maxy);
pivot := Result[top, x];
for y := top + 1 to Size.Rows - 1 do
if not CIsZero(Result[y, x]) then
Result.RowAddMul(y, top, - Result[y, x] / pivot, True);
Break;
end;
end;
end;
function TComplexMatrix.ReducedRowEchelonForm(CollectRowOps: Boolean): TComplexMatrix;
var
y, p: Integer;
pivot: TASC;
yp: Integer;
begin
Result := RowEchelonForm(CollectRowOps);
for y := Result.Size.Rows - 1 downto 0 do
begin
p := Result.PivotPos(y);
if p = -1 then Continue;
pivot := Result[y, p];
if pivot <> 1 then
Result.RowScale(y, 1/pivot);
for yp := y - 1 downto 0 do
if not CIsZero(Result[yp, p]) then
Result.RowAddMul(yp, y, -Result[yp, p], True);
end;
end;
function TComplexMatrix.NumZeroRows(const AEpsilon: TASR): Integer;
var
i: Integer;
begin
Result := 0;
for i := 0 to Size.Rows - 1 do
if IsZeroRow(i, AEpsilon) then
Inc(Result);
end;
function TComplexMatrix.NumTrailingZeroRows(const AEpsilon: TASR): Integer;
var
i: Integer;
begin
Result := 0;
for i := Size.Rows - 1 downto 0 do
if IsZeroRow(i, AEpsilon) then
Inc(Result)
else
Break;
end;
function TComplexMatrix.GramSchmidt: TComplexMatrix;
var
i: Integer;
v, w, c: TComplexVector;
j: Integer;
cols: array of TComplexVector;
begin
SetLength(cols, Size.Cols);
for i := 0 to Size.Cols - 1 do
cols[i] := Self.Cols[i];
for i := 0 to Size.Cols - 1 do
begin
v := cols[i];
w := v;
for j := 0 to i - 1 do
begin
c := cols[j];
w := w - (v * c) * c;
end;
v := w;
for j := 0 to i - 1 do
begin
c := cols[j];
w := w - (v * c) * c;
end;
w.NormalizeIfNonzero;
cols[i] := w;
end;
Result := TComplexMatrix.CreateFromColumns(cols);
end;
function TComplexMatrix.ColumnSpaceBasis: TComplexMatrix;
var
A: TComplexMatrix;
pivots: array of Integer;
i: Integer;
begin
A := Self.RowEchelonForm;
SetLength(pivots, Size.Rows);
for i := 0 to High(pivots) do
pivots[i] := A.PivotPos(i);
Result := _EmptyComplexMatrix;
for i := 0 to High(pivots) do
if pivots[i] <> -1 then
Result := Result.Augment(Cols[pivots[i]])
end;
function TComplexMatrix.ColumnSpaceProjection(
const AVector: TComplexVector): TComplexVector;
begin
raise ENotImplemented.Create('Not implemented for complex matrices.');
end;
function TComplexMatrix.DistanceFromColumnSpace(const AVector: TComplexVector): TASR;
begin
raise ENotImplemented.Create('Not implemented for complex matrices.');
end;
function TComplexMatrix.SimilarHessenberg(A2x2Bulge: Boolean = False): TComplexMatrix;
var
k: Integer;
col: TComplexVector;
tau: TASC;
gamma: TASC;
uk: TComplexVector;
Ident, Q: TComplexMatrix;
begin
if not IsSquare then
raise EMathException.Create('Cannot find similar Hessenberg matrix of non-square matrix.');
Ident := ComplexIdentityMatrix(Size.Rows);
Result := Clone;
for k := 0 to Size.Rows - 2 - 1 do
begin
col.Dimension := Size.Rows - k - 1;
MatMoveColToVect(Result, k, k + 1, Size.Rows - 1, col);
GetHouseholderMap(col, tau, gamma, uk);
if CIsZero(gamma) then
Q := Ident
else
Q := DirectSum(ComplexIdentityMatrix(k + 1), ComplexIdentityMatrix(col.Dimension) - TComplexMatrix.Create(gamma * uk, uk));
Result := Q * Result * Q;
DoYield;
end;
end;
function TComplexMatrix.UnsortedEigenvalues: TComplexVector;
var
A, Q: TComplexMatrix;
FirstCol, u: TComplexVector;
tau, gamma: TASC;
n, e: Integer;
i: Integer;
c: Integer;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute eigenvalues of non-square matrix.');
if IsEmpty then
Exit(TComplexVector.Create([]));
if Size = Mat1x1 then
Exit(TComplexVector.Create([Self[0, 0]]));
if Size = Mat2x2 then
Exit(Eigenvalues2x2);
n := Size.Rows;
e := n - 1;
if n > 500 then
raise Exception.Create('Matrix too big.');
A := SimilarHessenberg(False);
c := 0;
while True do
begin
for i := 0 to e - 1 do
if CIsZero(A[i + 1, i]) then
Exit(VectConcat(
A.LeadingPrincipalSubmatrix(i + 1).UnsortedEigenvalues,
A.Submatrix(CreateIntSequence(i + 1, e)).UnsortedEigenvalues
));
FirstCol := ComplexZeroVector(Self.Size.Rows);
FirstCol[0] := ((A[0, 0] - A[e-1, e-1]) * (A[0, 0] - A[e, e]) - A[e, e-1] * A[e-1, e]) / A[1, 0] + A[0, 1];
FirstCol[1] := A[0, 0] + A[1, 1] - A[e-1, e-1] - A[e, e];
FirstCol[2] := A[2, 1];
GetHouseholderMap(FirstCol, tau, gamma, u);
if CIsZero(gamma) then
Q := ComplexIdentityMatrix(n)
else
Q := ComplexIdentityMatrix(n) - TComplexMatrix.Create(gamma * u, u);
A := (Q * A * Q).SimilarHessenberg(True);
Inc(c);
if c > 100 then
Break;
DoYield;
end;
raise EMathException.Create('Couldn''t compute eigenvalues.');
end;
function TComplexMatrix.spectrum: TComplexVector;
begin
Result := eigenvalues;
end;
function TComplexMatrix.eigenvectors(out AEigenvalues: TComplexVector;
out AEigenvectors: TComplexMatrix; ASkipVerify: Boolean = False): Boolean;
const
LIMIT = 10000;
var
A, Q, R: TComplexMatrix;
i, j, k: Integer;
lambda, expf: TASC;
E: TArray<TComplexVector>;
EigenspaceFirstIndex,
EigenspaceLastIndex: Integer;
begin
if IsDiagonal then
begin
AEigenvalues := MainDiagonal;
AEigenvectors := ComplexIdentityMatrix(Size.Rows);
Exit(True);
end;
Result := False;
if IsHermitian then
begin
A := Self;
AEigenvectors := ComplexIdentityMatrix(Size.Rows);
i := 0;
repeat
A.QR(Q, R);
A := R * Q;
AEigenvectors := AEigenvectors * Q;
Inc(i);
DoYield;
until A.IsUpperTriangular or (i = LIMIT);
AEigenvalues := A.MainDiagonal.Defuzz;
Result := (i < LIMIT) or A.IsUpperTriangular(1E-6);
end;
if not Result then
begin
try
AEigenvalues := eigenvalues;
SetLength(E, AEigenvalues.Dimension);
for i := 0 to High(E) do
E[i] := EigenvectorOf(AEigenvalues[i]);
AEigenvectors := TComplexMatrix.CreateFromColumns(E);
Result := True;
except
Result := False;
end;
end;
if Result then
begin
if IsHermitian then
begin
lambda := 0;
EigenspaceFirstIndex := 0;
for i := 0 to AEigenvalues.Dimension do
begin
if (i = AEigenvalues.Dimension) or (i > 0) and not CSameValue(AEigenvalues[i], lambda) then
begin
EigenspaceLastIndex := Pred(i);
if EigenspaceLastIndex > EigenspaceFirstIndex then
AEigenvectors.InplaceGramSchmidt(EigenspaceFirstIndex, EigenspaceLastIndex);
EigenspaceFirstIndex := i;
end;
if i < AEigenvalues.Dimension then
lambda := AEigenvalues[i];
end;
end;
for i := 0 to AEigenvectors.Size.Cols - 1 do
begin
for j := 0 to AEigenvectors.Size.Rows - 1 do
if (AEigenvectors[j, i].Re > 0) and (AEigenvectors[j, i].Im = 0) then
Break
else if AEigenvectors[j, i] <> 0 then
begin
expf := cexp(-AEigenvectors[j, i].Argument * ImaginaryUnit);
for k := 0 to AEigenvectors.Size.Rows - 1 do
AEigenvectors[k, i] := AEigenvectors[k, i] * expf;
Break;
end;
end;
end;
if Result and not ASkipVerify then
begin
if AEigenvectors.IsSingular then
Exit(False);
for i := 0 to Size.Cols - 1 do
if not IsEigenpair(AEigenvalues[i], AEigenvectors.Cols[i], 1E-6) then
Exit(False);
end;
end;
function TComplexMatrix.IsEigenvector(const u: TComplexVector; const Epsilon: Extended = 0): Boolean;
var
im: TComplexVector;
begin
if not IsSquare then
raise EMathException.Create('Non-square matrix cannot have eigenvectors.');
if u.Dimension <> Size.Cols then
raise EMathException.Create('Vector is of wrong dimension.');
if u.IsZeroVector(Epsilon) then Exit(False);
im := TComplexVector((Self * u).Data);
Result := AreParallel(u, im, Epsilon);
end;
function TComplexMatrix.EigenvalueOf(const u: TComplexVector; const Epsilon: Extended = 0): TASC;
begin
if not TryEigenvalueOf(u, Result, Epsilon) then
raise EMathException.Create('A vector which isn''t an eigenvector has no associated eigenvalue.');
end;
function TComplexMatrix.TryEigenvalueOf(const u: TComplexVector; out AEigenvalue: TASC;
const Epsilon: Extended = 0): Boolean;
var
i: Integer;
im: TComplexVector;
begin
if not IsEigenvector(u, Epsilon) then
Exit(False);
Result := True;
im := TComplexVector((Self * u).Data);
if im.IsZeroVector(Epsilon) then
begin
AEigenvalue := 0;
Exit;
end;
for i := 0 to u.Dimension - 1 do
if not CIsZero(u[i], Epsilon) and not CIsZero(im[i], Epsilon) then
begin
AEigenvalue := im[i] / u[i];
Exit;
end;
raise EMathException.Create('Couldn''t compute associated eigenvalue of given eigenvector.');
end;
function TComplexMatrix.IsEigenpair(const lambda: TASC; const u: TComplexVector;
const Epsilon: Extended): Boolean;
begin
if not IsSquare then
raise EMathException.Create('Non-square matrix cannot have eigenvectors.');
if u.Dimension <> Size.Cols then
raise EMathException.Create('Vector is of wrong dimension.');
Result := SameVectorEx(TComplexVector((Self * u).Data), lambda * u, Epsilon) and not u.IsZeroVector(Epsilon);
end;
function TComplexMatrix.EigenvectorOf(const lambda: TASC): TComplexVector;
var
pertlambda: TASC;
A: TComplexMatrix;
i: Integer;
j: Integer;
Done: Boolean;
u: TComplexVector;
begin
if not IsSquare then
raise EMathException.Create('EigenvectorOf: The matrix isn''t square.');
pertlambda := lambda;
i := 0;
while not (Self - pertlambda * ComplexIdentityMatrix(Size.Rows)).TryInvert(A) do
begin
if i = 100 then
raise EMathException.Create('EigenvectorOf: Couldn''t invert matrix for inverse iteration.');
Inc(i);
pertlambda := lambda + 10*i * lambda.Modulus * ExtendedResolution * (2*Random - 1);
end;
for i := 1 to 10 do
begin
Done := False;
if ImaginaryPart.IsZeroMatrix then
begin
Result := TComplexVector(RandomVector(Size.Rows));
j := 0;
repeat
Result := TComplexVector(A * Result).Normalized;
Done := IsEigenpair(lambda, Result);
Inc(j)
until Done or (j > 10);
end;
if not Done then
begin
Result := TComplexVector(RandomVector(Size.Rows)) + ImaginaryUnit * TComplexVector(RandomVector(Size.Rows));
j := 0;
repeat
Result := TComplexVector(A * Result).Normalized;
Done := IsEigenpair(lambda, Result);
Inc(j)
until Done or (j > 10);
end;
if Done then
begin
u := TComplexVector(A * TComplexVector(Result)).Normalized;
u := TComplexVector(A * TComplexVector(u)).Normalized;
u := TComplexVector(A * TComplexVector(u)).Normalized;
for j := 0 to Result.Dimension - 1 do
if u[j].Modulus < 1E-50 then
u[j] := 0;
if IsEigenpair(lambda, u) then
Result := u;
for j := 0 to Result.Dimension - 1 do
if (Result[j].Re > 0) and (Result[j].Im = 0) then
Break
else if Result[j] <> 0 then
begin
Result := Result * cexp(-Result[j].Argument * ImaginaryUnit);
Break;
end;
Exit;
end;
end;
raise EMathException.Create('EigenvectorOf: Couldn''t compute associated eigenvector.');
end;
function TComplexMatrix.SpectralRadius: TASR;
begin
Result := max(spectrum.Abs());
end;
function TComplexMatrix.SingularValues: TRealVector;
begin
Result := HermitianSquare
.eigenvalues
.RealPart
.ReverseSort
.TruncateAt(Size.SmallestDimension)
.Apply(sqrt);
end;
function TComplexMatrix.Abs: TRealMatrix;
var
i: Integer;
begin
Result := TRealMatrix.CreateUninitialized(Size);
for i := 0 to Size.ElementCount - 1 do
Result.Data[i] := FElements[i].Modulus;
end;
function TComplexMatrix.Defuzz(const Eps: Double): TComplexMatrix;
begin
Result := Self;
TComplexVector(FElements).Defuzz(Eps);
end;
function TComplexMatrix.Clone: TComplexMatrix;
begin
Result := TComplexMatrix.CreateUninitialized(Size);
if Length(FElements) > 0 then
Move(FElements[0], Result.FElements[0], Length(FElements) * SizeOf(TASC));
end;
function TComplexMatrix.Vectorization: TComplexVector;
begin
Result := TComplexVector(Transpose.Data);
end;
function TComplexMatrix.AsVector: TComplexVector;
begin
Result := TComplexVector.Create(Data);
end;
function TComplexMatrix.Augment(const A: TComplexMatrix): TComplexMatrix;
var
y: Integer;
x: Integer;
begin
if IsEmpty then
Exit(A.Clone);
if Size.Rows <> A.Size.Rows then
raise EMathException.Create('Cannot augment matrix with different number of rows.');
Result := TComplexMatrix.CreateUninitialized(TMatrixSize.Create(Size.Rows, Size.Cols + A.Size.Cols));
for y := 0 to Size.Rows - 1 do
for x := 0 to Size.Cols - 1 do
Result.Elements[y, x] := Self[y, x];
for y := 0 to Size.Rows - 1 do
for x := 0 to A.Size.Cols - 1 do
Result.Elements[y, Size.Cols + x] := A[y, x];
end;
function TComplexMatrix.Augment: TComplexMatrix;
begin
Result := Augment(ComplexZeroVector(Size.Rows));
end;
function TComplexMatrix.GetRow(ARow: Integer): TComplexVector;
begin
if not InRange(ARow, 0, Size.Rows - 1) then
raise EMathException.Create('The specified row does not exist.');
Result.Dimension := Size.Cols;
Move(FElements[ARow * Result.Dimension], Result.Data[0], Result.Dimension * SizeOf(TASC));
end;
function TComplexMatrix.GetCol(ACol: Integer): TComplexVector;
var
i: Integer;
begin
if not InRange(ACol, 0, Size.Cols - 1) then
raise EMathException.Create('The specified column does not exist.');
Result.Dimension := Size.Rows;
for i := 0 to Result.Dimension - 1 do
Result[i] := Self[i, ACol];
end;
procedure TComplexMatrix._DoSetRow(ARowIndex: Integer; const ARow: TComplexVector);
var
i: Integer;
j: Integer;
begin
if Length(ARow.Data) <> Size.Cols then
raise EMathException.Create('Incorrect length of array.');
if not InRange(ARowIndex, 0, Size.Rows - 1) then
raise EMathException.Create('The specified row does not exist.');
j := Length(ARow.Data) * ARowIndex;
for i := 0 to Length(ARow.Data) - 1 do
FElements[j + i] := ARow[i];
end;
procedure TComplexMatrix.SetRow(ARowIndex: Integer; const ARow: array of TASC);
var
dummy: TASCArray;
begin
SetLength(dummy, Length(ARow));
if Length(ARow) > 0 then
Move(ARow[0], dummy[0], Length(ARow) * SizeOf(TASC));
_DoSetRow(ARowIndex, TComplexVector(dummy));
end;
procedure TComplexMatrix._DoSetCol(AColIndex: Integer; const ACol: TComplexVector);
var
i: Integer;
begin
if Length(ACol.Data) <> Size.Rows then
raise EMathException.Create('TComplexMatrix.SetCol: Incorrect length of array.');
if not InRange(AColIndex, 0, Size.Cols - 1) then
raise EMathException.Create('TComplexMatrix.SetCol: The specified column does not exist.');
for i := 0 to Length(ACol.Data) - 1 do
Self[i, AColIndex] := ACol[i];
end;
function TComplexMatrix.GetFirstCol: TComplexVector;
begin
Result := Cols[0];
end;
procedure TComplexMatrix.SetFirstCol(const ACol: TComplexVector);
begin
Cols[0] := ACol;
end;
function TComplexMatrix.GetLastCol: TComplexVector;
begin
Result := Cols[Size.Cols - 1];
end;
procedure TComplexMatrix.SetLastCol(const ACol: TComplexVector);
begin
Cols[Size.Cols - 1] := ACol;
end;
procedure TComplexMatrix.SetCol(AColIndex: Integer; const ACol: array of TASC);
var
dummy: TASCArray;
begin
SetLength(dummy, Length(ACol));
if Length(ACol) > 0 then
Move(ACol[0], dummy[0], Length(ACol) * SizeOf(TASC));
_DoSetCol(AColIndex, TComplexVector(dummy));
end;
function TComplexMatrix.GetMainDiagonal: TComplexVector;
var
i: Integer;
q: Integer;
begin
q := Size.SmallestDimension;
Result.Dimension := q;
for i := 0 to q - 1 do
Result[i] := Self[i, i];
end;
procedure TComplexMatrix.SetMainDiagonal(const ADiagonal: TComplexVector);
var
i: Integer;
q: Integer;
begin
q := Size.SmallestDimension;
if ADiagonal.Dimension <> q then
raise EMathException.Create('Incorrect number of elements in diagonal.');
for i := 0 to q - 1 do
Self[i, i] := ADiagonal[i];
end;
function TComplexMatrix.GetSuperDiagonal: TComplexVector;
var
i: Integer;
q: Integer;
begin
if Size.Cols > Size.Rows then
q := Size.Rows
else
q := Size.Cols - 1;
Result.Dimension := q;
for i := 0 to Result.Dimension - 1 do
Result[i] := Self[i, i + 1];
end;
procedure TComplexMatrix.SetSuperDiagonal(const ADiagonal: TComplexVector);
var
i: Integer;
q: Integer;
begin
if Size.Cols > Size.Rows then
q := Size.Rows
else
q := Size.Cols - 1;
if ADiagonal.Dimension <> q then
raise EMathException.Create('Incorrect number of elements in superdiagonal.');
for i := 0 to ADiagonal.Dimension - 1 do
Self[i, i + 1] := ADiagonal[i];
end;
function TComplexMatrix.GetSubDiagonal: TComplexVector;
var
i: Integer;
q: Integer;
begin
if Size.Rows > Size.Cols then
q := Size.Cols
else
q := Size.Rows - 1;
Result.Dimension := q;
for i := 0 to Result.Dimension - 1 do
Result[i] := Self[i + 1, i];
end;
procedure TComplexMatrix.SetSubDiagonal(const ADiagonal: TComplexVector);
var
i: Integer;
q: Integer;
begin
if Size.Rows > Size.Cols then
q := Size.Cols
else
q := Size.Rows - 1;
if ADiagonal.Dimension <> q then
raise EMathException.Create('Incorrect number of elements in subdiagonal.');
for i := 0 to ADiagonal.Dimension - 1 do
Self[i + 1, i] := ADiagonal[i];
end;
procedure TComplexMatrix.SetSize(const Value: TMatrixSize);
begin
FElements := nil;
Alloc(Value);
end;
function TComplexMatrix.GetAntiDiagonal: TComplexVector;
var
i: Integer;
begin
if not IsSquare then
raise EMathException.Create('A non-square matrix has no antidiagonal.');
Result.Dimension := Size.Rows;
for i := 0 to Size.Rows - 1 do
Result[i] := Self[i, Size.Cols - 1 - i];
end;
procedure TComplexMatrix.SetAntiDiagonal(const ADiagonal: TComplexVector);
var
i: Integer;
begin
if not IsSquare then
raise EMathException.Create('A non-square matrix has no antidiagonal.');
if ADiagonal.Dimension <> Size.Rows then
raise EMathException.Create('Incorrect number of elements in antidiagonal.');
for i := 0 to Size.Rows - 1 do
Self[i, Size.Cols - 1 - i] := ADiagonal[i];
end;
function TComplexMatrix.Submatrix(ARowToRemove: Integer; AColToRemove: Integer;
AAllowEmpty: Boolean): TComplexMatrix;
var
y: Integer;
x: Integer;
resy, resx: Integer;
begin
if not (InRange(ARowToRemove, 0, Size.Rows - 1) and InRange(AColToRemove, 0, Size.Cols - 1)) then
raise EMathException.Create('Invalid row or column index in call to function Submatrix.');
if AAllowEmpty and (IsRow or IsColumn) then
Exit(_EmptyComplexMatrix);
Result := TComplexMatrix.CreateUninitialized(TMatrixSize.Create(Size.Rows - 1, Size.Cols - 1));
resy := 0;
for y := 0 to Size.Rows - 1 do
begin
if y = ARowToRemove then
Continue;
resx := 0;
for x := 0 to Size.Cols - 1 do
begin
if x = AColToRemove then
Continue;
Result.Elements[resy, resx] := Self[y, x];
Inc(resx);
end;
Inc(resy);
end;
end;
function TComplexMatrix.Submatrix(const ARows: array of Integer;
const ACols: array of Integer): TComplexMatrix;
procedure InvalidArg;
begin
raise EMathException.Create('Invalid index arrays passed to function Submatrix.');
end;
var
i: Integer;
y, x: Integer;
begin
for i := 0 to High(ARows) do
if not InRange(ARows[i], 0, Size.Rows - 1) then
InvalidArg;
for i := 0 to High(ACols) do
if not InRange(ACols[i], 0, Size.Cols - 1) then
InvalidArg;
Result := TComplexMatrix.CreateUninitialized(TMatrixSize.Create(Length(ARows), Length(ACols)));
for y := 0 to Result.Size.Rows - 1 do
for x := 0 to Result.Size.Cols - 1 do
Result[y, x] := Self[ARows[y], ACols[x]];
end;
function TComplexMatrix.Submatrix(const ARows: array of Integer): TComplexMatrix;
begin
Result := Submatrix(ARows, ARows);
end;
function TComplexMatrix.LeadingPrincipalSubmatrix(const ASize: Integer): TComplexMatrix;
begin
Result := Submatrix(CreateIntSequence(0, ASize - 1));
end;
function TComplexMatrix.Lessened: TComplexMatrix;
var
y: Integer;
x: Integer;
begin
if Size.Cols = 1 then
raise EMathException.Create('Cannot lessen a single-column matrix.');
Result := TComplexMatrix.CreateUninitialized(Size.LessenedSize);
for y := 0 to Result.Size.Rows - 1 do
for x := 0 to Result.Size.Cols - 1 do
Result[y, x] := Self[y, x];
end;
function TComplexMatrix.Minor(ARow: Integer; ACol: Integer): TASC;
begin
Result := Submatrix(ARow, ACol).Determinant;
end;
function TComplexMatrix.Cofactor(ARow: Integer; ACol: Integer): TASC;
begin
Result := AltSgn(ARow + ACol) * Minor(ARow, ACol);
end;
function TComplexMatrix.CofactorMatrix: TComplexMatrix;
var
y: Integer;
x: Integer;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute cofactor matrix of non-square matrix.');
Result := TComplexMatrix.CreateUninitialized(Size);
for y := 0 to Size.Rows - 1 do
for x := 0 to Size.Cols - 1 do
begin
Result[y, x] := Cofactor(y, x);
DoYield;
end;
end;
function TComplexMatrix.AdjugateMatrix: TComplexMatrix;
begin
Result := CofactorMatrix.Transpose;
end;
procedure TComplexMatrix.LU(out P, L, U: TComplexMatrix);
function RowPermutationMatrix(n, i, j: Integer): TComplexMatrix;
begin
Result := ComplexIdentityMatrix(n);
Result[i, i] := 0;
Result[j, j] := 0;
Result[i, j] := 1;
Result[j, i] := 1;
end;
var
A: TComplexMatrix;
Pvect: TIndexArray;
i: Integer;
begin
DoQuickLU(A, Pvect);
L := A.Clone;
L.MakeLowerTriangular;
L.MainDiagonal := TComplexVector.Create(L.Size.Rows, 1);
U := A.Clone;
U.MakeUpperTriangular;
P := ComplexIdentityMatrix(Size.Rows);
for i := 0 to High(Pvect) do
if Pvect[i] <> -1 then
P := RowPermutationMatrix(Size.Rows, i, Pvect[i]) * P;
end;
function TComplexMatrix.Cholesky(out R: TComplexMatrix): Boolean;
var
i, j, k: Integer;
begin
if not IsSquare then
raise EMathException.Create('Cannot compute Cholesky decomposition of non-square matrix.');
R := Clone;
for i := 0 to Size.Rows - 1 do
begin
for k := 0 to i - 1 do
R[i, i] := R[i, i] - R[k, i].ModSqr;
if (R[i, i].Re < 0) or IsZero(R[i, i].Re) or not R[i, i].IsReal then
Exit(False);
R[i, i] := sqrt(R[i, i].Re);
for j := i + 1 to Size.Rows - 1 do
begin
for k := 0 to i - 1 do
R[i, j] := R[i, j] - R[k, i].Conjugate * R[k, j];
R[i, j] := R[i, j] / R[i, i];
end;
DoYield;
end;
R.MakeUpperTriangular;
Result := True;
end;
procedure TComplexMatrix.GetHouseholderMap(const AVect: TComplexVector;
out tau, gamma: TASC; out u: TComplexVector);
var
beta: TASC;
begin
beta := max(AVect.Abs());
if CIsZero(beta) then
begin
tau := 0;
gamma := 0;
u := ComplexZeroVector(AVect.Dimension);
end
else
begin
u := AVect / beta;
tau := u.Norm * cexp(ImaginaryUnit * u[0].Argument);
u[0] := u[0] + tau;
gamma := u[0] / tau;
u := u / u[0];
u[0] := 1;
tau := tau * beta;
end;
end;
procedure TComplexMatrix.QR(out Q: TComplexMatrix; out R: TComplexMatrix);
var
k: Integer;
col: TComplexVector;
tau: TASC;
gamma: TASC;
u: TComplexVector;
Qk: TComplexMatrix;
begin
if Size.Cols > Size.Rows then
raise EMathException.Create('QR decomposition only implemented for square and tall matrices.');
R := Clone;
Q := ComplexIdentityMatrix(R.Size.Rows);
for k := 0 to Min(Size.Rows - 2, Size.Cols - 1) do
begin
col.Dimension := Size.Rows - k;
MatMoveColToVect(R, k, k, Size.Rows - 1, col);
GetHouseholderMap(col, tau, gamma, u);
if CIsZero(gamma) then
Qk := ComplexIdentityMatrix(col.Dimension)
else
Qk := ComplexIdentityMatrix(col.Dimension) - TComplexMatrix.Create(gamma * u, u);
MatMulBlockInplaceL(R,
Rect(
k,
k,
Min(k + Qk.Size.Cols, R.Size.Cols) - 1,
Min(k + Qk.Size.Rows, R.Size.Rows) - 1
),
Qk);
R[k, k] := -tau;
MatMulBottomRight(Q, Qk);
DoYield;
end;
R.MakeUpperTriangular;
end;
procedure TComplexMatrix.Hessenberg(out A, U: TComplexMatrix);
var
k: Integer;
col: TComplexVector;
tau: TASC;
gamma: TASC;
uk: TComplexVector;
Ident, Q: TComplexMatrix;
begin
if not IsSquare then
raise EMathException.Create('Cannot find similar Hessenberg matrix of non-square matrix.');
Ident := ComplexIdentityMatrix(Size.Rows);
A := Clone;
U := ComplexIdentityMatrix(Size.Rows);
for k := 0 to Size.Rows - 2 - 1 do
begin
col.Dimension := Size.Rows - k - 1;
MatMoveColToVect(A, k, k + 1, Size.Rows - 1, col);
GetHouseholderMap(col, tau, gamma, uk);
if CIsZero(gamma) then
Q := Ident
else
Q := DirectSum(ComplexIdentityMatrix(k + 1), ComplexIdentityMatrix(col.Dimension) - TComplexMatrix.Create(gamma * uk, uk));
A := Q * A * Q;
U := U * Q;
end;
end;
function TComplexMatrix.Apply(AFunction: TComplexFunctionRef): TComplexMatrix;
var
i: Integer;
begin
Result := TComplexMatrix.CreateUninitialized(Size);
for i := 0 to Result.Size.ElementCount - 1 do
Result.Data[i] := AFunction(FElements[i]);
end;
function TComplexMatrix.Replace(APredicate: TPredicate<TASC>; const ANewValue: TASC): TComplexMatrix;
begin
Result := TComplexMatrix.CreateUninitialized(Size);
Result.Data := TASCArray(TComplexVector(Data).Replace(APredicate, ANewValue));
end;
function TComplexMatrix.Replace(const AOldValue, ANewValue: TASC; const Epsilon: Extended): TComplexMatrix;
begin
Result := TComplexMatrix.CreateUninitialized(Size);
Result.Data := TASCArray(TComplexVector(Self.Data).Replace(AOldValue, ANewValue, Epsilon));
end;
function TComplexMatrix.Replace(const ANewValue: TASC): TComplexMatrix;
begin
Result := TComplexMatrix.Create(Size, ANewValue);
end;
procedure TComplexMatrix.RequireNonEmpty;
begin
if IsEmpty then
raise Exception.Create('Matrix is empty.');
end;
function TComplexMatrix.str(const AOptions: TFormatOptions): string;
var
y: Integer;
x: Integer;
begin
Result := '(';
for y := 0 to Size.Rows - 1 do
begin
Result := Result + '(';
for x := 0 to Size.Cols - 1 do
begin
Result := Result + ComplexToStr(Elements[y, x], False, AOptions);
if x < Size.Cols - 1 then
Result := Result + ', '
end;
Result := Result + ')';
if y < Size.Rows - 1 then
Result := Result + ', '
end;
Result := Result + ')';
end;
procedure TComplexMatrix.AddRow(const ARow: array of TASC);
var
i, j: Integer;
begin
if Length(ARow) <> Size.Cols then
raise EMathException.Create('Cannot add row to matrix since the number of columns doesn''t match.');
Alloc(Size.Rows + 1, Size.Cols);
j := Size.Cols * (Size.Rows - 1);
for i := 0 to Length(ARow) - 1 do
begin
FElements[j] := ARow[i];
Inc(j);
end;
end;
function TComplexMatrix.Sort(AComparer: IComparer<TASC>): TComplexMatrix;
begin
TComplexVector(FElements).Sort(AComparer);
Result := Self;
end;
function TComplexMatrix.eigenvalues: TComplexVector;
begin
Result := UnsortedEigenvalues.Sort(TASCComparer.ModulusArgumentDescending);
end;
function TComplexMatrix.Shuffle: TComplexMatrix;
begin
TComplexVector(FElements).Shuffle;
Result := Self;
end;
function TComplexMatrix.Reverse: TComplexMatrix;
begin
Result := Self;
TComplexVector(FElements).Reverse;
end;
function mpow(const A: TComplexMatrix; const N: Integer): TComplexMatrix;
var
i: Integer;
begin
if not A.IsSquare then
raise EMathException.Create('Cannot compute power of non-square matrix.');
if N < 0 then
Exit(mpow(A.Inverse, -N));
Result := ComplexIdentityMatrix(A.Size.Rows);
for i := 1 to N do
Result := Result * A;
end;
function msqrt(const A: TComplexMatrix): TComplexMatrix;
var
T: TComplexMatrix;
u: TComplexVector;
begin
if not A.IsPositiveSemiDefinite then
raise EMathException.Create('Matrix square root only defined for positive semidefinite Hermitian matrices.');
if not A.eigenvectors(u, T, true) then
raise EMathException.Create('msqrt: Couldn''t diagonalize the matrix.');
T := T.GramSchmidt;
Result := T * diag(u.RealPart.Apply(sqrt)) * T.Adjoint;
if not SameMatrixEx(Result.Sqr, A, 1E-8) then
raise EMathException.Create('Couldn''t compute matrix square root.');
end;
function SameMatrix(const A, B: TComplexMatrix; const Epsilon: Extended): Boolean;
begin
Result := (A.Size = B.Size) and SameVector(TComplexVector(A.Data), TComplexVector(B.Data), Epsilon);
end;
function SameMatrixEx(const A, B: TComplexMatrix; const Epsilon: Extended): Boolean;
begin
Result := (A.Size = B.Size) and SameVectorEx(TComplexVector(A.Data), TComplexVector(B.Data), Epsilon);
end;
function ComplexZeroMatrix(const ASize: TMatrixSize): TComplexMatrix; inline;
begin
Result := TComplexMatrix.Create(ASize, 0);
end;
function ComplexIdentityMatrix(ASize: Integer): TComplexMatrix;
begin
if ASize = 0 then Exit(_EmptyComplexMatrix);
Result := TComplexMatrix.CreateDiagonal(ASize, 1);
end;
function ComplexReversalMatrix(ASize: Integer): TComplexMatrix;
begin
Result := TComplexMatrix.Create(TMatrixSize.Create(ASize), 0);
Result.AntiDiagonal := TComplexVector.Create(ASize, 1);
end;
function diag(const AElements: array of TASC): TComplexMatrix;
begin
Result := TComplexMatrix.CreateDiagonal(AElements);
end;
function diag(const AElements: TComplexVector): TComplexMatrix;
begin
Result := TComplexMatrix.CreateDiagonal(AElements);
end;
function OuterProduct(const u, v: TComplexVector): TComplexMatrix; inline;
begin
Result := TComplexMatrix.Create(u, v);
end;
function CirculantMatrix(const AElements: array of TASC): TComplexMatrix;
var
y: Integer;
x: Integer;
row: PASC;
begin
Result := TComplexMatrix.CreateUninitialized(Length(AElements));
for y := 0 to Result.Size.Rows - 1 do
begin
row := Result.RowData[y];
for x := 0 to Result.Size.Cols - 1 do
row[x] := AElements[(Length(AElements) + x - y) mod Result.Size.Cols];
end;
end;
function ToeplitzMatrix(const AFirstRow, AFirstCol: array of TASC): TComplexMatrix;
function virtarr(index: Integer): TASC;
begin
if index <= 0 then
Result := AFirstRow[-index]
else
Result := AFirstCol[index];
end;
var
y: Integer;
x: Integer;
begin
if (Length(AFirstRow) = 0) or (Length(AFirstCol) = 0) then
raise EMathException.Create('The given vectors must be of dimension one or greater.');
if not CSameValueEx(AFirstRow[0], AFirstCol[0]) then
raise EMathException.Create('The first element of the first row must equal the first element of the first column.');
Result := TComplexMatrix.CreateUninitialized(TMatrixSize.Create(Length(AFirstCol), Length(AFirstRow)));
for y := 0 to Result.Size.Rows - 1 do
for x := 0 to Result.Size.Cols - 1 do
Result[y, x] := virtarr(y - x);
end;
function HankelMatrix(const AFirstRow, ALastCol: array of TASC): TComplexMatrix;
function virtarr(index: Integer): TASC;
begin
if index >= Length(AFirstRow) then
Result := ALastCol[index - Length(AFirstRow) + 1]
else
Result := AFirstRow[index];
end;
var
y: Integer;
x: Integer;
begin
if (Length(AFirstRow) = 0) or (Length(ALastCol) = 0) then
raise EMathException.Create('The specified vectors must be of dimension one or greater.');
if not CSameValueEx(AFirstRow[High(AFirstRow)], ALastCol[0]) then
raise EMathException.Create('The last element of the first row must equal the first element of the last column.');
Result := TComplexMatrix.CreateUninitialized(TMatrixSize.Create(Length(ALastCol), Length(AFirstRow)));
for y := 0 to Result.Size.Rows - 1 do
for x := 0 to Result.Size.Cols - 1 do
Result[y, x] := virtarr(y + x);
end;
function VandermondeMatrix(const AElements: array of TASC; ACols: Integer): TComplexMatrix;
var
y: Integer;
x: Integer;
row: PASC;
begin
if ACols <= 0 then
ACols := Length(AElements);
Result := TComplexMatrix.CreateUninitialized(TMatrixSize.Create(Length(AElements), ACols));
for y := 0 to Result.Size.Rows - 1 do
begin
row := Result.RowData[y];
if ACols >= 1 then
row[0] := 1;
if ACols >= 2 then
row[1] := AElements[y];
for x := 2 to Result.Size.Cols - 1 do
row[x] := cpow(AElements[y], x);
end;
end;
function ReflectionMatrix(const u: TComplexVector): TComplexMatrix;
begin
if u.IsZeroVector then
raise EMathException.Create('Vector cannot be zero.');
Result := ComplexIdentityMatrix(u.Dimension) - 2 * OuterProduct(u, u) / u.NormSqr;
end;
function QuickReflectionMatrix(const u: TComplexVector): TComplexMatrix;
begin
Result := ComplexIdentityMatrix(u.Dimension) - 2 * OuterProduct(u, u);
end;
function HadamardProduct(const A, B: TComplexMatrix): TComplexMatrix;
var
i: Integer;
begin
if A.Size <> B.Size then
raise EMathException.Create('Hadamard product only defined for matrices of the same size.');
Result := TComplexMatrix.CreateUninitialized(A.Size);
for i := 0 to Result.Size.ElementCount - 1 do
Result.Data[i] := A.Data[i] * B.Data[i];
end;
function DirectSum(const A, B: TComplexMatrix): TComplexMatrix;
begin
Result := DirectSum([A, B]);
end;
function DirectSum(const Blocks: array of TComplexMatrix): TComplexMatrix; overload;
var
i: Integer;
cols, rows: Integer;
x, y: Integer;
begin
cols := 0;
rows := 0;
for i := 0 to High(Blocks) do
begin
Inc(cols, Blocks[i].Size.Cols);
Inc(rows, Blocks[i].Size.Rows);
end;
Result := TComplexMatrix.CreateUninitialized(TMatrixSize.Create(rows, cols));
x := 0;
y := 0;
for i := 0 to High(Blocks) do
begin
MatMove(Blocks[i], Result, Point(x, y));
MatBlockFill(Result,
Rect(x + Blocks[i].Size.Cols, y, Result.Size.Cols - 1, y + Blocks[i].Size.Rows - 1),
0);
MatBlockFill(Result,
Rect(x, y + Blocks[i].Size.Rows, x + Blocks[i].Size.Cols - 1, Result.Size.Rows - 1),
0);
Inc(x, Blocks[i].Size.Cols);
Inc(y, Blocks[i].Size.Rows);
end;
end;
function Commute(const A, B: TComplexMatrix; const Epsilon: Extended): Boolean;
begin
Result := A.CommutesWith(B, Epsilon);
end;
function accumulate(const A: TComplexMatrix; const AStart: TASC;
AAccumulator: TAccumulator<TASC>): TASC; overload; inline;
begin
Result := accumulate(A, AStart, AAccumulator);
end;
function sum(const A: TComplexMatrix): TASC; inline;
begin
Result := sum(TComplexVector(A.Data));
end;
function ArithmeticMean(const A: TComplexMatrix): TASC; inline;
begin
Result := ArithmeticMean(TComplexVector(A.Data));
end;
function GeometricMean(const A: TComplexMatrix): TASC; inline;
begin
Result := GeometricMean(TComplexVector(A.Data));
end;
function HarmonicMean(const A: TComplexMatrix): TASC; inline;
begin
Result := HarmonicMean(TComplexVector(A.Data));
end;
function product(const A: TComplexMatrix): TASC; inline;
begin
Result := product(TComplexVector(A.Data));
end;
function exists(const A: TComplexMatrix; APredicate: TPredicate<TASC>): Boolean;
begin
Result := exists(TComplexVector(A.Data), APredicate);
end;
function count(const A: TComplexMatrix; APredicate: TPredicate<TASC>): Integer;
begin
Result := count(TComplexVector(A.Data), APredicate);
end;
function count(const A: TComplexMatrix; const AValue: TASC): Integer; inline;
begin
Result := count(TComplexVector(A.Data), AValue);
end;
function ForAll(const A: TComplexMatrix; APredicate: TPredicate<TASC>): Boolean;
begin
Result := ForAll(TComplexVector(A.Data), APredicate);
end;
function contains(const A: TComplexMatrix; AValue: TASC): Boolean; inline;
begin
Result := contains(TComplexVector(A.Data), AValue);
end;
function TryForwardSubstitution(const A: TComplexMatrix; const Y: TComplexVector;
out Solution: TComplexVector; IsUnitDiagonal: Boolean = False): Boolean;
var
i: Integer;
row: PASC;
j: Integer;
begin
if not A.IsSquare then
raise EMathException.Create('ForwardSubstitution: Coefficient matrix isn''t square.');
if A.Size.Cols <> Y.Dimension then
raise EMathException.Create('ForwardSubstitution: RHS is of wrong dimension.');
Solution.Dimension := Y.Dimension;
for i := 0 to A.Size.Rows - 1 do
begin
row := A.RowData[i];
Solution[i] := Y[i];
for j := 0 to i - 1 do
Solution[i] := Solution[i] - row[j] * Solution[j];
if not IsUnitDiagonal then
begin
if CIsZero(row[i]) then
Exit(False)
else
Solution[i] := Solution[i] / row[i];
end;
end;
Result := True;
end;
function ForwardSubstitution(const A: TComplexMatrix; const Y: TComplexVector;
IsUnitDiagonal: Boolean = False): TComplexVector;
begin
if not TryForwardSubstitution(A, Y, Result, IsUnitDiagonal) then
raise EMathException.Create('ForwardSubstitution: Matrix is singular.')
end;
function TryBackSubstitution(const A: TComplexMatrix; const Y: TComplexVector;
out Solution: TComplexVector): Boolean;
var
i: Integer;
row: PASC;
j: Integer;
begin
if not A.IsSquare then
raise EMathException.Create('BackSubstitution: Coefficient matrix isn''t square.');
if A.Size.Cols <> Y.Dimension then
raise EMathException.Create('BackSubstitution: RHS is of wrong dimension.');
Solution.Dimension := Y.Dimension;
for i := A.Size.Rows - 1 downto 0 do
begin
row := A.RowData[i];
Solution[i] := Y[i];
for j := i + 1 to A.Size.Cols - 1 do
Solution[i] := Solution[i] - row[j] * Solution[j];
if CIsZero(row[i]) then
Exit(False)
else
Solution[i] := Solution[i] / row[i];
end;
Result := True;
end;
function BackSubstitution(const A: TComplexMatrix; const Y: TComplexVector): TComplexVector;
begin
if not TryBackSubstitution(A, Y, Result) then
raise EMathException.Create('BackSubstitution: Matrix is singular.')
end;
function TryLUSysSolve(const A: TComplexMatrix; const P: TIndexArray;
const Y: TComplexVector; out Solution: TComplexVector): Boolean; overload;
var
b, c: TComplexVector;
i: Integer;
begin
if Y.Dimension <> Length(P) then
raise EMathException.Create('TryLUSysSolve: RHS is of wrong dimension.');
b := Y.Clone;
for i := 0 to High(P) do
if (P[i] <> -1) and (P[i] <> i) then
TSwapper<TASC>.Swap(b.Data[i], b.Data[P[i]]);
Result := TryForwardSubstitution(A, b, c, True) and
TryBackSubstitution(A, c, Solution);
end;
function LUSysSolve(const A: TComplexMatrix; const P: TIndexArray;
const Y: TComplexVector): TComplexVector; overload;
var
b: TComplexVector;
i: Integer;
begin
if Y.Dimension <> Length(P) then
raise EMathException.Create('LUSysSolve: RHS is of wrong dimension.');
b := Y.Clone;
for i := 0 to High(P) do
if (P[i] <> -1) and (P[i] <> i) then
TSwapper<TASC>.Swap(b.Data[i], b.Data[P[i]]);
b := ForwardSubstitution(A, b, True);
Result := BackSubstitution(A, b);
end;
function TrySysSolve(const A: TComplexMatrix; const Y: TComplexVector;
out Solution: TComplexVector): Boolean;
var
LU: TComplexMatrix;
P: TIndexArray;
begin
A.DoQuickLU(LU, P);
Result := TryLUSysSolve(LU, P, Y, Solution);
end;
function TrySysSolve(const A: TComplexMatrix; const Y: TComplexMatrix;
out Solution: TComplexMatrix): Boolean;
var
LU: TComplexMatrix;
P: TIndexArray;
i: Integer;
sol: TComplexVector;
begin
A.DoQuickLU(LU, P);
Solution := TComplexMatrix.CreateUninitialized(Y.Size);
for i := 0 to Y.Size.Cols - 1 do
if TryLUSysSolve(LU, P, Y.Cols[i], sol) then
Solution.Cols[i] := sol
else
Exit(False);
Result := True;
end;
function SysSolve(const AAugmented: TComplexMatrix): TComplexVector;
begin
Result := SysSolve(AAugmented.Lessened, AAugmented.LastColumn);
end;
function SysSolve(const A: TComplexMatrix; const Y: TComplexVector): TComplexVector;
var
LU: TComplexMatrix;
P: TIndexArray;
begin
if not A.IsSquare then
raise EMathException.Create('Coefficient matrix isn''t square.');
A.DoQuickLU(LU, P);
Result := LUSysSolve(LU, P, Y);
end;
function SysSolve(const A: TComplexMatrix; const Y: TComplexMatrix): TComplexMatrix; overload;
var
LU: TComplexMatrix;
P: TIndexArray;
i: Integer;
begin
if not A.IsSquare then
raise EMathException.Create('Coefficient matrix isn''t square.');
A.DoQuickLU(LU, P);
Result := TRealMatrix.CreateUninitialized(Y.Size);
for i := 0 to Y.Size.Cols - 1 do
Result.Cols[i] := LUSysSolve(LU, P, Y.Cols[i]);
end;
function LeastSquaresPolynomialFit(const X, Y: TComplexVector; ADegree: Integer): TComplexVector;
var
A, At: TComplexMatrix;
begin
if X.Dimension <> Y.Dimension then
raise EMathException.Create('LeastSquaresPolynomialFit: X and Y vectors must have the same dimension.');
if ADegree < 0 then
raise EMathException.Create('LeastSquaresPolynomialFit: Polynomial degree must be non-negative.');
A := VandermondeMatrix(X.Data, ADegree + 1);
At := A.Transpose;
Result := SysSolve(At * A, TComplexVector(At * Y));
end;
procedure VectMove(const ASource: TComplexVector; const AFrom, ATo: Integer;
var ATarget: TComplexVector; const ATargetFrom: Integer = 0);
begin
Move(ASource.Data[AFrom], ATarget.Data[ATargetFrom],
(ATo - AFrom + 1) * SizeOf(TASC));
end;
procedure VectMoveToMatCol(const ASource: TComplexVector; const AFrom, ATo: Integer;
var ATarget: TComplexMatrix; const ATargetCol: Integer;
const ATargetFirstRow: Integer = 0);
var
index: Integer;
i: Integer;
begin
index := ATargetFirstRow * ATarget.Size.Cols + ATargetCol;
for i := AFrom to ATo do
begin
ATarget.Data[index] := ASource[i];
Inc(index, ATarget.Size.Cols);
end;
end;
procedure VectMoveToMatRow(const ASource: TComplexVector; const AFrom, ATo: Integer;
var ATarget: TComplexMatrix; const ATargetRow: Integer;
const ATargetFirstCol: Integer = 0);
begin
Move(ASource.Data[AFrom], ATarget.RowData[ATargetRow][ATargetFirstCol],
(ATo - AFrom + 1) * SizeOf(TASC));
end;
procedure MatMove(const ASource: TComplexMatrix; const ARect: TRect;
var ATarget: TComplexMatrix; const ATargetTopLeft: TPoint);
var
y: Integer;
begin
for y := 0 to ARect.Bottom - ARect.Top do
Move(ASource.RowData[ARect.Top + y][ARect.Left],
ATarget.RowData[ATargetTopLeft.Y + y][ATargetTopLeft.X],
(ARect.Right - ARect.Left + 1) * SizeOf(TASC));
end;
procedure MatMove(const ASource: TComplexMatrix; var ATarget: TComplexMatrix;
const ATargetTopLeft: TPoint); overload;
begin
MatMove(ASource, Rect(0, 0, ASource.Size.Cols - 1, ASource.Size.Rows - 1),
ATarget, ATargetTopLeft);
end;
procedure MatMoveColToVect(const ASource: TComplexMatrix; const AColumn: Integer;
const AFrom, ATo: Integer; var ATarget: TComplexVector;
const ATargetFrom: Integer = 0);
var
index: Integer;
i: Integer;
begin
index := AColumn + AFrom * ASource.Size.Cols;
for i := ATargetFrom to ATargetFrom + ATo - AFrom do
begin
ATarget.Data[i] := ASource.Data[index];
Inc(index, ASource.Size.Cols);
end;
end;
procedure MatMoveRowToVect(const ASource: TComplexMatrix; const ARow: Integer;
const AFrom, ATo: Integer; var ATarget: TComplexVector;
const ATargetFrom: Integer = 0);
begin
Move(ASource.RowData[ARow][AFrom], ATarget.Data[ATargetFrom],
(ATo - AFrom + 1) * SizeOf(TASC));
end;
procedure MatMulBlockInplaceL(var ATarget: TComplexMatrix; const ARect: TRect;
const AFactor: TComplexMatrix);
var
prod: TComplexMatrix;
Large: Boolean;
i, j, k: Integer;
row1, row2: PASC;
begin
prod := TComplexMatrix.CreateUninitialized(
TMatrixSize.Create(AFactor.Size.Rows, ARect.Right - ARect.Left + 1));
Large := prod.Size.ElementCount > 100000;
for i := 0 to prod.Size.Rows - 1 do
begin
row1 := prod.RowData[i];
row2 := AFactor.RowData[i];
for j := 0 to prod.Size.Cols - 1 do
begin
row1[j] := 0;
for k := 0 to AFactor.Size.Cols - 1 do
row1[j] := row1[j] + row2[k] * ATarget[ARect.Top + k, ARect.Left + j];
end;
if Large then
DoYield;
end;
MatMove(prod, ATarget, ARect.TopLeft);
end;
procedure MatMulBlockInplaceL(var ATarget: TComplexMatrix; const ATopLeft: TPoint;
const AFactor: TComplexMatrix);
begin
MatMulBlockInplaceL(ATarget,
Rect(ATopLeft.X, ATopLeft.Y,
ATopLeft.X + AFactor.Size.Cols - 1, ATopLeft.Y + AFactor.Size.Rows - 1),
AFactor);
end;
procedure MatMulBottomRight(var ATarget: TComplexMatrix; const AFactor: TComplexMatrix);
var
prod: TComplexMatrix;
n, m, d: Integer;
Large: Boolean;
y, x: Integer;
k: Integer;
row1, row2: PASC;
begin
n := ATarget.Size.Rows;
m := AFactor.Size.Rows;
Large := n * m > 100000;
d := n - m;
prod := TComplexMatrix.CreateUninitialized(TMatrixSize.Create(n, m));
for y := 0 to n - 1 do
begin
row1 := prod.RowData[y];
row2 := ATarget.RowData[y];
for x := 0 to m - 1 do
begin
row1[x] := 0;
for k := 0 to m - 1 do
row1[x] := row1[x] + row2[d + k] * AFactor[k, x];
end;
if Large then
DoYield;
end;
MatMove(prod, ATarget, Point(d, 0));
end;
procedure MatBlockFill(var ATarget: TComplexMatrix; const ARect: TRect;
const Value: TASC);
var
y: Integer;
row: PASC;
x: Integer;
begin
for y := ARect.Top to ARect.Bottom do
begin
row := ATarget.RowData[y];
for x := ARect.Left to ARect.Right do
row[x] := Value;
end;
end;
function sqrt(const X: TASR): TASR;
begin
Result := System.Sqrt(X);
end;
function sqrt(const z: TASC): TASC;
begin
Result := csqrt(z);
end;
function sqrt(const A: TRealMatrix): TRealMatrix;
begin
Result := msqrt(A);
end;
function sqrt(const A: TComplexMatrix): TComplexMatrix;
begin
Result := msqrt(A);
end;
procedure InitCaches;
begin
ExpandPrimeCache(100);
InitSpecialFunctionsIntegrationCacheList;
end;
function GetTotalCacheSize: Integer;
begin
Result := 0;
Inc(Result, GetPrimeCacheSizeBytes);
Inc(Result, GetSpecialFunctionsIntegrationCacheSize);
Inc(Result, Length(_harmonic_numbers) * SizeOf(TASR));
Inc(Result, Length(_MöbiusCache) * SizeOf(Int8));
if Assigned(_MertensCache) then
begin
Inc(Result, _MertensCache.InstanceSize);
Inc(Result, _MertensCache.Capacity * SizeOf(Integer));
end;
end;
procedure ClearCaches;
begin
ClearPrimeCache;
ClearSpecialFunctionsIntegrationCaches;
SetLength(_harmonic_numbers, 0);
SetLength(_MöbiusCache, 0);
FreeAndNil(_MertensCache);
end;
constructor TRange.Create(AFrom, ATo: Integer; AStep: Integer = 1);
begin
From := AFrom;
&To := ATo;
Step := AStep;
end;
constructor TRange.Create(ASinglePoint: Integer);
begin
From := ASinglePoint;
&To := ASinglePoint;
Step := 1;
end;
function TFormatOptions.TComplexOptions.ImaginarySuffix: string;
begin
Result := MultiplicationSign + ImaginaryUnit;
end;
function TFormatOptions.TComplexOptions.MinusStr: string;
begin
if Spaced then
Result := SPACE + MinusSign + SPACE
else
Result := MinusSign;
end;
function TFormatOptions.TComplexOptions.PlusStr: string;
begin
if Spaced then
Result := SPACE + PlusSign + SPACE
else
Result := PlusSign;
end;
constructor TASR2.Create(AX, AY: TASR);
begin
X := AX;
Y := AY;
end;
constructor TASR3.Create(AX, AY, AZ: TASR);
begin
X := AX;
Y := AY;
Z := AZ;
end;
constructor TASR4.Create(AX, AY, AZ, AW: TASR);
begin
X := AX;
Y := AY;
Z := AZ;
W := AW;
end;
initialization
FS := TFormatSettings.Create(1033);
InitCaches;
finalization
ClearCaches;
{$IFNDEF REALCHECK}
{$MESSAGE Warn 'asnum.pas compiled without REALCHECK.'}
{$ENDIF}
end.