开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > 游戏 > 游戏引擎 > 查看源码
Basics.pas
资源名称：CAST2SDK.rar　[点击查看]
上传用户：yj_qiu
上传日期：2022-08-08
资源大小：23636k
文件大小：60k
源码类别：

游戏引擎

开发平台：

Delphi

Basics.pas：源码内容
  1. (*
  2.  @Abstract(Basic utilities unit)
  3.  (C) 2003-2007 George "Mirage" Bakhtadze. <a href="http://www.casteng.com">www.casteng.com</a> <br>
  4.  The source code may be used under either MPL 1.1 or LGPL 2.1 license. See included license.txt file <br>
  5.  Unit contains basic utilities, constants and types
  6. *)
  7. {$Include GDefines.inc}
  8. unit Basics;
  10. interface
  12. uses BaseMsg, BaseTypes, SysUtils;
  14. const
  15.   GeneralDecimalSeparator: Char = '.';
  17.   // Minimum capacity of reference counted container
  18.   MinRefCContainerLength = 8;
  19.   // Delimiter which separate strings in enumerations
  20.   StringDelimiter = '&';
  21.   // Short alias for StringDelimiter
  22.   StrDelim = StringDelimiter;
  24. //  feOK = 0; feNotFound = -1; feCannotRead = -2; feCannotWrite = -3; feInvalidFileFormat = -4; feCannotSeek = -5; feCannotOpen = -6;
  25.   // File usage: do not open
  26.   fuDoNotOpen = 0;
  27.   // File usage: open to read 
  28.   fuRead = 1;
  29.   // File usage: open to read and write
  30.   fuReadWrite = 2;
  31.   // File usage: open to write
  32.   fuWrite = 3;
  33.   // File usage: open to append
  34.   fuAppend = 4;
  35.   
  36.   // File sharing mode: allow all operations
  37.   smAllowAll = 0;
  38.   // File sharing mode: allow read
  39.   smAllowRead = 1;
  40.   // File sharing mode: do not allow anything (exlusive)
  41.   smExclusive = 2;
  43.   // 1.0 in integer representation
  44.   OneAsInt: LongWord = $3F800000;
  45.   OneAsInt2: LongWord = $3F800000 shl 1;
  46.   OneOver100 = 1/100;
  48.     // Pixel formats
  49.   // Number of supported pixel formats
  50.   TotalPixelFormats = 32;
  51.   pfUndefined    = 0;  pfR8G8B8   = 1;  pfA8R8G8B8 = 2;  pfX8R8G8B8 = 3;
  52.   pfR5G6B5       = 4;  pfX1R5G5B5 = 5;  pfA1R5G5B5 = 6;  pfA4R4G4B4 = 7;
  53.   pfA8           = 8;  pfX4R4G4B4 = 9;  pfA8P8     = 10; pfP8       = 11; pfL8     = 12; pfA8L8      = 13; pfA4L4 = 14;
  54.   pfV8U8         = 15; pfL6V5U5   = 16; pfX8L8V8U8 = 17; pfQ8W8V8U8 = 18; pfV16U16 = 19; pfW11V11U10 = 20;
  55.   pfD16_LOCKABLE = 21; pfD32      = 22; pfD15S1    = 23; pfD24S8    = 24; pfD16    = 25; pfD24X8     = 26; pfD24X4S4 = 27;
  56.   pfB8G8R8       = 28; pfA8B8G8R8 = 29;
  57.   pfATIDF16      = 30; pfATIDF24  = 31;
  58.   pfAuto         = $FFFFFFFF;
  60.   PixelFormatsEnum = 'Undefined&R8G8B8&A8R8G8B8&X8R8G8B8&' +
  61.                      'R5G6B5&X1R5G5B5&A1R5G5B5&A4R4G4B4&' +
  62.                      'A8&X4R4G4B4&A8P8&P8&L8&A8L8&A4L4&' +
  63.                      'V8U8&L6V5U5&X8L8V8U8&Q8W8V8U8&V16U16&W11V11U10&' +
  64.                      'D16(Lockable)&D32&D15S1&D24S8&D16&D24X8&D24X4S4&' +
  65.                      'B8G8R8&A8B8G8R8&' +
  66.                      'ATI_DF16&ATI_DF24';
  68.   OneOver255 = 1/255;
  69.   // IDF file format constants
  70.   icNone = 0; icRLE = 1; icLZW = 2; icHuffman = 3; icWavelet = 4;
  71.   IDFSignature = 'IDF';
  73. type
  74.   // IDF file header (deprecated)
  75.   TIDFHeader = record
  76.     Signature: array[0..2] of AnsiChar;
  77.     Compression, PixelFormat, MipLevels, Width, Height: Cardinal;
  78.   end;
  80.   // @Abstract(Base error class)
  81.   TError = class(TMessage)
  82.     // Error message text
  83.     ErrorMessage: string;
  84.     constructor Create(AErrorMessage: string);
  85.     // This function used as default error handler
  86.     function DefaultErrorHandler(const Error: TError): Boolean;
  87.   end;
  89.   { Error handler delegate. When an error occurs a delegate of this type is called (See @Link(ErrorHandler)).
  90.     If it returns @True the application should try to continue the operation which caused the error. }
  91.   TErrorHandler = function(const Error: TError): Boolean of object;
  93.   // Error class for streaming operations
  94.   TStreamError = class(TError)
  95.   end;
  96.   // Error class for invalid format errors
  97.   TInvalidFormat = class(TError)
  98.   end;
  99.   // Error class for invalid argument errors
  100.   TInvalidArgument = class(TError)
  101.   end;
  102.   // Error class for file operations
  103.   TFileError = class(TError)
  104.   end;
  106.   // A delegate with file name
  107.   TFileDelegate          = function(const FileName: string): Boolean of object;
  108.   // A delegate for string comparison
  109.   TStringCompareDelegate = function(const s1, s2: string): Integer of object;
  111.   { @Abstract(Reference-counted container of temporary objects and memory buffers )
  112.     Create an instance with @Link(CreateRefcountedContainer). The container can be used to accumulate temporary objects and buffers.
  113.     When no more references points to the container it destroys itself and all accumulated objects and buffers. }
  114.   IRefcountedContainer = interface
  115.     // Adds an object instance
  116.     function AddObject(Obj: TObject): TObject;
  117.     // Adds a memory buffer
  118.     function AddPointer(Ptr: Pointer): Pointer;
  119.     // Adds an array of object instances
  120.     procedure AddObjects(Objs: array of TObject);
  121.     // Adds an array of memory buffers
  122.     procedure AddPointers(Ptrs: array of Pointer);
  123.   end;
  125.   { @Abstract(Base class for streams)
  126.     Streams can read from and/or write to files (including text ones), memory, etc }
  127.   TStream = class
  128.   private
  129.     FPosition, FSize: Cardinal;
  130.     procedure SetPosition(const Value: Cardinal);
  131.   protected
  132.     // Changes current size of the stream
  133.     procedure SetSize(const Value: Cardinal); virtual;
  134.   public
  135.     // Changes the current position of the stream (if such changes are supported by particular stream class)
  136.     function Seek(const NewPos: Cardinal): Boolean; virtual;
  137.     // Reads <b>Count</b> bytes from the stream to <b>Buffer</b>, moves current position forward for number of bytes read and returns this number
  138.     function Read(out Buffer; const Count: Cardinal): Cardinal; virtual; abstract;
  139.     // Reads <b>Count</b> bytes from the stream to <b>Buffer</b>, moves current position forward for number of bytes read and returns @True if success
  140.     function ReadCheck(out Buffer; const Count: Cardinal): Boolean;
  141.     // Writes <b>Count</b> bytes from <b>Buffer</b> to the stream, moves current position forward for the number of bytes written and returns this number
  142.     function Write(const Buffer; const Count: Cardinal): Cardinal; virtual; abstract;
  143.     // Writes <b>Count</b> bytes from <b>Buffer</b> to the stream, moves current position forward for the number of bytes written and returns @True if success
  144.     function WriteCheck(const Buffer; const Count: Cardinal): Boolean;
  146.     // Current size of the stream in bytes
  147.     property Size: Cardinal read FSize write SetSize;
  148.     // Current position within the stream in bytes
  149.     property Position: Cardinal read FPosition write SetPosition;
  150.   end;
  152.   { @Abstract(File stream class)
  153.     Provides streaming implementation for binary files }
  154.   TFileStream = class(TStream)
  155.   private
  156.     Opened: Boolean;
  157.     FFileName: string;
  158.     F: file;
  159.   protected
  160.     // Changes current size of the stream
  161.     procedure SetSize(const Value: Cardinal); override;
  162.   public
  163.     // Creates a file stream associating it with file with the given file name
  164.     constructor Create(const AFileName: string; const Usage: Integer = fuReadWrite; const ShareMode: Integer = smAllowAll);
  165.     destructor Destroy; override;
  166.     // Open file with the specified usage and sharing mode
  167.     function Open(const Usage: Integer; const ShareMode: Integer): Boolean;
  168.     // Close file
  169.     procedure Close;
  170.     function Seek(const NewPos: Cardinal): Boolean; override;
  171.     function Read(out Buffer; const Count: Cardinal): Cardinal; override;
  172.     function Write(const Buffer; const Count: Cardinal): Cardinal; override;
  174.     // Associated file name
  175.     property Filename: string read FFileName;
  176.   end;
  178.   { @Abstract(Memory stream class)
  179.     Provides streaming implementation for buffers in memory }
  180.   TMemoryStream = class(TStream)
  181.   private
  182.     FData: Pointer;
  183.     FCapacity: Cardinal;
  184.     procedure SetCapacity(const NewCapacity: Cardinal);
  185.     procedure Allocate(const NewSize: Cardinal);
  186.   protected
  187.     // Changes current size of the stream
  188.     procedure SetSize(const Value: Cardinal); override;
  189. //    property Capacity: Cardinal read FCapacity;
  190.   public
  191.     // Creates a memory stream of the specified size associating it with the specified address in memory
  192.     constructor Create(AData: Pointer; const ASize: Cardinal);
  193.     destructor Destroy; override;
  194.     function Read(out Buffer; const Count: Cardinal): Cardinal; override;
  195.     function Write(const Buffer; const Count: Cardinal): Cardinal; override;
  197.     // Pointer to buffer in memory
  198.     property Data: Pointer read FData;
  199.   end;
  201.   { @Abstract(Non-unicode string stream class)
  202.     Provides streaming implementation for non-unicode strings }
  203.   TAnsiStringStream = class(TStream)
  204.     // string data container
  205.     Data: AnsiString;
  206.     // Carriage return character sequence. #13#10 for Windows.
  207.     ReturnSequence: TShortName;
  208.     constructor Create(AData: Pointer; const ASize: Cardinal; const AReturnsequence: TShortName = #13#10);
  209.     function Read(out Buffer; const Count: Cardinal): Cardinal; override;
  210.     function Write(const Buffer; const Count: Cardinal): Cardinal; override;
  211.     function Readln(out Buffer: AnsiString): Integer; virtual;
  212.     function Writeln(const Buffer: AnsiString): Integer; virtual;
  213.   end;
  215.   // Random numbers generator
  216.   TRandomGenerator = class
  217.   public
  218.     constructor Create;
  219.     // Initializes the current sequence with the specified chain value and the specified seed
  220.     procedure InitSequence(Chain, Seed: Longword);
  221.     // Generate a raw random number. Fastest method
  222.     function GenerateRaw: Longword; virtual;
  223.     // Generate a floating point random number within the given range
  224.     function Rnd(Range: Single): Single;
  225.     // Generate a floating point random number within the range [-<b>Range..Range</b>]
  226.     function RndSymm(Range: Single): Single;
  227.     // Generate an integer random number within the range [0..<b>Range</b>-1]
  228.     function RndI(Range: Integer): Integer;
  229.   protected
  230.     // Seeds for sequences
  231.     RandomSeed: array of Longword;
  232.     // Chain values for sequences
  233.     RandomChain: array of Longword;
  234.     // Current sequence
  235.     FCurrentSequence: Cardinal;
  236.     // Number of sequences
  237.     procedure SetMaxSequence(AMaxSequence: Integer);
  238.     procedure SetCurrentSequence(const Value: Cardinal);
  239.   public
  240.     // Current sequence
  241.     property CurrentSequence: Cardinal read FCurrentSequence write SetCurrentSequence;
  242.   end;
  244.   // Create an instance of reference counted container
  245.   function CreateRefcountedContainer: IRefcountedContainer;
  247.     // Some math routines
  248.   //
  249.   function Sign(x: Integer): Integer; overload;
  250.   function Sign(x: Single): Single; overload;
  252.   function Ceil(const X: Single): Integer;
  253.   function Floor(const X: Single): Integer;
  255.   function IsNan(const AValue: Single): Boolean;
  256.   function MaxS(V1, V2: Single): Single;
  257.   function MinS(V1, V2: Single): Single;
  258.   function ClampS(V, Min, Max: Single): Single;
  259.   function MaxI(V1, V2: Integer): Integer;
  260.   function MinI(V1, V2: Integer): Integer;
  261.   function MaxC(V1, V2: Cardinal): Cardinal;
  262.   function MinC(V1, V2: Cardinal): Cardinal;
  263.   function ClampI(V, Min, Max: Integer): Integer;
  264.   procedure SwapI(var a, b: Integer);
  265.   function BitTest(Data: Cardinal; BitIndex: Byte): Boolean;
  266.   function InterleaveBits(x, y: Smallint): Integer;
  268.   function PtrOffs(Base: Pointer; Offset: Integer): Pointer;
  270.   // Returns color max component value
  271.   function GetColor4SIntensity(const Color: TColor4s): Single;
  273.   function VectorToColor(const v: TVector3s): TColor;
  275.   function GetColorFrom4s(const ColorS: TColor4s): TColor;
  276.   
  277.   // Returns color max component value
  278.   function GetColorIntensity(const Color: TColor): Integer;
  280.   // Returns scale color. S is desired koefficient multiplied by 256
  281.   function ScaleColorI(const Color: TColor; S: Cardinal): TColor;
  282.   function ScaleColorS(const Color: TColor; S: Single): TColor;
  283.   function AddColorW(const Color1, Color2: TColor; W1, W2: Single): TColor;
  284.   function BlendColor(const Color1, Color2: TColor; K: Single): TColor;
  286.   function IsDepthFormat(Format: Integer): Boolean;
  287.   function PixelFormatToStr(Format: Integer): AnsiString;
  289.   function GetSteppedSize(CurrentSize, Step: Integer): Integer;
  291.   function CmpMem(P1, P2: Pointer; Size: Cardinal): Boolean;
  292.   procedure MoveReverse8(Src, Dest: Pointer; Count: Integer);
  293.   procedure MoveReverse16(Src, Dest: Pointer; Count: Integer);
  295.   procedure Swap(var V1, V2);
  296.   // Fast (if SSE optimization are allowed) implementation of Trunc(x)
  297.   function FastTrunc(X: Single): Integer;
  298.   procedure SinCos(a: Single; out OSin, OCos: Single);
  299.   // Fast (if assembler optimization are allowed) implementation of Sqrt(x) with accurasy ~0.25%
  300.   function FastSqrt(x: Single): Single;
  301.   // Fast (if assembler optimization are allowed) implementation of 1/Sqrt(x)
  302.   function InvSqrt(x: Single): Single;
  303.   function Log2I(x: Integer): Integer;
  304.   function IntPower(Base: Single; Exponent: Integer): Single;
  305.   function Power(const Base, Exponent: Single): Single;
  306.   function NextPowerOf2(x: Integer): Integer;
  307.   function PosEx(const substr : AnsiString; const s : AnsiString; const start: Integer ) : Integer ;
  310.   { Splits a string into array of strings using <b>Delim</b> as a delimiter
  311.     If <b>EmptyOK</b> is @True result strings can be empty. Returns number of strings in array }
  312.   function Split(const Str, Delim: string; out Res: TStringArray; EmptyOK: Boolean): Integer;
  313.   { Splits an ansi string into array of strings using <b>Delim</b> as a delimiter
  314.     If <b>EmptyOK</b> is @True result strings can be empty. Returns number of strings in array }
  315.   function SplitA(const Str, Delim: AnsiString; out Res: TAnsiStringArray; EmptyOK: Boolean): Integer;
  317.   { Returns an enumeration string which consists of all elements of strings separated by @Link(StringDelimiter)
  318.     If <b>EmptyOK</b> is @True empty elements are included in result }
  319.   function StringsToEnumA(Strings: array of TShortName; EmptyOK: Boolean): Ansistring;
  321.   procedure RectIntersect(const ARect1, ARect2: TRect; out Result: TRect);
  322.   function GetRectIntersect(const ARect1, ARect2: TRect): TRect;
  323.   function GetCorrectRect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  324.   function IsInArea(const X, Y, X1, Y1, X2, Y2: Single): Boolean; overload;
  325.   function IsInArea(const X, Y: Single; const Area: TArea): Boolean; overload;
  327.   function GetFileName(const FileName: string): string;
  328.   procedure FillDWord(var Dest; Count: Cardinal; Value: LongWord);
  330.   function GetDefaultUVMap: TUVMap;
  332.   function CompareValues(v1, v2: Extended): Integer;
  333.   function CompareDates(ADate: TDateTime; Year, Month, Day: Integer): Integer;
  335.   function HexStrToIntDef(const s: string; Default: Longword): Longword;
  336.   function ColorStrToIntDef(const color: string; Default: Longword): Longword;
  337.   function IsDecimalInteger(const s: string): Boolean;
  338.   function IsFloat(const s: string): Boolean;                           // Tests with current decimal separator
  339.   function IsColor(const s: string): Boolean;
  341.   function IntToStrA(Value: Int64): AnsiString;
  342.   function IntToHexA(Value: Int64; Digits: Integer): AnsiString;
  343.   function FloatToStrA(Value: Extended): AnsiString;
  344.   function FormatA(const Format: string; const Args: array of const): AnsiString;
  345.   function StrToFloatDefA(const S: AnsiString; const Default: Extended): Extended;
  347.   function TrimSpacesA(ts: string): AnsiString;
  348.   function TrimSpaces(ts: string): string;
  349.   function GetLastCharPos(c: Char; const s: string): Integer;
  351.   function isSameGUID(GUID1, GUID2: TGUID): Boolean;
  352.   function GetBytesPerPixel(PixelFormat: Cardinal): Integer;
  353.   function GetBitsPerPixel(PixelFormat: Cardinal): Integer;
  355.     // Sorting via indices not affecting values itself
  356.   // Performs a quick sort on an array of strings and returns sorted indices not affecting the source array
  357.   procedure QuickSortStrInd(N: Integer; Values: TAnsiStringArray; Inds: TIndArray; Acc: Boolean);
  358.   // Performs a quick sort on an array of integers and returns sorted indices not affecting the source array
  359.   procedure QuickSortIntInd(N: Integer; Values, Inds: TIndArray; Acc: Boolean);
  360.   // Performs a quick sort on an array of floating point numbers and returns sorted indices not affecting the source array
  361.   procedure QuickSortSInd(N: Integer; Values: TSingleArray; Inds: TIndArray; Acc: Boolean);
  362.     // Sorting values
  363.   // Performs a quick sort on an array of strings
  364.   procedure QuickSortStr(N: Integer; Values: TAnsiStringArray);
  365.   // Performs a quick sort on an array of integers
  366.   procedure QuickSortInt(N: Integer; Values: TIndArray);
  367.   // Performs a quick sort on an array of floating point numbers
  368.   procedure QuickSortS(N: Integer; Values: TSingleArray);
  370.   function AssureFloatFormat(const s: string): string;
  372.   function StrFormat(const s: string; args: array of string): string;
  373.   function ExtractStr(s, Sig: string): string;
  375.   // Returns True if the spcefied character belongs to the specified set
  376.   function IsCharIn(C: AnsiChar; const CharSet: TSysCharSet): Boolean;
  378.   function IsReal(const s: string): Boolean;                            // Tests with general decimal separator
  379.   function StrToRealDef(const s: string; Default: Extended): Extended;
  380.   function RealToStr(Value: Extended): string;
  382.   // Saves a string to a stream. Returns @True if success
  383.   function SaveString(Stream: TStream; const s: AnsiString): Boolean; overload;
  384.   // Loads a string from a stream. Returns @True if success
  385.   function LoadString(Stream: TStream; out   s: AnsiString): Boolean; overload;
  386.   // Saves a wide string to a stream. Returns @True if success
  387.   function SaveString(Stream: TStream; const s: WideString): Boolean; overload;
  388.   // Loads a wide string from a stream. Returns @True if success
  389.   function LoadString(Stream: TStream; out   s: WideString): Boolean; overload;
  391.   { Calls the <b>Delegate</b> for each file passing the given mask and attribute filter and returns number of such files.
  392.     Stops if the delegate returns @False }
  393.   function ForEachFile(const PathAndMask: string; AttributeFilter: Integer; Delegate: TFileDelegate): Integer;
  395.   procedure CalcCRC32(Bytes: PByteBuffer; ByteCount: Cardinal; var CRCValue: Longword);
  397. var
  398.   { This handler caled when an error occurs. Default handler simply logs the error class.
  399.     Application can set its own handler to handle errors, raise exceptions, continue the workflow, etc.
  400.     To continue the normal workflow application's handler should call <b>Invalidate()</b> method of the error message. }
  401.   ErrorHandler: TErrorHandler;
  403.   // Key codes
  404.   //
  405.   IK_ESCAPE,
  406.   IK_1, IK_2, IK_3, IK_4, IK_5, IK_6, IK_7, IK_8, IK_9, IK_0,
  407.   IK_MINUS, IK_EQUALS, IK_BACK, IK_TAB,
  408.   IK_Q, IK_W, IK_E, IK_R, IK_T, IK_Y, IK_U, IK_I, IK_O, IK_P,
  409.   IK_LBRACKET, IK_RBRACKET,
  410.   IK_RETURN,
  411.   IK_LCONTROL,
  412.   IK_A, IK_S, IK_D, IK_F, IK_G, IK_H, IK_J, IK_K, IK_L,
  413.   IK_SEMICOLON, IK_APOSTROPHE, IK_GRAVE,
  414.   IK_LSHIFT,
  415.   IK_BACKSLASH,
  416.   IK_Z, IK_X, IK_C, IK_V, IK_B, IK_N, IK_M,
  417.   IK_COMMA, IK_PERIOD, IK_SLASH,
  418.   IK_RSHIFT,
  419.   IK_MULTIPLY,
  420.   IK_LMENU,
  421.   IK_SPACE,
  422.   IK_CAPITAL,
  423.   IK_F1, IK_F2, IK_F3, IK_F4, IK_F5, IK_F6, IK_F7, IK_F8, IK_F9, IK_F10,
  424.   IK_NUMLOCK, IK_SCROLL,
  425.   IK_NUMPAD7, IK_NUMPAD8, IK_NUMPAD9, IK_SUBTRACT, IK_NUMPAD4, IK_NUMPAD5, IK_NUMPAD6,
  426.   IK_ADD, IK_NUMPAD1, IK_NUMPAD2, IK_NUMPAD3, IK_NUMPAD0, IK_DECIMAL,
  428.   IK_OEM_102,
  429.   IK_F11, IK_F12,
  430.   IK_F13, IK_F14, IK_F15,
  431.   IK_KANA, IK_ABNT_C1,
  432.   IK_CONVERT, IK_NOCONVERT,
  433.   IK_YEN, IK_ABNT_C2,
  434.   IK_NUMPADEQUALS, IK_CIRCUMFLEX,
  435.   IK_AT, IK_COLON, IK_UNDERLINE, IK_KANJI,
  436.   IK_STOP,
  437.   IK_AX, IK_UNLABELED,
  438.   IK_NEXTTRACK,
  439.   IK_NUMPADENTER,
  440.   IK_RCONTROL,
  441.   IK_MUTE, IK_CALCULATOR, IK_PLAYPAUSE, IK_MEDIASTOP,
  442.   IK_VOLUMEDOWN, IK_VOLUMEUP,
  443.   IK_WEBHOME,
  444.   IK_NUMPADCOMMA, IK_DIVIDE,
  445.   IK_SYSRQ, IK_RMENU, IK_PAUSE,
  446.   IK_HOME, IK_UP, IK_PRIOR, IK_LEFT, IK_RIGHT, IK_END, IK_DOWN,
  447.   IK_NEXT, IK_INSERT, IK_DELETE,
  448.   IK_LWIN, IK_RWIN,
  449.   IK_APPS, IK_POWER, IK_SLEEP, IK_WAKE,
  450.   IK_WEBSEARCH, IK_WEBFAVORITES, IK_WEBREFRESH, IK_WEBSTOP, IK_WEBFORWARD, IK_WEBBACK,
  451.   IK_MYCOMPUTER, IK_MAIL, IK_MEDIASELECT,
  452.   //  Alternate names
  453.   //
  454.   IK_BACKSPACE, IK_NUMPADSTAR, IK_LALT, IK_CAPSLOCK,
  455.   IK_NUMPADMINUS, IK_NUMPADPLUS, IK_NUMPADPERIOD, IK_NUMPADSLASH,
  456.   IK_RALT,
  457.   IK_UPARROW, IK_PGUP, IK_LEFTARROW, IK_RIGHTARROW, IK_DOWNARROW, IK_PGDN,
  458.   IK_PREVTRACK, IK_MOUSELEFT, IK_MOUSERIGHT, IK_MOUSEMIDDLE,
  459.   IK_SHIFT, IK_CONTROL, IK_ALT: Integer;
  461. implementation
  463. uses TextFile {$IFDEF RUSSIAN} , FIOPadeg, Math {$ENDIF} ;
  465. type
  466.   TRefcountedContainer = class(TInterfacedObject, IRefcountedContainer)
  467.   private
  468.     ObjList: array of TObject;
  469.     PtrList: array of Pointer;
  470.     ObjCount, PtrCount: Integer;
  471.   public
  472.     destructor Destroy; override;
  474.     function AddObject(Obj: TObject): TObject;
  475.     function AddPointer(Ptr: Pointer): Pointer;
  476.     procedure AddObjects(Objs: array of TObject);
  477.     procedure AddPointers(Ptrs: array of Pointer);
  478.   end;
  480. { TError }
  482. constructor TError.Create(AErrorMessage: string);
  483. begin
  484.   ErrorMessage := AErrorMessage;
  485. end;
  487. function TError.DefaultErrorHandler(const Error: TError): Boolean;
  488. begin
  489.   Log.Log('An unhandled error of class "' + Error.ClassName + '": ' + Error.ErrorMessage, lkError);
  490.   Result := False;                    // Do not continue
  491. end;
  493. function CreateRefcountedContainer: IRefcountedContainer;
  494. begin
  495.   Result := TRefcountedContainer.Create;
  496. end;
  498. function Sign(x: Integer): Integer; overload;
  499. begin
  500.   Result := Ord(X > 0) - Ord(X < 0);
  501. //  if x > 0 then Result := 1 else if x < 0 then Result := -1 else Result := 0;
  502. end;
  504. function Sign(x: Single): Single; overload;
  505. begin
  506.   if x > 0 then Result := 1 else if x < 0 then Result := -1 else Result := 0;
  507. end;
  509. function IsNan(const AValue: Single): Boolean;
  510. begin
  511.   Result := ((Longword((@AValue)^) and $7F800000)  = $7F800000) and
  512.             ((Longword((@AValue)^) and $007FFFFF) <> $00000000);
  513. end;
  515. function Ceil(const X: Single): Integer;
  516. begin
  517.   Result := Integer(Trunc(X));
  518.   if Frac(X) > 0 then Inc(Result);
  519. end;
  521. function Floor(const X: Single): Integer;
  522. begin
  523.   Result := Integer(Trunc(X));
  524.   if Frac(X) < 0 then Dec(Result);
  525. end;
  527. //-----------------------------------------
  529. function MaxI(V1, V2: Integer): Integer;
  530. begin
  531. //  if V1 > V2 then Result := V1 else Result := V2;
  532.   Result := V1 * Ord(V1 >= V2) + V2 * Ord(V1 < V2);
  533.   Assert((Result >= V1) and (Result >= V2));
  534. end;
  536. function MinI(V1, V2: Integer): Integer;
  537. begin
  538. //  if V1 < V2 then Result := V1 else Result := V2;
  539.   Result := V1 * Ord(V1 <= V2) + V2 * Ord(V1 > V2);
  540.   Assert((Result <= V1) and (Result <= V2));
  541. end;
  543. {$IFDEF USEP6ASM}
  544. function MaxS(V1, V2: Single): Single; assembler;
  545. asm
  546.   fld     dword ptr [ebp+$08]
  547.   fld     dword ptr [ebp+$0c]
  548.   fcomi   st(0), st(1)
  549.   fcmovb  st(0), st(1)
  550.   ffree   st(1)
  551. end;
  553. function MinS(V1, V2: Single): Single; assembler;
  554. asm
  555.   fld     dword ptr [ebp+$08]
  556.   fld     dword ptr [ebp+$0c]
  557.   fcomi   st(0), st(1)
  558.   fcmovnb st(0), st(1)
  559.   ffree   st(1)
  560. end;
  561. {$ELSE}
  562. function MaxS(V1, V2: Single): Single;
  563. begin
  564.   if V1 > V2 then Result := V1 else Result := V2;
  565. end;
  567. function MinS(V1, V2: Single): Single;
  568. begin
  569.   if V1 < V2 then Result := V1 else Result := V2;
  570. end;
  571. {$ENDIF}
  573. function ClampS(V, Min, Max: Single): Single;
  574. begin
  575.   Result := MinS(MaxS(V, Min), Max);
  576. end;
  578. function MaxC(V1, V2: Cardinal): Cardinal;
  579. begin
  580.   Result := V1 * Cardinal(Ord(V1 >= V2)) + V2 * Cardinal(Ord(V1 < V2));
  581.   Assert((Result >= V1) and (Result >= V2));
  582. end;
  584. function MinC(V1, V2: Cardinal): Cardinal;
  585. begin
  586.   Result := V1 * Cardinal(Ord(V1 <= V2)) + V2 * Cardinal(Ord(V1 > V2));
  587.   Assert((Result <= V1) and (Result <= V2));
  588. end;
  590. function ClampI(V, Min, Max: Integer): Integer;
  591. begin
  592. //  if V < B1 then Result := B1 else if V > B2 then Result := B2 else Result := V;
  593.   Result := V + (Min - V) * Ord(V < Min) - (V - Max) * Ord(V > Max);
  594.   Assert((Result >= Min) and (Result <= Max));
  595. end;
  597. procedure SwapI(var a, b: Integer);
  598. begin
  599.   a := a xor b;
  600.   b := b xor a;
  601.   a := a xor b;
  602. end;
  604. function BitTest(Data: Cardinal; BitIndex: Byte): Boolean;
  605. begin
  606.   Result := Odd(Data shr BitIndex);
  607. end;
  609. function InterleaveBits(x, y: Smallint): Integer;
  610. var i: Integer;
  611. begin
  612.   Result := 0;
  613.   for i := 0 to SizeOf(x) * BitsInByte-1 do Result := Result or (x and (1 shl i)) shl i or (y and (1 shl i)) shl (i + 1);
  614. { Another (faster) way:
  615. x = (x | (x << S[3])) & B[3];
  616. x = (x | (x << S[2])) & B[2];
  617. x = (x | (x << S[1])) & B[1];
  618. x = (x | (x << S[0])) & B[0];
  620. y = (y | (y << S[3])) & B[3];
  621. y = (y | (y << S[2])) & B[2];
  622. y = (y | (y << S[1])) & B[1];
  623. y = (y | (y << S[0])) & B[0];
  625. z = x | (y << 1);}
  626. end;
  628. function PtrOffs(Base: Pointer; Offset: Integer): Pointer;
  629. begin
  630.   Result := Base;
  631.   Inc(PByte(Result), Offset);
  632. end;
  634. function GetColor4SIntensity(const Color: TColor4s): Single;
  635. begin
  636.   Result := MaxS(MaxS(Color.R, Color.G), Color.B);
  637. end;
  639. function VectorToColor(const v: TVector3s): TColor;
  640. begin
  641.   Result.r := Round(127.0 * v.x + 128.0);
  642.   Result.g := Round(127.0 * v.y + 128.0);
  643.   Result.b := Round(127.0 * v.z + 128.0);
  644. end;
  646. function GetColorFrom4s(const ColorS: TColor4s): TColor;
  647. begin
  648.   Result.A := Round(MinS(1, MaxS(0, ColorS.A))*255);
  649.   Result.R := Round(MinS(1, MaxS(0, ColorS.R))*255);
  650.   Result.G := Round(MinS(1, MaxS(0, ColorS.G))*255);
  651.   Result.B := Round(MinS(1, MaxS(0, ColorS.B))*255);
  652. end;
  654. function GetColorIntensity(const Color: TColor): Integer;
  655. begin
  656.   Result := MaxI(MaxI(Color.R, Color.G), Color.B);
  657. end;
  659. function ScaleColorI(const Color: TColor; S: Cardinal): TColor;
  660. begin
  661.   Result.C := MinI(255,  (Color.C and 255)        *S) shr 8 +
  662.               MinI(255, ((Color.C shr 8)  and 255)*S)       +
  663.               MinI(255, ((Color.C shr 16) and 255)*S) shl 8 +
  664.               MinI(255, ((Color.C shr 24) and 255)*S) shl 16;
  665. end;
  667. function ScaleColorS(const Color: TColor; S: Single): TColor;
  668. begin
  669.   Result.C := Cardinal(Round(MinS(255,  (Color.C and 255)        *S)))        +
  670.               Cardinal(Round(MinS(255, ((Color.C shr 8)  and 255)*S))) shl 8  +
  671.               Cardinal(Round(MinS(255, ((Color.C shr 16) and 255)*S))) shl 16 +
  672.               Cardinal(Round(MinS(255, ((Color.C shr 24) and 255)*S))) shl 24;
  673. end;
  675. function AddColorW(const Color1, Color2: TColor; W1, W2: Single): TColor;
  676. begin
  677.   Result.R := ClampI(Round(Color1.R * W1 + Color2.R * W2), 0, 255);
  678.   Result.G := ClampI(Round(Color1.G * W1 + Color2.G * W2), 0, 255);
  679.   Result.B := ClampI(Round(Color1.B * W1 + Color2.B * W2), 0, 255);
  680.   Result.A := ClampI(Round(Color1.A * W1 + Color2.A * W2), 0, 255);
  681. end;
  683. function BlendColor(const Color1, Color2: TColor; K: Single): TColor;
  684. begin
  685.   if K > 1 then K := 1; if K < 0 then K := 0;
  686.   Result := AddColorW(Color1, Color2, 1-K, K);
  687. end;
  689. function IsDepthFormat(Format: Integer): Boolean;
  690. begin
  691.   Result := (Format >= pfD16_LOCKABLE) and (Format <= pfD24X4S4) or
  692.             (Format = pfATIDF16) or (Format = pfATIDF24);
  693. end;
  695. function PixelFormatToStr(Format: Integer): AnsiString;
  696. var Strs: TAnsiStringArray;
  697. begin
  698.   Strs := nil;
  699.   if (Format < SplitA(PixelFormatsEnum, '&', Strs, True)) then
  700.     Result := Strs[Format] else
  701.       Result := 'Unknown';
  702.   SetLength(Strs, 0);
  703. end;
  705. function GetSteppedSize(CurrentSize, Step: Integer): Integer;
  706. begin
  707. //  Assert(get
  708. //  Result := MaxI(0, (CurrentSize-1)) and (Step-1) + Step)
  709.   Result := MaxI(0, (CurrentSize-1)) div Step * Step + Step;
  710. end;
  712. function CmpMem(P1, P2: Pointer; Size: Cardinal): Boolean;
  713. { TODO -cOptimization : Make an assembler version }
  714. var i: Integer;
  715. begin
  716.   Result := False;
  717.   for i := 0 to Size-1 do if TByteBuffer(P1^)[i] <> TByteBuffer(P2^)[i] then Exit;
  718.   Result := True;
  719. end;
  721. procedure MoveReverse8(Src, Dest: Pointer; Count: Integer);
  722. var i: Integer;
  723. begin
  724.   if Count <= 0 then Exit;
  725.   for i := 0 to Count-1 do PByteBuffer(Dest)^[i] := PByteBuffer(Src)^[Count-1 - i];
  726. end;
  728. procedure MoveReverse16(Src, Dest: Pointer; Count: Integer);
  729. var i: Integer;
  730. begin
  731.   if Count <= 0 then Exit;
  732.   for i := 0 to Count-1 do PWordBuffer(Dest)^[i] := PWordBuffer(Src)^[Count-1 - i];
  733. end;
  735. procedure Swap(var V1, V2);
  736. var T: Pointer;
  737. begin
  738.   T := Pointer(V1);
  739.   Pointer(V1) := Pointer(V2); Pointer(V2) := T;
  740. end;
  742. function FastTrunc(X: Single): Integer;
  743. {$IFDEF USESSE}
  744. asm
  745.   CVTTSS2SI  eax, [ebp+offset X]
  746. end;
  747. {$ELSE}
  748. begin
  749.   Result := Trunc(X);
  750. end;
  751. {$ENDIF}
  753. {$IFDEF PUREPASCAL}
  754. procedure SinCos(a: Single; out OSin, OCos: Single);
  755. begin
  756.   OSin := Sin(a);
  757.   OCos := Cos(a);
  758. end;
  759. {$ELSE}
  760. procedure SinCos(a: Single; out OSin, OCos: Single); assembler; register;
  761. // EAX contains address of OSin
  762. // EDX contains address of OCos
  763. // a is passed over the stack
  764. asm
  765.   FLD  a
  766.   FSINCOS
  767.   FSTP [OCos]
  768.   FSTP [OSin]
  769. //  FWAIT
  770. end;
  771. {$ENDIF}
  773. {$IFDEF PUREPASCAL}
  774. function FastSqrt(x: Single): Single;
  775. begin
  776.   Result := Sqrt(x);
  777. {$ELSE}
  778. function FastSqrt(x: Single): Single; assembler;
  779.   asm
  780.     MOV      EAX, x
  781.     SUB      EAX, 0C0800000H
  782.     TEST     EAX, 000800000H
  783.     MOV      ECX, EAX
  784.     JZ       @NoNeg
  785.     NEG      EAX
  786. @NoNeg:
  787.     AND      EAX, 000FFFFFFH
  788.     SHR      ECX, 1
  789.     MUL      EAX
  790.     NEG      EDX
  791.     LEA      EAX, [ECX+EDX*8]
  792.     LEA      EDX, [EDX+EDX*8]
  793.     LEA      EAX, [EAX+EDX*4]
  794.     mov      Result, eax
  795. {$ENDIF}
  796. end;
  798. function InvSqrt(x: Single): Single;
  799. {$IFDEF PUREPASCAL}
  800. begin
  801.   Result := 1/Sqrt(x);
  802. {$ELSE}
  803. var tmp: LongWord;
  804. begin
  805.   asm
  806.     mov        eax, OneAsInt
  807.     sub        eax, x
  808.     add        eax, OneAsInt2
  809.     shr        eax, 1
  810.     mov        tmp, eax
  811.   end;
  812.   Result := Single((@tmp)^) * (1.47 - 0.47 * x * Single((@tmp)^) * Single((@tmp)^));
  813. {$ENDIF}
  814. end;
  816. function Log2I(x: Integer): Integer;
  817. begin
  818.   Result := 0;
  819.   x := x shr 1;
  820.   while x > 0 do begin
  821.     x := x shr 1;
  822.     Inc(Result);
  823.   end;
  824. end;
  826. function IntPower(Base: Single; Exponent: Integer): Single;
  827. var a: Integer;
  828. begin
  829.   a := Abs(Exponent);
  830.   Result := 1;
  831.   while a > 0 do begin
  832.     while not Odd(a) do begin
  833.       Base := Sqr(Base);
  834.       a := a shr 1;
  835.     end;
  836.     Result := Result * Base;
  837.     Dec(a);
  838.   end;
  839.   if Exponent < 0 then Result := 1/Result
  840. end;
  842. function Power(const Base, Exponent: Single): Single;
  843. begin
  844.   if Exponent = 0.0 then
  845.     Result := 1.0 else
  846.       if (Base = 0.0) and (Exponent > 0.0) then
  847.         Result := 0.0 else
  848.           if (Frac(Exponent) = 0) and (Abs(Exponent) <= MaxInt) then
  849.             Result := IntPower(Base, Trunc(Exponent)) else
  850.               Result := Exp(Exponent * Ln(Base));
  851. end;
  853. function NextPowerOf2(x: Integer): Integer;
  854. begin
  855.   Result := x-1;
  856.   Result := Result or Result shr 1;
  857.   Result := Result or Result shr 2;
  858.   Result := Result or Result shr 4;
  859.   Result := Result or Result shr 8;
  860.   Result := Result or Result shr 16;
  861.   Inc(Result);
  862. end;
  864. function PosEx(const substr : AnsiString; const s : AnsiString; const start: Integer ) : Integer ; assembler;
  865. type StrRec = record allocSiz, refCnt, length: Longint; end;
  866. const skew = sizeof(StrRec);
  867. asm
  868. {     ->EAX     Pointer to substr               }
  869. {       EDX     Pointer to string               }
  870. {       ECX     Pointer to start      //cs      }
  871. {     <-EAX     Position of substr in s or 0    }
  873.         TEST    EAX,EAX
  874.         JE      @@noWork
  875.         TEST    EDX,EDX
  876.         JE      @@stringEmpty
  877.         TEST    ECX,ECX           //cs
  878.         JE      @@stringEmpty     //cs
  880.         PUSH    EBX
  881.         PUSH    ESI
  882.         PUSH    EDI
  884.         MOV     ESI,EAX                         { Point ESI to  }
  885.         MOV     EDI,EDX                         { Point EDI to  }
  887.         MOV     EBX,ECX        //cs save start
  888.         MOV     ECX,[EDI-skew].StrRec.length    { ECX =    }
  889.         PUSH    EDI                             { remember s position to calculate index }
  891.         CMP     EBX,ECX        //cs
  892.         JG      @@fail         //cs
  894.         MOV     EDX,[ESI-skew].StrRec.length    { EDX = bstr)          }
  896.         DEC     EDX                             { EDX = Length(substr) -   }
  897.         JS      @@fail                          { < 0 ? return             }
  898.         MOV     AL,[ESI]                        { AL = first char of       }
  899.         INC     ESI                             { Point ESI to 2'nd char of substr }
  900.         SUB     ECX,EDX                         { #positions in s to look  }
  901.                                                 { = Length(s) - Length(substr) + 1      }
  902.         JLE     @@fail
  903.         DEC     EBX       //cs
  904.         SUB     ECX,EBX   //cs
  905.         JLE     @@fail    //cs
  906.         ADD     EDI,EBX   //cs
  908. @@loop:
  909.         REPNE   SCASB
  910.         JNE     @@fail
  911.         MOV     EBX,ECX                         { save outer loop                }
  912.         PUSH    ESI                             { save outer loop substr pointer }
  913.         PUSH    EDI                             { save outer loop s              }
  915.         MOV     ECX,EDX
  916.         REPE    CMPSB
  917.         POP     EDI                             { restore outer loop s pointer      }
  918.         POP     ESI                             { restore outer loop substr pointer }
  919.         JE      @@found
  920.         MOV     ECX,EBX                         { restore outer loop nter    }
  921.         JMP     @@loop
  923. @@fail:
  924.         POP     EDX                             { get rid of saved s nter    }
  925.         XOR     EAX,EAX
  926.         JMP     @@exit
  928. @@stringEmpty:
  929.         XOR     EAX,EAX
  930.         JMP     @@noWork
  932. @@found:
  933.         POP     EDX                             { restore pointer to first char of s    }
  934.         MOV     EAX,EDI                         { EDI points of char after match        }
  935.         SUB     EAX,EDX                         { the difference is the correct index   }
  936. @@exit:
  937.         POP     EDI
  938.         POP     ESI
  939.         POP     EBX
  940. @@noWork:
  941. end;
  943. function Split(const Str, Delim: string; out Res: TStringArray; EmptyOK: Boolean): Integer;
  944. var i: Integer; s: string;
  945. begin
  946.   Result := 1;
  947.   s := Str;
  948.   while s <> '' do begin
  949.     i := Pos(Delim, s);
  950.     if i > 0 then begin
  951.       if (i > 1) or EmptyOK then begin
  952.         Inc(Result);
  953.         if Length(Res) < Result then SetLength(Res, Result);
  954.         Res[Result-2] := Copy(s, 1, i-1);
  955.       end;
  956.       s := Copy(s, i + Length(Delim), Length(s));
  957.     end else Break;
  958.   end;
  959.   if Length(Res) < Result then SetLength(Res, Result);
  960.   if EmptyOK or (s <> '') then Res[Result-1] := s else Dec(Result);
  961. end;
  963. function SplitA(const Str, Delim: AnsiString; out Res: TAnsiStringArray; EmptyOK: Boolean): Integer;
  964. // Splits s at all occurences of Delim. Res contains splitted strings; Returns number of parts
  965. { TODO -cOptimization : Optimize it }
  966. (*
  967. function explode(Delim: Char; const S: string): TStringArr; 
  968. var i, k, Len, Count: Integer; 
  969. begin 
  970.   Len := Length(S); 
  971.   Count := 0; 
  972.   for i := 1 to Len do 
  973.     if S[i] = Delim then Inc(Count); 
  974.   SetLength(Result, Count + 1); 
  975.   Count := 0; 
  976.   k := 1; 
  977.   for i := 1 to Len do 
  978.   begin 
  979.     if S[i] = Delim then 
  980.     begin 
  981.       Inc(Count); 
  982.       SetString(Result[Count-1], PChar(@S[k]), i-k); 
  983.       k := i + 1; 
  984.     end; 
  985.   end; // for i 
  986.   Inc(Count); 
  987.   SetString(Result[Count-1], PChar(@S[k]), Len-k+1);
  988. end;
  989. *)
  990. var i: Integer; s: AnsiString;
  991. begin
  992.   Result := 1;
  993.   s := Str;
  994.   while s <> '' do begin
  995.     i := Pos(Delim, s);
  996.     if i > 0 then begin
  997.       if (i > 1) or EmptyOK then begin
  998.         Inc(Result);
  999.         if Length(Res) < Result then SetLength(Res, Result);
  1000.         Res[Result-2] := Copy(s, 1, i-1);
  1001.       end;
  1002.       s := Copy(s, i + Length(Delim), Length(s));
  1003.     end else Break;
  1004.   end;
  1005.   if Length(Res) < Result then SetLength(Res, Result);
  1006.   if EmptyOK or (s <> '') then Res[Result-1] := s else Dec(Result);
  1007. end;
  1009. function StringsToEnumA(Strings: array of TShortName; EmptyOK: Boolean): Ansistring;
  1010. var i: Integer;
  1011. begin                                                                       // Can be optimized
  1012.   if Length(Strings) = 0 then
  1013.     Result := ''
  1014.   else begin
  1015.     Result := Strings[0];
  1016.     for i := 1 to High(Strings) do
  1017.       if EmptyOK or (Strings[i] <> '') then
  1018.         Result := Result + StringDelimiter + Strings[i];
  1019.   end;  
  1020. end;
  1022. procedure RectIntersect(const ARect1, ARect2: TRect; out Result: TRect);
  1023. begin
  1024.   Result.Left   := MaxI(ARect1.Left,   ARect2.Left);
  1025.   Result.Top    := MaxI(ARect1.Top,    ARect2.Top);
  1026.   Result.Right  := MinI(ARect1.Right,  ARect2.Right);
  1027.   Result.Bottom := MinI(ARect1.Bottom, ARect2.Bottom);
  1028. end;
  1030. function GetRectIntersect(const ARect1, ARect2: TRect): TRect;
  1031. begin
  1032.   RectIntersect(ARect1, ARect2, Result);
  1033. end;
  1035. function GetCorrectRect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  1036. begin
  1037.   with Result do begin
  1038.     Left := MinI(ALeft, ARight); Top := MinI(ATop, ABottom);
  1039.     Right:= MaxI(ALeft, ARight); Bottom := MaxI(ATop, ABottom);
  1040.   end;
  1041. end;
  1043. function IsInArea(const X, Y, X1, Y1, X2, Y2: Single): Boolean;
  1044. begin
  1045.   Result := (X >= X1) and (Y >= Y1) and (X < X2) and (Y < Y2);
  1046. end;
  1048. function IsInArea(const X, Y: Single; const Area: TArea): Boolean; overload;
  1049. begin
  1050.   Result := IsInArea(X, Y, Area.X1, Area.Y1, Area.X2, Area.Y2);
  1051. end;
  1053. function GetFileName(const FileName: string): string;
  1054. var i: Integer;
  1055. begin
  1056.   if Pos('', FileName) = 0 then begin
  1057.     if Pos(':', FileName) = 0 then Result := FileName else Result := Copy(FileName, Pos(':', FileName)+1, Length(FileName));
  1058.   end else for i := Length(FileName) downto 1 do if FileName[i] = '' then begin
  1059.     Result := Copy(FileName, i+1, Length(FileName)); Break;
  1060.   end;
  1061.   i := Pos('.', Result);
  1062.   if i > 0 then Result := Copy(Result, 1, i-1);
  1063. end;
  1065. function GetDefaultUVMap: TUVMap;
  1066. begin
  1067.   Result := @DefaultUV;
  1068. end;
  1070. { TRefcountedContainer }
  1072. destructor TRefcountedContainer.Destroy;
  1073. var i: Integer;
  1074. begin
  1075.   for i := 0 to ObjCount-1 do if Assigned(ObjList[i]) then FreeAndNil(ObjList[i]);
  1076.   for i := 0 to PtrCount-1 do if Assigned(PtrList[i]) then FreeMem(PtrList[i]);
  1077.   ObjList := nil;
  1078.   PtrList := nil;
  1079.   inherited;
  1080. end;
  1082. function TRefcountedContainer.AddObject(Obj: TObject): TObject;
  1083. begin
  1084.   Inc(ObjCount);
  1085.   if ObjCount > Length(ObjList) then SetLength(ObjList, MaxI(MinRefCContainerLength, Length(ObjList) * 2));
  1086.   ObjList[ObjCount-1] := Obj;
  1087.   Result := Obj;
  1088. end;
  1090. function TRefcountedContainer.AddPointer(Ptr: Pointer): Pointer;
  1091. begin
  1092.   Inc(PtrCount);
  1093.   if PtrCount > Length(PtrList) then SetLength(PtrList, MaxI(MinRefCContainerLength, Length(PtrList) * 2));
  1094.   PtrList[PtrCount-1] := Ptr;
  1095.   Result := Ptr;
  1096. end;
  1098. procedure TRefcountedContainer.AddObjects(Objs: array of TObject);
  1099. var i: Integer;
  1100. begin
  1101.   for i := Low(Objs) to High(Objs) do AddObject(Objs[i]);
  1102. end;
  1104. procedure TRefcountedContainer.AddPointers(Ptrs: array of Pointer);
  1105. var i: Integer;
  1106. begin
  1107.   for i := Low(Ptrs) to High(Ptrs) do AddPointer(Ptrs[i]);
  1108. end;
  1110. { TStream }
  1112. procedure TStream.SetPosition(const Value: Cardinal);
  1113. begin
  1114.   Seek(Value);
  1115. end;
  1117. procedure TStream.SetSize(const Value: Cardinal);
  1118. begin
  1119.   FSize := Value;
  1120. end;
  1122. function TStream.Seek(const NewPos: Cardinal): Boolean;
  1123. begin
  1124.   Result := NewPos <= Size;
  1125.   if Result then FPosition := NewPos else ErrorHandler(TStreamError.Create('Invalid seek'));
  1126. end;
  1128. function TStream.ReadCheck(out Buffer; const Count: Cardinal): Boolean;
  1129. begin
  1130.   Result := Read(Buffer, Count) = Count;
  1131. end;
  1133. function TStream.WriteCheck(const Buffer; const Count: Cardinal): Boolean;
  1134. begin
  1135.   Result := Write(Buffer, Count) = Count;
  1136. end;
  1138. { TFileStream }
  1140. constructor TFileStream.Create(const AFileName: string; const Usage: Integer; const ShareMode: Integer);
  1141. begin
  1142.   Opened := False;
  1143.   if AFileName = '' then Exit;
  1144.   FFileName := ExpandFileName(AFileName);
  1145.   if Usage <> fuDoNotOpen then Open(Usage, ShareMode);
  1146. end;
  1148. destructor TFileStream.Destroy;
  1149. begin
  1150.   Close;
  1151. end;
  1153. function TFileStream.Open(const Usage, ShareMode: Integer): Boolean;
  1154. var OldFileMode: Byte;
  1155. begin
  1156.   Opened := False;
  1157.   Result := False;
  1159.   OldFileMode := FileMode;
  1160. {$I-}
  1161.   case ShareMode of
  1162.     smAllowAll: FileMode := 0;
  1163.     smAllowRead: FileMode := fmShareDenyWrite;
  1164.     smExclusive: FileMode := fmShareExclusive;
  1165.   end;  
  1166.   AssignFile(F, FileName);
  1167.   case Usage of
  1168.     fuRead: begin
  1169.       FileMode := FileMode or fmOpenRead;
  1170.       Reset(F, 1);
  1171.     end;
  1172.     fuReadWrite: begin
  1173.       FileMode := FileMode or fmOpenReadWrite;
  1174.       Reset(F, 1);
  1175.       if (IOResult <> 0) and not FileExists(FFileName) then Rewrite(F, 1);
  1176.     end;
  1177.     fuWrite: Rewrite(F, 1);
  1178.     fuAppend: if FileExists(FileName) then begin
  1179.       FileMode := FileMode or fmOpenReadWrite;
  1180.       Reset(F, 1);
  1181.       FSize := FileSize(F);
  1182.       Seek(Size);
  1183.     end else Rewrite(F, 1);
  1184.   end;
  1186.   if IOResult <> 0 then Exit;
  1188.   FSize := FileSize(F);
  1190.   FileMode := OldFileMode;
  1192.   Opened := True;
  1193.   Result := True;
  1194. end;
  1196. procedure TFileStream.Close;
  1197. begin
  1198.   if Opened then CloseFile(F);
  1199.   Opened := False;
  1200. end;
  1202. function TFileStream.Seek(const NewPos: Cardinal): Boolean;
  1203. begin
  1204.   Result := False;
  1205.   if not Opened then if not ErrorHandler(TStreamError.Create('File stream is not opened')) then Exit;
  1206. {$I-}
  1207.   System.Seek(F, NewPos);
  1208.   Result := IOResult = 0;
  1209.   if Result then FPosition := NewPos;
  1210. end;
  1212. procedure TFileStream.SetSize(const Value: Cardinal);
  1213. begin
  1214.   if not Opened then if not ErrorHandler(TStreamError.Create('File stream is not opened')) then Exit;
  1215. {$I-}
  1216.   System.Seek(F, Value);
  1217.   if IOResult <> 0 then if not ErrorHandler(TStreamError.Create('Seek operation failed')) then Exit;
  1218.   System.Truncate(F);
  1219.   if IOResult <> 0 then if not ErrorHandler(TStreamError.Create('Truncate operation failed')) then Exit;
  1220.   Position := MinI(Value, FPosition);
  1221.   inherited;
  1222. end;
  1224. function TFileStream.Read(out Buffer; const Count: Cardinal): Cardinal;
  1225. begin
  1226.   Result := 0;
  1227.   if not Opened then if not ErrorHandler(TStreamError.Create('File stream is not opened')) then Exit;
  1228.   BlockRead(F, Buffer, Count, Result);
  1229.   if Result > 0 then FPosition := FPosition + Result;
  1230. end;
  1232. function TFileStream.Write(const Buffer; const Count: Cardinal): Cardinal;
  1233. begin
  1234.   Result := 0;
  1235.   if not Opened then if not ErrorHandler(TStreamError.Create('File stream is not opened')) then Exit;
  1236.   BlockWrite(F, Buffer, Count, Result);
  1237.   if Result > 0 then FPosition := FPosition + Result;
  1238.   FSize := FPosition;
  1239. end;
  1241. { TMemoryStream }
  1243. procedure TMemoryStream.SetCapacity(const NewCapacity: Cardinal);
  1244. begin
  1245.   if FCapacity = 0 then GetMem(FData, NewCapacity) else ReallocMem(FData, NewCapacity);
  1246.   FCapacity := NewCapacity;
  1247.   if FSize > FCapacity then FSize := FCapacity;
  1248.   Seek(FPosition);
  1249. end;
  1251. procedure TMemoryStream.Allocate(const NewSize: Cardinal);
  1252. const MinCap = $40; CapPower = 10; MaxCapStep = $10000;
  1253. var NewCapacity: Cardinal;
  1254. begin
  1255.   if NewSize > FCapacity then begin
  1256.     if NewSize < MinCap then
  1257.       NewCapacity := MinCap
  1258.     else if (NewSize < MaxCapStep) and (NewSize <= FCapacity*2) then
  1259.       NewCapacity := FCapacity*2
  1260.     else begin
  1261.       NewCapacity := (NewSize shr CapPower) shl CapPower;
  1262.       if NewCapacity < NewSize then Inc(NewCapacity, 1 shl CapPower);
  1263.     end;
  1264.     Assert(NewCapacity >= NewSize, ClassName + '.Allocate: Error');
  1265.     SetCapacity(NewCapacity);
  1266.   end;
  1267.   FSize := NewSize;
  1268. end;
  1270. procedure TMemoryStream.SetSize(const Value: Cardinal);
  1271. begin
  1272.   SetCapacity(Value);
  1273.   Position := MinI(Value, FPosition);
  1274.   inherited;
  1275. end;
  1277. constructor TMemoryStream.Create(AData: Pointer; const ASize: Cardinal);
  1278. begin
  1279.   FData := nil;
  1280.   if ASize > 0 then Allocate(ASize);
  1281.   if AData <> nil then Move(AData^, Data^, ASize);
  1282. end;
  1284. destructor TMemoryStream.Destroy;
  1285. begin
  1286.   FreeMem(Data);
  1287. end;
  1289. function TMemoryStream.Read(out Buffer; const Count: Cardinal): Cardinal;
  1290. begin
  1291.   Result := FSize - FPosition;
  1292.   if Result > Count then Result := Count;
  1293.   if Result > 0 then begin
  1294.     Move(Pointer(Cardinal(FData) + FPosition)^, Buffer, Result);
  1295.     Inc(FPosition, Result);
  1296.   end;
  1297. end;
  1299. function TMemoryStream.Write(const Buffer; const Count: Cardinal): Cardinal;
  1300. var NewPos: Cardinal;
  1301. begin
  1302.   NewPos := FPosition + Count;
  1303.   if NewPos > FSize then Allocate(NewPos);
  1304.   Move(Buffer, Pointer(Cardinal(FData) + FPosition)^, Count);
  1305.   FPosition := NewPos;
  1306.   Result := Count;
  1307. end;
  1309. { TStringStream }
  1311. constructor TAnsiStringStream.Create(AData: Pointer; const ASize: Cardinal; const AReturnsequence: TShortName = #13#10);
  1312. begin
  1313.   ReturnSequence := AReturnSequence;
  1314.   SetLength(Data, ASize);
  1315.   if (AData <> nil) and (ASize > 0) then Data := Copy(AnsiString(AData), 1, ASize);
  1316.   FSize := ASize;
  1317. end;
  1319. function TAnsiStringStream.Read(out Buffer; const Count: Cardinal): Cardinal;
  1320. begin
  1321.   Result := Count;
  1322.   AnsiString(Buffer) := Copy(Data, FPosition+1, Count);
  1323. end;
  1325. function TAnsiStringStream.Readln(out Buffer: AnsiString): Integer;
  1326. var i: Integer;
  1327. begin
  1328.   Result := 0;
  1329.   i := 0;
  1330.   Buffer := '';
  1331.   while (FPosition < Size) and (i < Length(ReturnSequence)) do begin
  1332.     if Data[FPosition+1] = ReturnSequence[i+1] then Inc(i) else begin
  1333.       if i > 0 then begin
  1334.         Buffer := Buffer + Copy(ReturnSequence, 1, i);
  1335.         i := 0;
  1336.         Buffer := Buffer + Data[FPosition+1];
  1337.       end else Buffer := Buffer + Data[FPosition+1];
  1338.     end;
  1339.     Inc(FPosition);
  1340.     Inc(Result);
  1341.   end;
  1342. end;
  1344. function TAnsiStringStream.Write(const Buffer; const Count: Cardinal): Cardinal;
  1345. begin
  1346.   Result := Count;
  1347.   SetLength(Data, FPosition);
  1348.   Data := Data + Copy(AnsiString(Buffer), 1, Count);
  1349.   FPosition := FPosition + Count;
  1350.   FSize := FPosition;
  1351. end;
  1353. function TAnsiStringStream.Writeln(const Buffer: AnsiString): Integer;
  1354. var p: Pointer; BufLen: Integer;
  1355. begin
  1356.   BufLen := Length(Buffer);
  1357.   Result := BufLen + Length(ReturnSequence);
  1358.   p := @Buffer[1];
  1359.   Write(p, BufLen);
  1360.   p := @ReturnSequence[1];
  1361.   Write(p, Length(ReturnSequence));
  1362. end;
  1364. { TRandomGenerator }
  1366. constructor TRandomGenerator.Create;
  1367. begin
  1368.   SetMaxSequence(8);
  1369.   CurrentSequence := 0;
  1370.   InitSequence(1, 1);
  1371. end;
  1373. procedure TRandomGenerator.InitSequence(Chain, Seed: Longword);
  1374. begin
  1375.   RandomChain[FCurrentSequence] := Chain;
  1376.   RandomSeed [FCurrentSequence] := Seed;
  1377. end;
  1379. function TRandomGenerator.GenerateRaw: Longword;
  1380. begin
  1381. {$Q-}
  1382.   RandomSeed[FCurrentSequence] := 97781173 * RandomSeed[FCurrentSequence] + RandomChain[FCurrentSequence];
  1383.   Result := RandomSeed[FCurrentSequence];
  1384. end;
  1386. function TRandomGenerator.Rnd(Range: Single): Single;
  1387. const RandomNorm = 1/$FFFFFFFF;
  1388. begin
  1389.   Result := GenerateRaw * RandomNorm * Range;
  1390. end;
  1392. function TRandomGenerator.RndSymm(Range: Single): Single;
  1393. begin
  1394.   Result := Rnd(2*Range) - Range;
  1395. end;
  1397. function TRandomGenerator.RndI(Range: Integer): Integer;
  1398. begin
  1399.   Result := Round(Rnd(MaxI(0, Range-1)));
  1400. end;
  1402. procedure TRandomGenerator.SetMaxSequence(AMaxSequence: Integer);
  1403. begin
  1404.   SetLength(RandomSeed, AMaxSequence);
  1405.   SetLength(RandomChain, AMaxSequence);
  1406. end;
  1408. procedure TRandomGenerator.SetCurrentSequence(const Value: Cardinal);
  1409. begin
  1410.   FCurrentSequence := Value;
  1411.   if Integer(Value) > High(RandomSeed) then SetMaxSequence(Value+1);
  1412. end;
  1414. {--------------------------}
  1416. procedure FillDWord(var Dest; Count: Cardinal; Value: LongWord);
  1417. {$IFDEF PUREPASCAL}
  1418. begin
  1419.   FillChar(Dest, Count * 4, Value);
  1420. {$ELSE}
  1421. assembler;
  1422. asm
  1423. {     ->EAX     Pointer to destination  }
  1424. {       EDX     count   }
  1425. {       CX      value   }
  1427.         PUSH    EDI
  1429.         MOV     EDI,EAX { Point EDI to destination              }
  1431.         MOV     EAX,ECX
  1432.         CLD
  1433.         MOV     ECX,EDX
  1435.         REP     STOSD   { Fill count dwords       }
  1437. @@exit:
  1438.         POP     EDI
  1439. {$ENDIF}
  1440. end;
  1442. function CompareValues(v1, v2: Extended): Integer;
  1443. begin
  1444.   if v1 > v2 then Result := 1 else
  1445.     if v1 < v2 then Result := -1 else
  1446.       Result := 0;
  1447. end;
  1449. function CompareDates(ADate: TDateTime; Year, Month, Day: Integer): Integer;
  1450. var AYear, AMonth, ADay: Word;
  1451. begin
  1452.   DecodeDate(ADate, AYear, AMonth, ADay);
  1453.   Result := CompareValues(AYear * 512 + AMonth * 32 + ADay, Year * 512 + Month * 32 + Day);
  1454. end;
  1456. function HexStrToIntDef(const s: string; Default: Longword): Longword;
  1457. var E: Integer;
  1458. begin
  1459.   Val('0x' + s, Result, E);
  1460.   if E <> 0 then Result := Default;
  1461. end;
  1463. function ColorStrToIntDef(const color: string; Default: Longword): Longword;
  1464. var E: Integer;
  1465. begin
  1466.   if (color <> '') and (color[1] = '#') then begin
  1467.     Val('0x' + Copy(color, 2, Length(color)), Result, E);
  1468.     if E <> 0 then Result := Default;
  1469.   end else Result := Default;  
  1470. end;
  1472. {$HINTS OFF}
  1473. function IsDecimalInteger(const s: string): Boolean;
  1474. var E, R: Integer;
  1475. begin
  1476.   Val(s, R, E);
  1477.   Result := E = 0;
  1478. end;
  1479. {$HINTS ON}
  1481. function IsFloat(const s: string): Boolean;
  1482. begin
  1483.   Result := Abs(StrToFloatDef(s, 0) - StrToFloatDef(s, 1)) < 0.5;
  1484. end;
  1486. {$HINTS OFF}
  1487. function IsColor(const s: string): Boolean;
  1488. var E, R: Integer;
  1489. begin
  1490.   Result := False;
  1491.   if (s = '') or (s[1] <> '#') then Exit;
  1492.   Val('0x' + Copy(s, 2, Length(s)), R, E);
  1493.   Result := E = 0;
  1494. end;
  1495. {$HINTS ON}
  1497. function isSameGUID(GUID1, GUID2: TGUID): Boolean;
  1498. begin
  1499.   Result := (GUID1.D1 = GUID2.D1) and (GUID1.D2 = GUID2.D2) and (GUID1.D3 = GUID2.D3) and
  1500.             (GUID1.D4[0] = GUID2.D4[0]) and (GUID1.D4[1] = GUID2.D4[1]) and (GUID1.D4[2] = GUID2.D4[2]) and (GUID1.D4[3] = GUID2.D4[3]) and
  1501.             (GUID1.D4[4] = GUID2.D4[4]) and (GUID1.D4[5] = GUID2.D4[5]) and (GUID1.D4[6] = GUID2.D4[6]) and (GUID1.D4[7] = GUID2.D4[7]);
  1502. end;
  1504. function GetBytesPerPixel(PixelFormat: Cardinal): Integer;
  1505. begin
  1506.   case PixelFormat of
  1507.     pfA8R8G8B8, pfX8R8G8B8, pfX8L8V8U8, pfQ8W8V8U8, pfV16U16, pfW11V11U10, pfD32, pfD24S8, pfD24X8, pfD24X4S4, pfA8B8G8R8: Result := 4;
  1508.     pfR8G8B8, pfB8G8R8: Result := 3;
  1509.     pfR5G6B5, pfX1R5G5B5, pfA1R5G5B5, pfA4R4G4B4, pfX4R4G4B4, pfA8P8, pfA8L8, pfV8U8, pfL6V5U5, pfD16_LOCKABLE, pfD15S1, pfD16: Result := 2;
  1510.     pfA8, pfP8, pfL8, pfA4L4: Result := 1;
  1511.     else Result := 0;
  1512.   end;
  1513. end;
  1515. function GetBitsPerPixel(PixelFormat: Cardinal): Integer;
  1516. begin
  1517.   Result := GetBytesPerPixel(PixelFormat) * 8;
  1518. end;
  1520. function IntToStrA(Value: Int64): AnsiString;
  1521. begin
  1522.   Result := AnsiString(IntToStr(Value));
  1523. end;
  1525. function IntToHexA(Value: Int64; Digits: Integer): AnsiString;
  1526. begin
  1527.   Result := AnsiString(IntToHex(Int64(Value), Digits));
  1528. end;
  1530. function FloatToStrA(Value: Extended): AnsiString;
  1531. begin
  1532.   Result := AnsiString(FloatToStr(Value));
  1533. end;
  1535. function FormatA(const Format: string; const Args: array of const): AnsiString;
  1536. begin
  1537.   Result := AnsiString(SysUtils.Format(Format, Args));
  1538. end;
  1540. function StrToFloatDefA(const S: AnsiString; const Default: Extended): Extended;
  1541. begin
  1542.   Result := StrToFloatDef(string(S), Default);
  1543. end;
  1545. function TrimSpacesA(ts: string): AnsiString;
  1546. begin
  1547.   Result := AnsiString(TrimSpaces(ts));
  1548. end;
  1550. function TrimSpaces(ts: string): string;
  1551. const CharsToTrim = ' '#9#0;
  1552. var LeadingSpaces, TrailingSpaces: Integer;
  1553. begin
  1554.   Result := '';
  1555.   LeadingSpaces := 0;
  1556.   while (LeadingSpaces < Length(ts)) and (Pos(ts[LeadingSpaces+1], CharsToTrim) > 0) do Inc(LeadingSpaces);
  1557.   TrailingSpaces := 0;
  1558.   while ((Length(ts)-TrailingSpaces) > LeadingSpaces) and (Pos(ts[Length(ts)-TrailingSpaces], CharsToTrim) > 0) do Inc(TrailingSpaces);
  1559.   Result := Copy(ts, LeadingSpaces+1, Length(ts) - LeadingSpaces - TrailingSpaces);
  1560. end;
  1562. function GetLastCharPos(c: Char; const s: string): Integer;
  1563. begin
  1564.   for Result := Length(s) downto 1 do if s[Result] = c then Exit;
  1565.   Result := -1;
  1566. end;
  1568. procedure QuickSortStrInd(N: Integer; Values: TAnsiStringArray; Inds: TIndArray; Acc: Boolean);
  1569. type _QSDataType = string;
  1570. {$DEFINE COMPARABLE}
  1571. {$I basics_quicksort_ind.inc}
  1572. {$IFNDEF ForCodeNavigationWork} begin end; {$ENDIF}
  1574. procedure QuickSortIntInd(N: Integer; Values, Inds: TIndArray; Acc: Boolean);
  1575. type _QSDataType = Integer;
  1576. {$DEFINE COMPARABLE}
  1577. {$I basics_quicksort_ind.inc}
  1578. {$IFNDEF ForCodeNavigationWork} begin end; {$ENDIF}
  1580. procedure QuickSortSInd(N: Integer; Values: TSingleArray; Inds: TIndArray; Acc: Boolean);
  1581. type _QSDataType = Single;
  1582. {$DEFINE COMPARABLE}
  1583. {$I basics_quicksort_ind.inc}
  1584. {$IFNDEF ForCodeNavigationWork} begin end; {$ENDIF}
  1586. procedure QuickSortStr(N: Integer; Values: TAnsiStringArray);
  1587. type _QSDataType = AnsiString;
  1588. {$DEFINE COMPARABLE}
  1589. {$I basics_quicksort.inc}
  1590. {$IFNDEF ForCodeNavigationWork} begin end; {$ENDIF}
  1592. procedure QuickSortInt(N: Integer; Values: TIndArray);
  1593. type _QSDataType = Integer;
  1594. {$DEFINE COMPARABLE}
  1595. {$I basics_quicksort.inc}
  1596. {$IFNDEF ForCodeNavigationWork} begin end; {$ENDIF}
  1598. procedure QuickSortS(N: Integer; Values: TSingleArray);
  1599. type _QSDataType = Single;
  1600. {$DEFINE COMPARABLE}
  1601. {$I basics_quicksort.inc}
  1602. {$IFNDEF ForCodeNavigationWork} begin end; {$ENDIF}
  1604. function AssureFloatFormat(const s: string): string;
  1605. var i: Integer;
  1606. begin
  1607.   SetLength(Result, Length(s));
  1608.   for i := 1 to Length(s) do
  1609.    if (s[i] <> '.') and (s[i] <> ',') then Result[i] := s[i] else Result[i] := DecimalSeparator;
  1610. end;
  1612. function StrFormat(const s: string; Args: array of string): string;
  1613. {$IFDEF RUSSIAN}
  1614. const GenderStr = '戽';
  1615. var GenderI  : Integer;
  1616. {$ENDIF}
  1617. var i, ArgI, PadegI: Integer; ArgState: Boolean;
  1619.   function ReadNumber: Integer;
  1620.   var rs: string;
  1621.   begin
  1622.     rs := '';
  1623.     Inc(i);
  1624.     while s[i] in ['0'..'9'] do begin
  1625.       rs := rs + s[i];
  1626.       Inc(i);
  1627.     end;
  1628.     Dec(i);
  1629.     Result := StrToIntDef(rs, -1);
  1630.   end;
  1632. begin
  1633.   ArgState := False;
  1634.   Result := '';
  1635.   ArgI := 1; PadegI := 1; {$IFDEF RUSSIAN} GenderI := 1; {$ENDIF}
  1636.   i := 1;
  1637.   while i <= Length(s) do begin
  1638.     if ArgState then begin
  1639.       case s[i] of
  1640.         'A': begin
  1641.           ArgI := ReadNumber;
  1642.           if (ArgI < 1) or (ArgI > Length(Args)) then ArgI := 1;
  1643.         end;
  1644. {$IFDEF RUSSIAN}
  1645.         'P': begin
  1646.           PadegI := ReadNumber;
  1647.           if (PadegI < 1) or (PadegI > MaxPadeg) then PadegI := 1;
  1648.         end;
  1649.         'G': begin
  1650.           GenderI := ReadNumber;
  1651.           if (GenderI < 1) or (GenderI > 2) then GenderI := 1;
  1652.         end;
  1653. {$ENDIF}
  1654.       end;
  1655.     end else if s[i] <> '%' then Result := Result + s[i];
  1656.     if s[i] = '%' then begin
  1657.       if ArgState and (ArgI > 0) and (ArgI <= Length(Args)) and (Length(Args[ArgI-1]) > 0) then begin
  1658.         if PadegI = 1 then Result := Result + Args[ArgI-1]
  1659. {$IFDEF RUSSIAN}
  1660.          else begin
  1661.            if Ord(Args[ArgI-1][Length(Args[ArgI-1])]) <= 127 then
  1662.             Result := Result + GetFIO('', Args[ArgI-1]+'''', '', GenderStr[GenderI], PadegI) else
  1663.              Result := Result + GetFIO('', Args[ArgI-1], '', GenderStr[GenderI], PadegI);
  1664.          end;
  1665. {$ENDIF};
  1666.         ArgI := MinI(ArgI+1, Length(Args));
  1667.       end;
  1668.       ArgState := not ArgState;
  1669.     end;
  1670.     Inc(i);
  1671.   end;
  1672. end;
  1674. function ExtractStr(s, Sig: string): string;
  1675. var p1, p2: Integer; s1: string;
  1676. begin
  1677.   Result := '';
  1678.   p1 := Pos(Sig, s);
  1679.   if p1 = 0 then Exit;
  1680.   s1 := Copy(s, p1 + Length(Sig), Length(s));
  1682.   p2 := Pos(#10, s1);
  1683.   if (p2 = 0) or ( (Pos(#13, s1) > 0) and (Pos(#13, s1) < p2) ) then p2 := Pos(#13, s1);
  1684.   if p2 = 0 then p2 := Length(s1)+1;
  1685.   if p2 < 2 then Exit;
  1686.   Result := TrimSpaces(Copy(s1, 1, p2-1));
  1687. end;
  1689. function IsCharIn(C: AnsiChar; const CharSet: TSysCharSet): Boolean;
  1690. begin
  1691.   Result := C in CharSet;
  1692. end;
  1694. function StrToRealDef(const s: string; Default: Extended): Extended;
  1695. var OldDecimalSeparator: Char;
  1696. begin
  1697.   OldDecimalSeparator := DecimalSeparator;
  1698.   DecimalSeparator := GeneralDecimalSeparator;
  1699.   Result := StrToFloatDef(s, Default);
  1700.   DecimalSeparator := OldDecimalSeparator;
  1701. end;
  1703. function RealToStr(Value: Extended): string;
  1704. var OldDecimalSeparator: Char;
  1705. begin
  1706.   OldDecimalSeparator := DecimalSeparator;
  1707.   DecimalSeparator := GeneralDecimalSeparator;
  1708.   Result := FloatToStrF(Value, ffGeneral, 7, 0);
  1709.   DecimalSeparator := OldDecimalSeparator;
  1710. end;
  1712. function IsReal(const s: string): Boolean;                           // Tests with current decimal separator
  1713. begin
  1714.   Result := Abs(StrToRealDef(s, 0) - StrToRealDef(s, 1)) < 0.5;
  1715. end;
  1717. function SaveString(Stream: TStream; const s: AnsiString): Boolean;
  1718. var l: Integer;
  1719. begin
  1720.   l := Length(s);
  1721.   Result := Stream.WriteCheck(l, SizeOf(l));
  1722.   if Result and (l > 0) then Result := Stream.WriteCheck(Pointer(s)^, l * SizeOf(AnsiChar));
  1723. end;
  1725. function SaveString(Stream: TStream; const s: WideString): Boolean;
  1726. var l: Integer;
  1727. begin
  1728.   l := Length(s);
  1729.   Result := Stream.WriteCheck(l, SizeOf(l));
  1730.   if Result and (l > 0) then Result := Stream.WriteCheck(Pointer(s)^, l * SizeOf(WideChar));
  1731. end;
  1734. function LoadString(Stream: TStream; out s: AnsiString): Boolean;
  1735. var l: Cardinal;
  1736. begin
  1737.   Result := Stream.Read(l, SizeOf(l)) = SizeOf(l);
  1738.   if Result then begin
  1739.     SetLength(s, l);
  1740.     if l > 0 then Result := Stream.Read(Pointer(s)^, l * SizeOf(AnsiChar)) = l * SizeOf(AnsiChar);
  1741.   end;
  1742. end;
  1744. function LoadString(Stream: TStream; out   s: WideString): Boolean;
  1745. var l: Cardinal;
  1746. begin
  1747.   Result := Stream.Read(l, SizeOf(l)) = SizeOf(l);
  1748.   if Result then begin
  1749.     SetLength(s, l);
  1750.     if l > 0 then Result := Stream.Read(Pointer(s)^, l * SizeOf(WideChar)) = l * SizeOf(WideChar);
  1751.   end;
  1752. end;
  1754. const CRCTable: array[0..255] of Longword =
  1755.      ($00000000, $77073096, $EE0E612C, $990951BA,
  1756.       $076DC419, $706AF48F, $E963A535, $9E6495A3,
  1757.       $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
  1758.       $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
  1759.       $1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
  1760.       $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
  1761.       $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
  1762.       $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
  1763.       $3B6E20C8, $4C69105E, $D56041E4, $A2677172,
  1764.       $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
  1765.       $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
  1766.       $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
  1767.       $26D930AC, $51DE003A, $C8D75180, $BFD06116,
  1768.       $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
  1769.       $2802B89E, $5F058808, $C60CD9B2, $B10BE924,
  1770.       $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
  1772.       $76DC4190, $01DB7106, $98D220BC, $EFD5102A,
  1773.       $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
  1774.       $7807C9A2, $0F00F934, $9609A88E, $E10E9818,
  1775.       $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
  1776.       $6B6B51F4, $1C6C6162, $856530D8, $F262004E,
  1777.       $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
  1778.       $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
  1779.       $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
  1780.       $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
  1781.       $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
  1782.       $4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
  1783.       $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
  1784.       $5005713C, $270241AA, $BE0B1010, $C90C2086,
  1785.       $5768B525, $206F85B3, $B966D409, $CE61E49F,
  1786.       $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
  1787.       $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
  1789.       $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
  1790.       $EAD54739, $9DD277AF, $04DB2615, $73DC1683,
  1791.       $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
  1792.       $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
  1793.       $F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
  1794.       $F762575D, $806567CB, $196C3671, $6E6B06E7,
  1795.       $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
  1796.       $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
  1797.       $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
  1798.       $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
  1799.       $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
  1800.       $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
  1801.       $CB61B38C, $BC66831A, $256FD2A0, $5268E236,
  1802.       $CC0C7795, $BB0B4703, $220216B9, $5505262F,
  1803.       $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
  1804.       $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
  1806.       $9B64C2B0, $EC63F226, $756AA39C, $026D930A,
  1807.       $9C0906A9, $EB0E363F, $72076785, $05005713,
  1808.       $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
  1809.       $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
  1810.       $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
  1811.       $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
  1812.       $88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
  1813.       $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
  1814.       $A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
  1815.       $A7672661, $D06016F7, $4969474D, $3E6E77DB,
  1816.       $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
  1817.       $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
  1818.       $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
  1819.       $BAD03605, $CDD70693, $54DE5729, $23D967BF,
  1820.       $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
  1821.       $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
  1823. procedure CalcCRC32(Bytes: PByteBuffer; ByteCount: Cardinal; var CRCValue: Longword);
  1824. var i: Cardinal;
  1825. begin
  1826.   for i := 0 to ByteCount - 1 do
  1827.     CRCvalue := (CRCvalue shr 8) xor CRCTable[Bytes^[i] xor (CRCvalue and $000000FF)];
  1828. end;
  1830. function ForEachFile(const PathAndMask: string; AttributeFilter: Integer; Delegate: TFileDelegate): Integer;
  1831. var SR: SysUtils.TSearchRec; Dir: string;
  1832. begin
  1833.   Result := 0;
  1834.   if SysUtils.FindFirst(PathAndMask, AttributeFilter, SR) = 0 then begin
  1835.     Dir := ExtractFilePath(PathAndMask);
  1836.     repeat
  1837.       Inc(Result);
  1838.       if not Delegate(Dir + SR.Name) then Break;
  1839.     until SysUtils.FindNext(SR) <> 0;
  1840.     SysUtils.FindClose(SR);
  1841.   end;
  1842. end;
  1844. var err: TError;
  1846. initialization
  1847.   ErrorHandler := {$IFDEF OBJFPCEnable}@{$ENDIF}Err.DefaultErrorHandler;
  1848. end.