unit ASKernelDefs;
{$WARN SYMBOL_PLATFORM OFF}
{$WARN DUPLICATE_CTOR_DTOR OFF}
interface
uses
Windows, SysUtils, ExtCtrls, Generics.Defaults, Generics.Collections, Graphics,
ASSounds;
type
TTokenKind = (tkIntegerLiteral, tkFloatLiteral, tkStringLiteral, tkOperator,
tkBracket, tkComma, tkIdentifier, tkImplicitNull);
TOperator = (oUnaryPlus, oLooseUnaryPlus, oUnaryMinus, oLooseUnaryMinus, oPlus,
oMinus, oAsterisk, oSolidus, oCircumflex, oCDot, oCRing, oSqrt, oCross,
oExclamation, oQuestion, oPercent, oPermille, oDegrees, oPeriod, oBar, oAmp,
oAt, oColon, oSemicolon, oLessThan, oLessEqual, oGreaterThan, oGreaterEqual,
oEquals, oNotEquals, oApprox, oAnd, oOr, oXor, oNand, oNor, oNot, oUnion,
oIntersection, oSetDifference, oSymDiff, oComplement, oIn, oNi, oNotIn,
oNotNi, oSubset, oSubsetEq, oSubsetNEq, oSuperset, oSupersetEq, oSupersetNEq,
oDivides, oNDivides, oParallel, oNParallel, oOrthogonal, oCircledPlus,
oCircledTimes, oCircledDot, oImpliesRight, oImpliesLeft, oEquivalent, oTo,
oMapsTo, oAssign, oTilde, oNumberSignPrefix, oNumberSignPostfix, oSection,
oBackslash);
TOpKind = (okPrefix, okPostfix, okInfix);
TVersionData = record
Major,
Minor,
Release,
Build: Cardinal;
function ToString: string;
end;
const
KernelVersion: TVersionData =
(
Major: 3;
Minor: 1;
Release: 0;
Build: 0
);
type
EKernelException = class(Exception);
EAlgosimObjectException = class(EKernelException);
EArrayException = class(EAlgosimObjectException);
EStructureException = class(EAlgosimObjectException);
ESetException = class(EAlgosimObjectException);
EAlgosimOSError = class(EKernelException);
EExpressionException = class(EKernelException);
ESyntaxException = class(EExpressionException);
EParseException = class(EExpressionException);
ERuntimeException = class(EExpressionException)
strict private
FSource: TList<TClass>;
public
constructor Create(const AReason: string; ASource: TList<TClass> = nil);
destructor Destroy; override;
property
Source: TList<TClass> read FSource write FSource;
end;
EInvArgs = class(ERuntimeException);
EUnknownIdentifier = class(ERuntimeException);
EInvalidIdentName = class(ERuntimeException);
EIllegalLValue = class(ERuntimeException);
ETooDeepRecursion = class(ERuntimeException);
EManualAbort = class(ERuntimeException);
EVariableException = class(EKernelException);
EVariableProtectionException = class(EVariableException);
EPropStoreException = class(EKernelException);
EBufferException = class(EKernelException);
EObjStoreLocked = class(EKernelException);
EClientRequestException = class(EKernelException);
EClientVisualizationError = class(EClientRequestException);
TIdentAttrib = (iaProtected, iaSystem);
TIdentAttribs = set of TIdentAttrib;
const
MAX_EXPR_DEPTH = 255;
MAX_RECURSE_DEPTH = 1023;
resourcestring
SUniverseNotASet = 'The universe is not a set, but an object of type %s.';
SUnknownFileExt = 'Unknown file extension: "%s".';
SEmptyBracket = 'Empty bracket at column %d.';
SAdjValues = 'Adjacent values at column %d; a comma or operator was expected.';
SNothingBeforeComma = 'Value missing before comma at column %d.';
SNothingAfterComma = 'Value missing after comma at column %d.';
SNoLeftOperand = 'Operand missing before operator %s at column %d.';
SNoRightOperand = 'Operand missing after operator %s at column %d.';
SInvalidNumLit = 'Invalid numeric literal "%s" starting at column %d.';
SInvNumBase = 'Invalid number base %d in numeric literal "%s" starting at column %d.';
SInvDigit = 'Invalid base-%d digit "%s" in numeric literal "%s" starting at column %d.';
SUnterminatedStringLiteral = 'Unterminated string literal "%s" starting at column %d.';
SNegativeBracketLevel = 'Negative bracket level starting at column %d.';
SWrongBracket = 'Closing bracket %s at column %d doesn''t match the most recent opening bracket %s at column %d.';
SOpenBracketAtEOE = 'There is at least one open bracket at the end of the expression. The following brackets are open: "%s".';
SInternalError = 'Internal error.';
SWrongArgCount = '%d argument(s) expected, but %d given.';
STooFewArgs = 'At least %d argument(s) required.';
SWrongArgCountUnspec = 'There is no version of this function that can take %d argument(s).';
SInvalidArguments = 'Invalid function arguments.';
SInvArgClass = 'An object of type %s was expected as argument %d, but an object of type %s was given.';
SNotAllArgsAre = 'This function requires that all arguments are of type %s, but ' +
'the given argument at index %d is of type %s.';
SNoFunctionObj = 'No function object assigned to custom function.';
SASymbolWasExpected = 'A symbol was expected as argument %d.';
SUnknownIdentifier = 'Unknown identifier "%s".';
SNoCopyConstructor = 'No copy constructor for object of type "%s".';
SObjectTypeHasNoCopyConstrForType = 'Object type "%s" has no copy construc' +
'tor for object type "%s".';
SNoMaxLen = 'An object of type "%s" has no maximum display length setting.';
SArrayElementIsNil = 'Element with index %d is nil.';
SArrayCannotInsertNil = 'Cannot insert nil into array.';
SIndexOutOfBounds = 'Index %d out of bounds.';
SIndexOutOfBounds2D = 'Index (%d, %d) out of bounds.';
SNewLengthMustBeNonNegative = 'New length must be non-negative.';
SStructAlreadyHasMember = 'The structure already contains a member named "' +
'%s".';
SCannotAlterTypedStruct = 'Cannot alter member arrangement in a typed stru' +
'cture.';
SStructNameValCountMismatch = 'The number of member names must equal the n' +
'umber of member values.';
SStructNoMemberFound = 'There is no member named "%s".';
SNamedStructNoMemberFound = 'Structure "%s" has no member named "%s".';
SMemberValueIsNil = 'Member value is nil.';
SStructInvalidMemberName = 'Invalid member name: "%s".';
SStructTooManyMembers = 'Too many members (%d) for structure type %s with ' +
'%d member(s).';
SStructMemberNotInType = 'Structure type "%s" does not contain a member name' +
'd "%s".';
SUnsupportedSignalType = 'Unsupported signal object type %d.';
SInvalidObjectTypeInUnion = 'Invalid object type(s) in union.';
SInvalidObjectTypeInIntersection = 'Invalid object type(s) in intersection.';
SStructureOfType = 'structure of type "%s"';
SInvalidGroupSize = 'Invalid group size %d.';
SCannotTransposeNonMatrix = 'Cannot transpose an array that is not shaped ' +
'as a matrix.';
SObjectNoContainer = 'Object type "%s" is not a suitable container.';
SObjectNoPlanarValueContainer = 'Object type "%s" is not a container that ' +
'can be indexed by two integers.';
SCannotFindMaxNonSpecific = 'Cannot find the largest value in this list.';
SCannotFindMaximumEmpty = 'Cannot find the largest value in an empty list.';
SCannotFindMax = 'Cannot find the largest number in an object of type "%s".';
SCannotFindMinNonSpecific = 'Cannot find the smallest value in this list.';
SCannotFindMinimumEmpty = 'Cannot find the smallest value in an empty list.';
SCannotFindMin = 'Cannot find the smallest number in an object of type "%s".';
SCannotComputeSumOfUnknownType = 'Cannot compute sum of zero objects of un' +
'known type.';
SCannotComputeSumOfContainer = 'Cannot compute sum of this container.';
SCannotComputeSumOfObject = 'Cannot compute sum of this object.';
SCannotComputeProductOfUnknownType = 'Cannot compute product of zero objects ' +
'of unknown type.';
SCannotComputeProductOfContainer = 'Cannot compute product of this container.';
SCannotComputeProductOfObject = 'Cannot compute product of this object.';
SCannotExtractPart = 'Cannot extract part of an object of type "%s".';
SCannotExtractPart2d = 'Cannot extract two-dimensional part of an object of type "%s".';
SCannotCountElements = 'Cannot count elements in an object of type "%s".';
SCannotAccumulateElements = 'Cannot accumulate elements in an object of type "%s".';
SCannotFilter = 'Cannot filter elements in an object of type "%s".';
SCannotApply = 'Cannot apply function to elements in an object of type "%s".';
SCannotReplace = 'Cannot replace elements in an object of type "%s".';
SCannotRemove = 'Cannot remove elements from an object of type "%s".';
SUnsupportedSubscriptOp = 'Unsupported subscript operation.';
SCannotComputeUnaryMinus = 'Cannot compute unary minus of an object of typ' +
'e "%s".';
SCannotComputeImgPart = 'Cannot compute imaginary part of an object of typ' +
'e "%s".';
SCannotComputeRePart = 'Cannot compute real part of an object of type "%s".';
SCannotDetermineSign = 'Cannot determine the sign of an object of type "%s".';
SCannotComputeAbs = 'Cannot compute absolute value or modulus of an object ' +
'of type "%s".';
SCannotSquare = 'Cannot compute square of an object of type "%s".';
SCannotComputeNorm = 'Cannot compute %s of an object of type "%s".';
SCannotNormSquare = 'Cannot compute norm square of an object of type "%s".';
SCannotInvert = 'Cannot invert an object of type "%s".';
SCannotTranspose = 'Cannot transpose an object of type "%s".';
SCannotConjTranspose = 'Cannot conjugate transpose an object of type "%s".';
SCannotScale = 'Cannot scale an object of type "%s".';
SCannotComputeAvg = 'Cannot compute mean of an object of type "%s".';
SCannotComputeAvgNonSpecific = 'Cannot compute mean of this object.';
SCannotComputeAvgEmptyList = 'Cannot compute the mean of an empty list.';
SUnknownNormType = 'Unknown norm type "%s".';
SInvalidSDDKind = 'Invalid SDD kind.';
SPredicateDidntReturnBool = 'The predicate was expected to return a boolea' +
'n, but an object of type %s was returned.';
SComparerDidntReturnReal = 'The comparer was expected to return a real number, ' +
'but an object of type %s was returned.';
SCharApply = 'Character application function must return a single character.';
SStringApply = 'String application function must return a string.';
SRealNumberApply = 'Real number application function must return a real ' +
'number.';
SComplexNumberApply = 'Complex number application function must return a complex ' +
'number.';
SColorApply = 'Colour application function must return a colour.';
SConvComplexReal = 'Complex number %s cannot be converted to a real number.';
SConvStrRealNum = 'Cannot convert string "%s" to a real number.';
SConvStrComplexNum = 'Cannot convert string "%s" to a complex number.';
SConvContNumber = 'A container with more than a single value cannot be con' +
'verted to a number.';
SConvEmptyContNumber = 'An empty container cannot be converted to a number.';
SConvObjRealNum = 'An object of type %s cannot be converted to a real number.';
SConvObjComplexNum = 'An object of type %s cannot be converted to a complex ' +
'number.';
SComplexVectToReal = 'Complex vector cannot be converted to real vector be' +
'cause it contains a non-real component %s.';
SComplexMatToRealVect = 'Complex matrix cannot be converted to real vector be' +
'cause it contains a non-real component %s.';
SConvRealVect = 'An object of type "%s" cannot be converted to a real vector.';
SConvComplexVect = 'An object of type "%s" cannot be converted to a complex v' +
'ector.';
SConvRealMat = 'An object of type "%s" cannot be converted to a real matrix.';
SComplexVectToRealMatrix = 'Complex vector cannot be converted to real matrix be' +
'cause it contains a non-real component %s.';
SComplexMatToReal = 'Complex matrix cannot be converted to real matrix be' +
'cause it contains a non-real component %s.';
SConvComplexMat = 'An object of type "%s" cannot be converted to a complex matrix.';
SConvChar = 'An object of type "%s" cannot be converted to a character.';
SConvStrCharLen = 'A string of length %d cannot be converted to a character.';
SConvStrBool = 'String "%s" cannot be converted to a boolean.';
SConvColor = 'An object of type "%s" cannot be converted to a colour.';
SConvNonIntColor = 'A number which isn''t a 32-bit integer cannot be converted to ' +
'a colour.';
SVectDim = 'A vector must have dimension at least one.';
SMatDim = 'A matrix must have size at least 1×1.';
SVarProtectionError = 'Cannot modify or delete protected variable "%s".';
SNoPropInStore = 'There is no property named "%s" in store "%s".';
SNoSubstoreInStore = 'There is no substore named "%s" in store "%s".';
SObjectNotAStructure = 'Object "%s" is not a structure.';
SUnassignedLValueData = 'Unassigned lvalue data.';
SEmptyLValueData = 'Empty lvalue data.';
SInvalidLValueDataRoot = 'Invalid lvalue data root.';
SSetStringSubscriptNoChar = 'A character was expected, but an object of type "%s" given, when ' +
'setting a character in a string.';
SSetRVectSubscriptNoRNum = 'A real number was expected, but an object of type "%s" given, when ' +
'setting a component in a real vector.';
SSetCVectSubscriptNoNum = 'A real or complex number was expected, but an object of type "%s" given, when ' +
'setting a component in a complex vector.';
SSetRMatSubscriptNoRNum = 'A real number was expected, but an object of type "%s" given, when ' +
'setting an entry in a real matrix.';
SSetCMatSubscriptNoNum = 'A real or complex number was expected, but an object of type "%s" given, when ' +
'setting an entry in a complex matrix.';
SSetPixmapSubscriptNoColor = 'A colour was expected, but an object of type "%s" given, when setting a ' +
'pixel in a pixmap.';
SSetTableSubscriptNoString = 'A string was expected, but an object of type "%s" given, when setting a ' +
'cell in a table.';
SSetBinarySubscriptNoByte = 'A byte was expected, but an object of type "%s" given, when setting a ' +
'byte in stream of bytes.';
SInvalidIdentName = 'Invalid identifier name "%s".';
SCannotRotate = 'An object of type "%s" cannot be rotated.';
SCannotSort = 'An object of type "%s" cannot be sorted using this type of comparer.';
SCannotShuffle = 'An object of type "%s" cannot be shuffled.';
SCannotReverse = 'An object of type "%s" cannot be reversed.';
SCannotConstructUnique = 'Cannot remove duplicates from an object of type "%s".';
SCannotConstructUniqueFromSorted = 'Cannot remove adjacent duplicates from an object of type "%s".';
SCannotConstructFreq = 'Cannot compute member frequencies in an object of type "%s".';
SCannotConstructFreqAdj = 'Cannot compute adjacent member counts in an object of type "%s".';
SUnknownComparer = 'Unknown comparison method "%s".';
SLeftSideCannotBeAssignedTo = 'Left side cannot be assigned to.';
SExprNodeChildren = 'An expression node must only have expression node children.';
SExprNodeTree = 'Cannot insert expression node in a tree which is not an expression.';
SNoStandaloneNode = 'Cannot create a stand-alone tree node.';
SExpressionTreeNodes = 'An expression tree can only have expression nodes.';
SUnknownStructType = 'Unknown structure type "%s".';
SStructTypeAlreadyRegistered = 'There already is a registered structure type named "%s".';
SCannotUnregisterKernelType = 'Cannot unregister kernel structure type "%s".';
STooFewArguments = 'Too few arguments. A required argument of type %s is missing.';
STooManyArguments = 'Too many arguments.';
SArgNotNonNegInt = 'A non-negative integer was expected as argument %d, but "%s" was given.';
SArgNotPosInt = 'A positive integer was expected as argument %d, but "%s" was given.';
SArgNotNonNegReal = 'A non-negative real number was expected as argument %d, but "%s" was given.';
SArgNotPosReal = 'A positive real number was expected as argument %d, but "%s" was given.';
SInvPointList = 'Invalid point list.';
SArgNotChr = 'A character was expected as argument %d, but "%s" was given.';
SArgNotMatchingStruct = 'The structure in argument %d must be of type %s.';
SIntTypeToSmall = 'Cannot represent this %d-bit integer value as a %d-bit value.';
SObjNoDBitInt = 'Object cannot be represented as a %d-bit integer.';
SObjNoRat = 'Object isn''t a rational number.';
SObjNoFloat = 'Object isn''t a real number.';
SObjNoComplex = 'Object isn''t a complex number.';
SCmplxNoOrder = 'Complex numbers have no order.';
SNoIntPointList = 'A list or set of integer points was expected as argument %d.';
SConvBlob = 'An object of type "%s" cannot be converted to a binary object.';
SUnknownClassType = 'Unknown class type: "%s".';
SSetFromBlob = 'An object of type "%s" cannot be set using binary data.';
SInvalidBlob = 'Invalid binary data for object of type "%s".';
SObjectStoreStackEmpty = 'The object store stack is empty.';
SCannotCloneRootlessExpression = 'Cannot clone a rootless expression.';
SVectPlanarExtentWidth = 'A vector must be a single column.';
SSpecValWrongLength2D = 'Cannot populate a %d×%d array with a list of %d values.';
SNamedBufferNotFound = 'There is no output buffer named "%s".';
SInvalidBufferName = 'Invalid buffer name "%s".';
SUserCanceled = 'The operation was cancelled by the user.';
SInvNumberBase = 'Invalid number base %d.';
SInvNumDigits = 'Invalid number of digits %d.';
SInvDigGrSize = 'Invalid digit grouping size %d.';
SInvMinLen = 'Invalid minimum length %d.';
SCannotConvertNon2DListToMatrix = 'Cannot convert a list which is not 2D to a matrix.';
SExpressionTooDeep = 'Expression is too deep.';
STooDeepRecursion = 'Too deep recursion.';
var
DefaultFormatSettings: TFormatSettings;
function IsValidIdent(const AName: string): Boolean;
procedure CheckIdentName(const AName: string); inline;
procedure ErrInternal; inline;
procedure ErrInvalidArguments; inline;
function BytesToString(const ABytes: TBytes): string; overload; inline;
function BytesToString(ABuf: PByte; ALen: Cardinal): string; overload;
function LinkerTimestamp: TDateTime;
function IndexChr(const AChr: Char; AValues: array of Char): Integer;
function IndexInt(const AInt: Integer; AValues: array of Integer): Integer;
procedure RestartTimer(ATimer: TTimer);
function UnicodeSuperscript(const AChar: Char): Char;
function UnicodeSubscript(const AChar: Char): Char;
function UnicodeCircled(const AChar: Char): Char;
function UnicodeParenthesized(const AChar: Char): Char;
function UnicodeFullStop(const AChar: Char): Char;
function UnicodeDoublyCircled(const AChar: Char): Char;
function IntToPrettyStr(AValue: Integer): string;
type
TReadOnlyPromise = (I_Will_Not_Modify_The_Object = 7);
TResKind = (rkText, rkBitmap, rkSound, rkModel);
TResInfo = record
ResKind: TResKind;
ResName: string;
Meta: string;
end;
function ResLookup(const AName: string): TResInfo;
function LoadResBitmap(const AName: string): TBitmap;
function LoadResSound(const AName: string): TASSound;
function LoadResString(const AName: string): string;
function LoadCompressedResString(const AName: string): string;
function LoadResLicense(const AName: string): string;
function BlockCombineStrings(const AStrings: array of string;
AMaxWidth, ASpaceCount: Integer): string;
const
KernelFPUCW = Word($1332);
implementation
uses
Classes, Math, Character, Zip;
function IsValidIdent(const AName: string): Boolean;
var
i: Integer;
begin
Result := (AName.Length > 0) and AName[1].IsLetter;
if Result then
for i := 2 to AName.Length do
if not AName[i].IsLetterOrDigit then
Exit(False);
end;
procedure CheckIdentName(const AName: string);
begin
if not IsValidIdent(AName) then
raise EInvalidIdentName.CreateFmt(SInvalidIdentName, [AName]);
end;
procedure ErrInternal;
begin
raise EKernelException.Create(SInternalError);
end;
procedure ErrInvalidArguments;
begin
raise EInvArgs.Create(SInvalidArguments);
end;
function BytesToString(const ABytes: TBytes): string;
begin
Result := BytesToString(PByte(ABytes), Length(ABytes));
end;
function BytesToString(ABuf: PByte; ALen: Cardinal): string;
const
HexDigits: array[0..$F] of Char = '0123456789ABCDEF';
var
i: Integer;
begin
if ALen = 0 then
Exit('');
SetLength(Result, 3 * ALen - 1);
Result[1] := HexDigits[ABuf[0] shr 4];
Result[2] := HexDigits[ABuf[0] and $0F];
for i := 1 to ALen - 1 do
begin
Result[3*i + 0] := ' ';
Result[3*i + 1] := HexDigits[ABuf[i] shr 4];
Result[3*i + 2] := HexDigits[ABuf[i] and $0F];
end;
end;
function LinkerTimestamp: TDateTime;
begin
Result := PImageNtHeaders(HInstance + Cardinal(PImageDosHeader(HInstance)^._lfanew))^.FileHeader.TimeDateStamp / SecsPerDay + UnixDateDelta;
end;
function IndexChr(const AChr: Char; AValues: array of Char): Integer;
var
i: Integer;
begin
for i := 0 to High(AValues) do
if AChr = AValues[i] then
Exit(i);
Result := -1;
end;
function IndexInt(const AInt: Integer; AValues: array of Integer): Integer;
var
i: Integer;
begin
for i := 0 to High(AValues) do
if AInt = AValues[i] then
Exit(i);
Result := -1;
end;
procedure RestartTimer(ATimer: TTimer);
begin
if ATimer = nil then
Exit;
ATimer.Enabled := False;
ATimer.Enabled := True;
end;
function UnicodeSuperscript(const AChar: Char): Char;
begin
Result := AChar;
case AChar of
'0':
Result := '⁰';
'1':
Result := '¹';
'2':
Result := '²';
'3':
Result := '³';
'4':
Result := '⁴';
'5':
Result := '⁵';
'6':
Result := '⁶';
'7':
Result := '⁷';
'8':
Result := '⁸';
'9':
Result := '⁹';
'+':
Result := '⁺';
'-', '−':
Result := '⁻';
'=':
Result := '⁼';
'(':
Result := '⁽';
')':
Result := '⁾';
'n':
Result := 'ⁿ';
end;
end;
function UnicodeSubscript(const AChar: Char): Char;
begin
Result := AChar;
case AChar of
'0':
Result := '₀';
'1':
Result := '₁';
'2':
Result := '₂';
'3':
Result := '₃';
'4':
Result := '₄';
'5':
Result := '₅';
'6':
Result := '₆';
'7':
Result := '₇';
'8':
Result := '₈';
'9':
Result := '₉';
'+':
Result := '₊';
'-', '−':
Result := '₋';
'=':
Result := '₌';
'(':
Result := '₍';
')':
Result := '₎';
end;
end;
function UnicodeCircled(const AChar: Char): Char;
begin
Result := AChar;
if InRange(Ord(AChar), Ord('A'), Ord('Z')) then
Result := Chr($24B6 + Ord(AChar) - Ord('A'))
else if InRange(Ord(AChar), Ord('a'), Ord('z')) then
Result := Chr($24D0 + Ord(AChar) - Ord('a'))
else if InRange(Ord(AChar), Ord('1'), Ord('9')) then
Result := Chr($2460 + Ord(AChar) - Ord('1'))
else if AChar = '0' then
Result := #$24EA;
end;
function UnicodeParenthesized(const AChar: Char): Char;
begin
Result := AChar;
if InRange(Ord(AChar), Ord('a'), Ord('z')) then
Result := Chr($249C + Ord(AChar) - Ord('a'))
else if InRange(Ord(AChar), Ord('1'), Ord('9')) then
Result := Chr($2474 + Ord(AChar) - Ord('1'))
end;
function UnicodeFullStop(const AChar: Char): Char;
begin
Result := AChar;
if InRange(Ord(AChar), Ord('1'), Ord('9')) then
Result := Chr($2488 + Ord(AChar) - Ord('1'))
end;
function UnicodeDoublyCircled(const AChar: Char): Char;
begin
Result := AChar;
if InRange(Ord(AChar), Ord('1'), Ord('9')) then
Result := Chr($24F5 + Ord(AChar) - Ord('1'))
end;
constructor ERuntimeException.Create(const AReason: string;
ASource: TList<TClass>);
var
i: Integer;
begin
inherited Create(AReason);
if Assigned(ASource) then
begin
FSource := TList<TClass>.Create;
FSource.Capacity := ASource.Count;
for i := 0 to ASource.Count - 1 do
FSource.Add(ASource[i]);
end;
end;
destructor ERuntimeException.Destroy;
begin
FreeAndNil(FSource);
inherited;
end;
var
PrettyIntFS: TFormatSettings;
function IntToPrettyStr(AValue: Integer): string;
begin
Result := Format('%.0n', [Double(AValue)], PrettyIntFS);
end;
function ResLookup(const AName: string): TResInfo;
var
s, r: string;
c: TArray<string>;
begin
s := LoadResString('residx');
for r in s.Split([sLineBreak]) do
begin
c := r.Split([#9]);
if Length(c) >= 4 then
if SameText(c[0], AName) then
begin
if SameText(c[1], 'text') then
Result.ResKind := rkText
else if SameText(c[1], 'bitmap') then
Result.ResKind := rkBitmap
else if SameText(c[1], 'sound') then
Result.ResKind := rkSound
else if SameText(c[1], 'model') then
Result.ResKind := rkModel
else
raise Exception.Create('Unsupported resource type.');
Result.ResName := c[2];
Result.Meta := c[3];
Exit;
end;
end;
raise Exception.CreateFmt('Resource "%s" not found.', [AName]);
end;
function LoadResBitmap(const AName: string): TBitmap;
var
h: NativeUInt;
begin
h := LoadLibrary('asres.dll');
if h = 0 then
RaiseLastOSError;
try
Result := TBitmap.Create;
try
Result.LoadFromResourceName(h, AName);
except
Result.Free;
raise;
end;
finally
FreeLibrary(h);
end;
end;
function LoadResSound(const AName: string): TASSound;
var
h: NativeUInt;
rs: TResourceStream;
begin
h := LoadLibrary('asres.dll');
if h = 0 then
RaiseLastOSError;
try
rs := TResourceStream.Create(h, AName, RT_RCDATA);
try
Result := LoadSoundFromStream(rs);
finally
rs.Free;
end;
finally
FreeLibrary(h);
end;
end;
function LoadResString(const AName: string): string;
var
h: NativeUInt;
rs: TResourceStream;
ss: TStringStream;
begin
h := LoadLibrary('asres.dll');
if h = 0 then
RaiseLastOSError;
try
rs := TResourceStream.Create(h, AName, RT_RCDATA);
try
ss := TStringStream.Create('', TEncoding.UTF8);
try
ss.CopyFrom(rs, rs.Size);
Result := ss.DataString;
finally
ss.Free;
end;
finally
rs.Free;
end;
finally
FreeLibrary(h);
end;
end;
function LoadCompressedResString(const AName: string): string;
begin
var h := LoadLibrary('asres.dll');
if h = 0 then
RaiseLastOSError;
try
var rs := TResourceStream.Create(h, AName, RT_RCDATA);
try
var ss := TStringStream.Create('', TEncoding.UTF8);
try
var z := TZipFile.Create;
try
z.Open(rs, zmRead);
var zh := Default(TZipHeader);
var zs := TStream(nil);
try
z.Read(0, zs, zh);
ss.CopyFrom(zs, zs.Size)
finally
zs.Free;
end;
Result := ss.DataString;
finally
z.Free;
end;
finally
ss.Free;
end;
finally
rs.Free;
end;
finally
FreeLibrary(h);
end;
end;
function LoadResLicense(const AName: string): string;
begin
Result := ResLookup(AName).Meta;
end;
function BlockCombineStrings(const AStrings: array of string;
AMaxWidth, ASpaceCount: Integer): string;
var
Lines: TArray<TArray<string>>;
Widths: TArray<Integer>;
Tops: TArray<Integer>;
LastWritten: Integer;
x, i, j: Integer;
LineCount: Integer;
OutputLines: TStringList;
procedure FinalizeRow(ALastIndex: Integer);
var
k, l: Integer;
s, line: string;
begin
for k := Succ(LastWritten) to ALastIndex do
Tops[k] := (LineCount - Length(Lines[k])) div 2;
for k := 0 to LineCount - 1 do
begin
line := '';
for l := Succ(LastWritten) to ALastIndex do
begin
if InRange(k, Tops[l], Tops[l] + High(Lines[l])) then
s := Lines[l][k - Tops[l]]
else
s := '';
if s.Length < Widths[l] then
s := s + StringOfChar(#32, Widths[l] - s.Length);
line := line + s;
end;
OutputLines.Add(line);
end;
x := 0;
LineCount := 0;
LastWritten := ALastIndex;
OutputLines.Add('');
end;
begin
SetLength(Lines, Length(AStrings));
SetLength(Widths, Length(AStrings));
SetLength(Tops, Length(AStrings));
OutputLines := TStringList.Create;
try
x := 0;
LineCount := 0;
LastWritten := -1;
for i := 0 to High(AStrings) do
begin
Lines[i] := AStrings[i].Split([sLineBreak]);
for j := 0 to High(Lines[i]) do
if Lines[i][j].Length > Widths[i] then
Widths[i] := Lines[i][j].Length;
if x + Widths[i] > AMaxWidth then
FinalizeRow(Pred(i));
if Length(Lines[i]) > LineCount then
LineCount := Length(Lines[i]);
if i < High(AStrings) then
Inc(Widths[i], ASpaceCount);
Inc(x, Widths[i]);
end;
FinalizeRow(High(AStrings));
Result := OutputLines.Text;
finally
OutputLines.Free;
end;
end;
function TVersionData.ToString: string;
begin
Result := Format('%d.%d.%d.%d', [Major, Minor, Release, Build]);
end;
initialization
DefaultFormatSettings := TFormatSettings.Create(1033);
PrettyIntFS := TFormatSettings.Invariant;
PrettyIntFS.ThousandSeparator := #32;
end.