ImagingUtility.pas 41 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523
  1. {
  2. $Id$
  3. Vampyre Imaging Library
  4. by Marek Mauder
  5. http://imaginglib.sourceforge.net
  6. The contents of this file are used with permission, subject to the Mozilla
  7. Public License Version 1.1 (the "License"); you may not use this file except
  8. in compliance with the License. You may obtain a copy of the License at
  9. http://www.mozilla.org/MPL/MPL-1.1.html
  10. Software distributed under the License is distributed on an "AS IS" basis,
  11. WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  12. the specific language governing rights and limitations under the License.
  13. Alternatively, the contents of this file may be used under the terms of the
  14. GNU Lesser General Public License (the "LGPL License"), in which case the
  15. provisions of the LGPL License are applicable instead of those above.
  16. If you wish to allow use of your version of this file only under the terms
  17. of the LGPL License and not to allow others to use your version of this file
  18. under the MPL, indicate your decision by deleting the provisions above and
  19. replace them with the notice and other provisions required by the LGPL
  20. License. If you do not delete the provisions above, a recipient may use
  21. your version of this file under either the MPL or the LGPL License.
  22. For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  23. }
  24. { This unit contains utility functions and types for Imaging library.}
  25. unit ImagingUtility;
  26. {$I ImagingOptions.inc}
  27. interface
  28. uses
  29. SysUtils, Classes, Types;
  30. const
  31. STrue = 'True';
  32. SFalse = 'False';
  33. type
  34. TByteArray = array[0..MaxInt - 1] of Byte;
  35. PByteArray = ^TByteArray;
  36. TWordArray = array[0..MaxInt div 2 - 1] of Word;
  37. PWordArray = ^TWordArray;
  38. TLongIntArray = array[0..MaxInt div 4 - 1] of LongInt;
  39. PLongIntArray = ^TLongIntArray;
  40. TLongWordArray = array[0..MaxInt div 4 - 1] of LongWord;
  41. PLongWordArray = ^TLongWordArray;
  42. TInt64Array = array[0..MaxInt div 8 - 1] of Int64;
  43. PInt64Array = ^TInt64Array;
  44. TSingleArray = array[0..MaxInt div 4 - 1] of Single;
  45. PSingleArray = ^TSingleArray;
  46. TBooleanArray = array[0..MaxInt - 1] of Boolean;
  47. PBooleanArray = ^TBooleanArray;
  48. TDynByteArray = array of Byte;
  49. TDynIntegerArray = array of Integer;
  50. TDynBooleanArray = array of Boolean;
  51. TWordRec = packed record
  52. case Integer of
  53. 0: (WordValue: Word);
  54. 1: (Low, High: Byte);
  55. end;
  56. PWordRec = ^TWordRec;
  57. TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec;
  58. PWordRecArray = ^TWordRecArray;
  59. TLongWordRec = packed record
  60. case Integer of
  61. 0: (LongWordValue: LongWord);
  62. 1: (Low, High: Word);
  63. { Array variants - Index 0 means lowest significant byte (word, ...).}
  64. 2: (Words: array[0..1] of Word);
  65. 3: (Bytes: array[0..3] of Byte);
  66. end;
  67. PLongWordRec = ^TLongWordRec;
  68. TLongWordRecArray = array[0..MaxInt div 4 - 1] of TLongWordRec;
  69. PLongWordRecArray = ^TLongWordRecArray;
  70. TInt64Rec = packed record
  71. case Integer of
  72. 0: (Int64Value: Int64);
  73. 1: (Low, High: LongWord);
  74. { Array variants - Index 0 means lowest significant byte (word, ...).}
  75. 2: (Words: array[0..3] of Word);
  76. 3: (Bytes: array[0..7] of Byte);
  77. end;
  78. PInt64Rec = ^TInt64Rec;
  79. TInt64RecArray = array[0..MaxInt div 8 - 1] of TInt64Rec;
  80. PInt64RecArray = ^TInt64RecArray;
  81. TFloatHelper = record
  82. Data1: Int64;
  83. Data2: Int64;
  84. end;
  85. PFloatHelper = ^TFloatHelper;
  86. TChar2 = array[0..1] of AnsiChar;
  87. TChar3 = array[0..2] of AnsiChar;
  88. TChar4 = array[0..3] of AnsiChar;
  89. TChar8 = array[0..7] of AnsiChar;
  90. TChar16 = array[0..15] of AnsiChar;
  91. { Options for BuildFileList function:
  92. flFullNames - file names in result will have full path names
  93. (ExtractFileDir(Path) + FileName)
  94. flRelNames - file names in result will have names relative to
  95. ExtractFileDir(Path) dir
  96. flRecursive - adds files in subdirectories found in Path.}
  97. TFileListOption = (flFullNames, flRelNames, flRecursive);
  98. TFileListOptions = set of TFileListOption;
  99. { Frees class instance and sets its reference to nil.}
  100. procedure FreeAndNil(var Obj);
  101. { Frees pointer and sets it to nil.}
  102. procedure FreeMemNil(var P); {$IFDEF USE_INLINE}inline;{$ENDIF}
  103. { Replacement of standard System.FreeMem procedure which checks if P is nil
  104. (this is only needed for Free Pascal, Delphi makes checks in its FreeMem).}
  105. procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF}
  106. { Returns current exception object. Do not call outside exception handler.}
  107. function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF}
  108. { Returns time value with microsecond resolution.}
  109. function GetTimeMicroseconds: Int64;
  110. { Returns time value with milisecond resolution.}
  111. function GetTimeMilliseconds: Int64;
  112. { Returns file extension (without "." dot)}
  113. function GetFileExt(const FileName: string): string;
  114. { Returns file name of application's executable.}
  115. function GetAppExe: string;
  116. { Returns directory where application's exceutable is located without
  117. path delimiter at the end.}
  118. function GetAppDir: string;
  119. { Returns True if FileName matches given Mask with optional case sensitivity.
  120. Mask can contain ? and * special characters: ? matches
  121. one character, * matches zero or more characters.}
  122. function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean = False): Boolean;
  123. { This function fills Files string list with names of files found
  124. with FindFirst/FindNext functions (See details on Path/Atrr here).
  125. - BuildFileList('c:\*.*', faAnyFile, List, [flRecursive]) returns
  126. list of all files (only name.ext - no path) on C drive
  127. - BuildFileList('d:\*.*', faDirectory, List, [flFullNames]) returns
  128. list of all directories (d:\dirxxx) in root of D drive.}
  129. function BuildFileList(Path: string; Attr: LongInt; Files: TStrings;
  130. Options: TFileListOptions = []): Boolean;
  131. { Similar to RTL's Pos function but with optional Offset where search will start.
  132. This function is in the RTL StrUtils unit but }
  133. function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
  134. { Same as PosEx but without case sensitivity.}
  135. function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  136. { Returns a sub-string from S which is followed by
  137. Sep separator and deletes the sub-string from S including the separator.}
  138. function StrToken(var S: string; Sep: Char): string;
  139. { Same as StrToken but searches from the end of S string.}
  140. function StrTokenEnd(var S: string; Sep: Char): string;
  141. { Fills instance of TStrings with tokens from string S where tokens are separated by
  142. one of Seps characters.}
  143. procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
  144. { Returns string representation of integer number (with digit grouping).}
  145. function IntToStrFmt(const I: Int64): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
  146. { Returns string representation of float number (with digit grouping).}
  147. function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
  148. { Clamps integer value to range <Min, Max>}
  149. function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  150. { Clamps float value to range <Min, Max>}
  151. function ClampFloat(Number: Single; Min, Max: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
  152. { Clamps integer value to Byte boundaries.}
  153. function ClampToByte(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  154. { Clamps integer value to Word boundaries.}
  155. function ClampToWord(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  156. { Returns True if Num is power of 2.}
  157. function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
  158. { Returns next power of 2 greater than or equal to Num
  159. (if Num itself is power of 2 then it retuns Num).}
  160. function NextPow2(Num: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  161. { Raises 2 to the given integer power (in range [0, 30]).}
  162. function Pow2Int(Exponent: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  163. { Raises Base to any power.}
  164. function Power(const Base, Exponent: Single): Single;
  165. { Returns log base 2 of integer X (max 2^30) or -1 if X is not power of 2.}
  166. function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  167. { Returns log base 2 of X.}
  168. function Log2(X: Single): Single;
  169. { Returns largest integer <= Val (for 5.9 returns 5).}
  170. function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  171. { Returns smallest integer >= Val (for 5.1 returns 6).}
  172. function Ceil(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  173. { Returns lesser of two integer numbers.}
  174. function Min(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  175. { Returns lesser of two float numbers.}
  176. function MinFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
  177. { Returns greater of two integer numbers.}
  178. function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
  179. { Returns greater of two float numbers.}
  180. function MaxFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
  181. { Returns result from multiplying Number by Numerator and then dividing by Denominator.
  182. Denominator must be greater than 0.}
  183. function MulDiv(Number, Numerator, Denominator: Word): Word; {$IFDEF USE_INLINE}inline;{$ENDIF}
  184. { Switches Boolean value.}
  185. procedure Switch(var Value: Boolean); {$IFDEF USE_INLINE}inline;{$ENDIF}
  186. { If Condition is True then TruePart is retured, otherwise
  187. FalsePart is returned.}
  188. function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  189. { If Condition is True then TruePart is retured, otherwise
  190. FalsePart is returned.}
  191. function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  192. { If Condition is True then TruePart is retured, otherwise
  193. FalsePart is returned.}
  194. function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  195. { If Condition is True then TruePart is retured, otherwise
  196. FalsePart is returned.}
  197. function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  198. { If Condition is True then TruePart is retured, otherwise
  199. FalsePart is returned.}
  200. function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  201. { If Condition is True then TruePart is retured, otherwise
  202. FalsePart is returned.}
  203. function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  204. { If Condition is True then TruePart is retured, otherwise
  205. FalsePart is returned.}
  206. function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  207. { If Condition is True then TruePart is retured, otherwise
  208. FalsePart is returned.}
  209. function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
  210. { Swaps two Byte values}
  211. procedure SwapValues(var A, B: Byte); overload;
  212. { Swaps two Word values}
  213. procedure SwapValues(var A, B: Word); overload;
  214. { Swaps two LongInt values}
  215. procedure SwapValues(var A, B: LongInt); overload;
  216. { Swaps two Single values}
  217. procedure SwapValues(var A, B: Single); overload;
  218. { Swaps two LongInt values if necessary to ensure that Min <= Max.}
  219. procedure SwapMin(var Min, Max: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
  220. { This function returns True if running on little endian machine.}
  221. function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
  222. { Swaps byte order of Word value.}
  223. function SwapEndianWord(Value: Word): Word; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  224. { Swaps byte order of multiple Word values.}
  225. procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload;
  226. { Swaps byte order of LongWord value.}
  227. function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  228. { Swaps byte order of multiple LongWord values.}
  229. procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload;
  230. { Calculates CRC32 for the given data.}
  231. procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
  232. { Fills given memory with given Byte value. Size is size of buffer in bytes.}
  233. procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
  234. { Fills given memory with given Word value. Size is size of buffer in bytes.}
  235. procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
  236. { Fills given memory with given LongWord value. Size is size of buffer in bytes.}
  237. procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
  238. { Returns how many mipmap levels can be created for image of given size.}
  239. function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
  240. { Returns total number of levels of volume texture with given depth and
  241. mipmap count (this is not depth * mipmaps!).}
  242. function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
  243. { Returns rectangle (X, Y, X + Width, Y + Height).}
  244. function BoundsToRect(X, Y, Width, Height: LongInt): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  245. { Returns rectangle (R.Left, R.Top, R.Left + R.Right, R.Top + R.Bottom).}
  246. function BoundsToRect(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  247. { Returns rectangle (R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top).}
  248. function RectToBounds(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  249. { Clips given bounds to Clip rectangle.}
  250. procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
  251. { Clips given source bounds and dest position. It is used by various CopyRect
  252. functions that copy rect from one image to another. It handles clipping the same way
  253. as Win32 BitBlt function. }
  254. procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt;
  255. SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
  256. { Clips given source bounds and dest bounds. It is used by various StretchRect
  257. functions that stretch rectangle of pixels from one image to another.
  258. It handles clipping the same way as Win32 StretchBlt function. }
  259. procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
  260. DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
  261. { Scales one rectangle to fit into another. Proportions are preserved so
  262. it could be used for 'Stretch To Fit Window' image drawing for instance.}
  263. function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
  264. { Returns True if R1 fits into R2.}
  265. function RectInRect(const R1, R2: TRect): Boolean;
  266. { Returns True if R1 and R2 intersects.}
  267. function RectIntersects(const R1, R2: TRect): Boolean;
  268. { Formats given message for usage in Exception.Create(..). Use only
  269. in except block - returned message contains message of last raised exception.}
  270. function FormatExceptMsg(const Msg: string; const Args: array of const): string;
  271. { Outputs debug message - shows message dialog in Windows and writes to console
  272. in Linux/Unix.}
  273. procedure DebugMsg(const Msg: string; const Args: array of const);
  274. implementation
  275. uses
  276. {$IFDEF MSWINDOWS}
  277. Windows;
  278. {$ENDIF}
  279. {$IFDEF UNIX}
  280. {$IFDEF KYLIX}
  281. Libc;
  282. {$ELSE}
  283. Dos, BaseUnix, Unix;
  284. {$ENDIF}
  285. {$ENDIF}
  286. procedure FreeAndNil(var Obj);
  287. var
  288. Temp: TObject;
  289. begin
  290. Temp := TObject(Obj);
  291. Pointer(Obj) := nil;
  292. Temp.Free;
  293. end;
  294. procedure FreeMemNil(var P);
  295. begin
  296. FreeMem(Pointer(P));
  297. Pointer(P) := nil;
  298. end;
  299. procedure FreeMem(P: Pointer);
  300. begin
  301. if P <> nil then
  302. System.FreeMem(P);
  303. end;
  304. function GetExceptObject: Exception;
  305. begin
  306. Result := Exception(ExceptObject);
  307. end;
  308. {$IFDEF MSWINDOWS}
  309. var
  310. PerfFrequency: Int64;
  311. InvPerfFrequency: Single;
  312. function GetTimeMicroseconds: Int64;
  313. var
  314. Time: Int64;
  315. begin
  316. QueryPerformanceCounter(Time);
  317. Result := Round(1000000 * InvPerfFrequency * Time);
  318. end;
  319. {$ENDIF}
  320. {$IFDEF UNIX}
  321. function GetTimeMicroseconds: Int64;
  322. var
  323. TimeVal: TTimeVal;
  324. begin
  325. {$IFDEF KYLIX}
  326. GetTimeOfDay(TimeVal, nil);
  327. {$ELSE}
  328. fpGetTimeOfDay(@TimeVal, nil);
  329. {$ENDIF}
  330. Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec;
  331. end;
  332. {$ENDIF}
  333. {$IFDEF MSDOS}
  334. function GetTimeMicroseconds: Int64;
  335. asm
  336. XOR EAX, EAX
  337. CLI
  338. OUT $43, AL
  339. MOV EDX, FS:[$46C]
  340. IN AL, $40
  341. DB $EB, 0, $EB, 0, $EB, 0
  342. MOV AH, AL
  343. IN AL, $40
  344. DB $EB, 0, $EB, 0, $EB, 0
  345. XCHG AL, AH
  346. NEG AX
  347. MOVZX EDI, AX
  348. STI
  349. MOV EBX, $10000
  350. MOV EAX, EDX
  351. XOR EDX, EDX
  352. MUL EBX
  353. ADD EAX, EDI
  354. ADC EDX, 0
  355. PUSH EDX
  356. PUSH EAX
  357. MOV ECX, $82BF1000
  358. MOVZX EAX, WORD PTR FS:[$470]
  359. MUL ECX
  360. MOV ECX, EAX
  361. POP EAX
  362. POP EDX
  363. ADD EAX, ECX
  364. ADC EDX, 0
  365. end;
  366. {$ENDIF}
  367. function GetTimeMilliseconds: Int64;
  368. begin
  369. Result := GetTimeMicroseconds div 1000;
  370. end;
  371. function GetFileExt(const FileName: string): string;
  372. begin
  373. Result := ExtractFileExt(FileName);
  374. if Length(Result) > 1 then
  375. Delete(Result, 1, 1);
  376. end;
  377. function GetAppExe: string;
  378. {$IFDEF MSWINDOWS}
  379. var
  380. FileName: array[0..MAX_PATH] of Char;
  381. begin
  382. SetString(Result, FileName,
  383. Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
  384. {$ENDIF}
  385. {$IFDEF UNIX}
  386. {$IFDEF KYLIX}
  387. var
  388. FileName: array[0..FILENAME_MAX] of Char;
  389. begin
  390. SetString(Result, FileName,
  391. System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
  392. {$ELSE}
  393. begin
  394. Result := FExpand(ParamStr(0));
  395. {$ENDIF}
  396. {$ENDIF}
  397. {$IFDEF MSDOS}
  398. begin
  399. Result := ParamStr(0);
  400. {$ENDIF}
  401. end;
  402. function GetAppDir: string;
  403. begin
  404. Result := ExtractFileDir(GetAppExe);
  405. end;
  406. function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean): Boolean;
  407. var
  408. MaskLen, KeyLen : LongInt;
  409. function CharMatch(A, B: Char): Boolean;
  410. begin
  411. if CaseSensitive then
  412. Result := A = B
  413. else
  414. Result := AnsiUpperCase (A) = AnsiUpperCase (B);
  415. end;
  416. function MatchAt(MaskPos, KeyPos: LongInt): Boolean;
  417. begin
  418. while (MaskPos <= MaskLen) and (KeyPos <= KeyLen) do
  419. begin
  420. case Mask[MaskPos] of
  421. '?' :
  422. begin
  423. Inc(MaskPos);
  424. Inc(KeyPos);
  425. end;
  426. '*' :
  427. begin
  428. while (MaskPos <= MaskLen) and (Mask[MaskPos] = '*') do
  429. Inc(MaskPos);
  430. if MaskPos > MaskLen then
  431. begin
  432. Result := True;
  433. Exit;
  434. end;
  435. repeat
  436. if MatchAt(MaskPos, KeyPos) then
  437. begin
  438. Result := True;
  439. Exit;
  440. end;
  441. Inc(KeyPos);
  442. until KeyPos > KeyLen;
  443. Result := False;
  444. Exit;
  445. end;
  446. else
  447. if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then
  448. begin
  449. Result := False;
  450. Exit;
  451. end
  452. else
  453. begin
  454. Inc(MaskPos);
  455. Inc(KeyPos);
  456. end;
  457. end;
  458. end;
  459. while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do
  460. Inc(MaskPos);
  461. if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then
  462. begin
  463. Result := False;
  464. Exit;
  465. end;
  466. Result := True;
  467. end;
  468. begin
  469. MaskLen := Length(Mask);
  470. KeyLen := Length(FileName);
  471. if MaskLen = 0 then
  472. begin
  473. Result := True;
  474. Exit;
  475. end;
  476. Result := MatchAt(1, 1);
  477. end;
  478. function BuildFileList(Path: string; Attr: LongInt;
  479. Files: TStrings; Options: TFileListOptions): Boolean;
  480. var
  481. FileMask: string;
  482. RootDir: string;
  483. Folders: TStringList;
  484. CurrentItem: LongInt;
  485. Counter: LongInt;
  486. LocAttr: LongInt;
  487. procedure BuildFolderList;
  488. var
  489. FindInfo: TSearchRec;
  490. Rslt: LongInt;
  491. begin
  492. Counter := Folders.Count - 1;
  493. CurrentItem := 0;
  494. while CurrentItem <= Counter do
  495. begin
  496. // Searching for subfolders
  497. Rslt := SysUtils.FindFirst(Folders[CurrentItem] + '*', faDirectory, FindInfo);
  498. try
  499. while Rslt = 0 do
  500. begin
  501. if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') and
  502. (FindInfo.Attr and faDirectory = faDirectory) then
  503. Folders.Add(Folders[CurrentItem] + FindInfo.Name + PathDelim);
  504. Rslt := SysUtils.FindNext(FindInfo);
  505. end;
  506. finally
  507. SysUtils.FindClose(FindInfo);
  508. end;
  509. Counter := Folders.Count - 1;
  510. Inc(CurrentItem);
  511. end;
  512. end;
  513. procedure FillFileList(CurrentCounter: LongInt);
  514. var
  515. FindInfo: TSearchRec;
  516. Res: LongInt;
  517. CurrentFolder: string;
  518. begin
  519. CurrentFolder := Folders[CurrentCounter];
  520. Res := SysUtils.FindFirst(CurrentFolder + FileMask, LocAttr, FindInfo);
  521. if flRelNames in Options then
  522. CurrentFolder := ExtractRelativePath(RootDir, CurrentFolder);
  523. try
  524. while Res = 0 do
  525. begin
  526. if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') then
  527. begin
  528. if (flFullNames in Options) or (flRelNames in Options) then
  529. Files.Add(CurrentFolder + FindInfo.Name)
  530. else
  531. Files.Add(FindInfo.Name);
  532. end;
  533. Res := SysUtils.FindNext(FindInfo);
  534. end;
  535. finally
  536. SysUtils.FindClose(FindInfo);
  537. end;
  538. end;
  539. begin
  540. FileMask := ExtractFileName(Path);
  541. RootDir := ExtractFilePath(Path);
  542. Folders := TStringList.Create;
  543. Folders.Add(RootDir);
  544. Files.Clear;
  545. {$IFDEF DCC}
  546. {$WARN SYMBOL_PLATFORM OFF}
  547. {$ENDIF}
  548. if Attr = faAnyFile then
  549. LocAttr := faSysFile or faHidden or faArchive or faReadOnly
  550. else
  551. LocAttr := Attr;
  552. {$IFDEF DCC}
  553. {$WARN SYMBOL_PLATFORM ON}
  554. {$ENDIF}
  555. // Here's the recursive search for nested folders
  556. if flRecursive in Options then
  557. BuildFolderList;
  558. if Attr <> faDirectory then
  559. for Counter := 0 to Folders.Count - 1 do
  560. FillFileList(Counter)
  561. else
  562. Files.AddStrings(Folders);
  563. Folders.Free;
  564. Result := True;
  565. end;
  566. function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
  567. var
  568. I, X: LongInt;
  569. Len, LenSubStr: LongInt;
  570. begin
  571. I := Offset;
  572. LenSubStr := Length(SubStr);
  573. Len := Length(S) - LenSubStr + 1;
  574. while I <= Len do
  575. begin
  576. if S[I] = SubStr[1] then
  577. begin
  578. X := 1;
  579. while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
  580. Inc(X);
  581. if (X = LenSubStr) then
  582. begin
  583. Result := I;
  584. Exit;
  585. end;
  586. end;
  587. Inc(I);
  588. end;
  589. Result := 0;
  590. end;
  591. function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt;
  592. begin
  593. Result := PosEx(AnsiLowerCase(SubStr), AnsiLowerCase(S), Offset);
  594. end;
  595. function StrToken(var S: string; Sep: Char): string;
  596. var
  597. I: LongInt;
  598. begin
  599. I := Pos(Sep, S);
  600. if I <> 0 then
  601. begin
  602. Result := Copy(S, 1, I - 1);
  603. Delete(S, 1, I);
  604. end
  605. else
  606. begin
  607. Result := S;
  608. S := '';
  609. end;
  610. end;
  611. function StrTokenEnd(var S: string; Sep: Char): string;
  612. var
  613. I, J: LongInt;
  614. begin
  615. J := 0;
  616. I := Pos(Sep, S);
  617. while I <> 0 do
  618. begin
  619. J := I;
  620. I := PosEx(Sep, S, J + 1);
  621. end;
  622. if J <> 0 then
  623. begin
  624. Result := Copy(S, J + 1, MaxInt);
  625. Delete(S, J, MaxInt);
  626. end
  627. else
  628. begin
  629. Result := S;
  630. S := '';
  631. end;
  632. end;
  633. procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
  634. var
  635. Token, Str: string;
  636. begin
  637. Tokens.Clear;
  638. Str := S;
  639. while Str <> '' do
  640. begin
  641. Token := StrToken(Str, Sep);
  642. Tokens.Add(Token);
  643. end;
  644. end;
  645. function IntToStrFmt(const I: Int64): string;
  646. begin
  647. Result := Format('%.0n', [I * 1.0]);
  648. end;
  649. function FloatToStrFmt(const F: Double; Precision: Integer): string;
  650. begin
  651. Result := Format('%.' + IntToStr(Precision) + 'n', [F]);
  652. end;
  653. function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
  654. begin
  655. Result := Number;
  656. if Result < Min then
  657. Result := Min
  658. else if Result > Max then
  659. Result := Max;
  660. end;
  661. function ClampFloat(Number: Single; Min, Max: Single): Single;
  662. begin
  663. Result := Number;
  664. if Result < Min then
  665. Result := Min
  666. else if Result > Max then
  667. Result := Max;
  668. end;
  669. function ClampToByte(Value: LongInt): LongInt;
  670. begin
  671. Result := Value;
  672. if Result > 255 then
  673. Result := 255
  674. else if Result < 0 then
  675. Result := 0;
  676. end;
  677. function ClampToWord(Value: LongInt): LongInt;
  678. begin
  679. Result := Value;
  680. if Result > 65535 then
  681. Result := 65535
  682. else if Result < 0 then
  683. Result := 0;
  684. end;
  685. function IsPow2(Num: LongInt): Boolean;
  686. begin
  687. Result := (Num and -Num) = Num;
  688. end;
  689. function NextPow2(Num: LongInt): LongInt;
  690. begin
  691. Result := Num and -Num;
  692. while Result < Num do
  693. Result := Result shl 1;
  694. end;
  695. function Pow2Int(Exponent: LongInt): LongInt;
  696. begin
  697. Result := 1 shl Exponent;
  698. end;
  699. function Power(const Base, Exponent: Single): Single;
  700. begin
  701. if Exponent = 0.0 then
  702. Result := 1.0
  703. else if (Base = 0.0) and (Exponent > 0.0) then
  704. Result := 0.0
  705. else
  706. Result := Exp(Exponent * Ln(Base));
  707. end;
  708. function Log2Int(X: LongInt): LongInt;
  709. begin
  710. case X of
  711. 1: Result := 0;
  712. 2: Result := 1;
  713. 4: Result := 2;
  714. 8: Result := 3;
  715. 16: Result := 4;
  716. 32: Result := 5;
  717. 64: Result := 6;
  718. 128: Result := 7;
  719. 256: Result := 8;
  720. 512: Result := 9;
  721. 1024: Result := 10;
  722. 2048: Result := 11;
  723. 4096: Result := 12;
  724. 8192: Result := 13;
  725. 16384: Result := 14;
  726. 32768: Result := 15;
  727. 65536: Result := 16;
  728. 131072: Result := 17;
  729. 262144: Result := 18;
  730. 524288: Result := 19;
  731. 1048576: Result := 20;
  732. 2097152: Result := 21;
  733. 4194304: Result := 22;
  734. 8388608: Result := 23;
  735. 16777216: Result := 24;
  736. 33554432: Result := 25;
  737. 67108864: Result := 26;
  738. 134217728: Result := 27;
  739. 268435456: Result := 28;
  740. 536870912: Result := 29;
  741. 1073741824: Result := 30;
  742. else
  743. Result := -1;
  744. end;
  745. end;
  746. function Log2(X: Single): Single;
  747. const
  748. Ln2: Single = 0.6931471;
  749. begin
  750. Result := Ln(X) / Ln2;
  751. end;
  752. function Floor(Value: Single): LongInt;
  753. begin
  754. Result := Trunc(Value);
  755. if Frac(Value) < 0.0 then
  756. Dec(Result);
  757. end;
  758. function Ceil(Value: Single): LongInt;
  759. begin
  760. Result := Trunc(Value);
  761. if Frac(Value) > 0.0 then
  762. Inc(Result);
  763. end;
  764. procedure Switch(var Value: Boolean);
  765. begin
  766. Value := not Value;
  767. end;
  768. function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt;
  769. begin
  770. if Condition then
  771. Result := TruePart
  772. else
  773. Result := FalsePart;
  774. end;
  775. function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord;
  776. begin
  777. if Condition then
  778. Result := TruePart
  779. else
  780. Result := FalsePart;
  781. end;
  782. function Iff(Condition, TruePart, FalsePart: Boolean): Boolean;
  783. begin
  784. if Condition then
  785. Result := TruePart
  786. else
  787. Result := FalsePart;
  788. end;
  789. function Iff(Condition: Boolean; const TruePart, FalsePart: string): string;
  790. begin
  791. if Condition then
  792. Result := TruePart
  793. else
  794. Result := FalsePart;
  795. end;
  796. function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char;
  797. begin
  798. if Condition then
  799. Result := TruePart
  800. else
  801. Result := FalsePart;
  802. end;
  803. function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer;
  804. begin
  805. if Condition then
  806. Result := TruePart
  807. else
  808. Result := FalsePart;
  809. end;
  810. function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64;
  811. begin
  812. if Condition then
  813. Result := TruePart
  814. else
  815. Result := FalsePart;
  816. end;
  817. function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single;
  818. begin
  819. if Condition then
  820. Result := TruePart
  821. else
  822. Result := FalsePart;
  823. end;
  824. procedure SwapValues(var A, B: Byte);
  825. var
  826. Tmp: Byte;
  827. begin
  828. Tmp := A;
  829. A := B;
  830. B := Tmp;
  831. end;
  832. procedure SwapValues(var A, B: Word);
  833. var
  834. Tmp: Word;
  835. begin
  836. Tmp := A;
  837. A := B;
  838. B := Tmp;
  839. end;
  840. procedure SwapValues(var A, B: LongInt);
  841. var
  842. Tmp: LongInt;
  843. begin
  844. Tmp := A;
  845. A := B;
  846. B := Tmp;
  847. end;
  848. procedure SwapValues(var A, B: Single);
  849. var
  850. Tmp: Single;
  851. begin
  852. Tmp := A;
  853. A := B;
  854. B := Tmp;
  855. end;
  856. procedure SwapMin(var Min, Max: LongInt);
  857. var
  858. Tmp: LongInt;
  859. begin
  860. if Min > Max then
  861. begin
  862. Tmp := Min;
  863. Min := Max;
  864. Max := Tmp;
  865. end;
  866. end;
  867. function Min(A, B: LongInt): LongInt;
  868. begin
  869. if A < B then
  870. Result := A
  871. else
  872. Result := B;
  873. end;
  874. function MinFloat(A, B: Single): Single;
  875. begin
  876. if A < B then
  877. Result := A
  878. else
  879. Result := B;
  880. end;
  881. function Max(A, B: LongInt): LongInt;
  882. begin
  883. if A > B then
  884. Result := A
  885. else
  886. Result := B;
  887. end;
  888. function MaxFloat(A, B: Single): Single;
  889. begin
  890. if A > B then
  891. Result := A
  892. else
  893. Result := B;
  894. end;
  895. function MulDiv(Number, Numerator, Denominator: Word): Word;
  896. {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
  897. asm
  898. MUL DX
  899. DIV CX
  900. end;
  901. {$ELSE}
  902. begin
  903. Result := Number * Numerator div Denominator;
  904. end;
  905. {$IFEND}
  906. function IsLittleEndian: Boolean;
  907. var
  908. W: Word;
  909. begin
  910. W := $00FF;
  911. Result := PByte(@W)^ = $FF;
  912. end;
  913. function SwapEndianWord(Value: Word): Word;
  914. {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
  915. asm
  916. XCHG AH, AL
  917. end;
  918. {$ELSE}
  919. begin
  920. TWordRec(Result).Low := TWordRec(Value).High;
  921. TWordRec(Result).High := TWordRec(Value).Low;
  922. end;
  923. {$IFEND}
  924. procedure SwapEndianWord(P: PWordArray; Count: LongInt);
  925. {$IFDEF USE_ASM}
  926. asm
  927. @Loop:
  928. MOV CX, [EAX]
  929. XCHG CH, CL
  930. MOV [EAX], CX
  931. ADD EAX, 2
  932. DEC EDX
  933. JNZ @Loop
  934. end;
  935. {$ELSE}
  936. var
  937. I: LongInt;
  938. Temp: Word;
  939. begin
  940. for I := 0 to Count - 1 do
  941. begin
  942. Temp := P[I];
  943. TWordRec(P[I]).Low := TWordRec(Temp).High;
  944. TWordRec(P[I]).High := TWordRec(Temp).Low;
  945. end;
  946. end;
  947. {$ENDIF}
  948. function SwapEndianLongWord(Value: LongWord): LongWord;
  949. {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
  950. asm
  951. BSWAP EAX
  952. end;
  953. {$ELSE}
  954. begin
  955. TLongWordRec(Result).Bytes[0] := TLongWordRec(Value).Bytes[3];
  956. TLongWordRec(Result).Bytes[1] := TLongWordRec(Value).Bytes[2];
  957. TLongWordRec(Result).Bytes[2] := TLongWordRec(Value).Bytes[1];
  958. TLongWordRec(Result).Bytes[3] := TLongWordRec(Value).Bytes[0];
  959. end;
  960. {$IFEND}
  961. procedure SwapEndianLongWord(P: PLongWord; Count: LongInt);
  962. {$IFDEF USE_ASM}
  963. asm
  964. @Loop:
  965. MOV ECX, [EAX]
  966. BSWAP ECX
  967. MOV [EAX], ECX
  968. ADD EAX, 4
  969. DEC EDX
  970. JNZ @Loop
  971. end;
  972. {$ELSE}
  973. var
  974. I: LongInt;
  975. Temp: LongWord;
  976. begin
  977. for I := 0 to Count - 1 do
  978. begin
  979. Temp := PLongWordArray(P)[I];
  980. TLongWordRec(PLongWordArray(P)[I]).Bytes[0] := TLongWordRec(Temp).Bytes[3];
  981. TLongWordRec(PLongWordArray(P)[I]).Bytes[1] := TLongWordRec(Temp).Bytes[2];
  982. TLongWordRec(PLongWordArray(P)[I]).Bytes[2] := TLongWordRec(Temp).Bytes[1];
  983. TLongWordRec(PLongWordArray(P)[I]).Bytes[3] := TLongWordRec(Temp).Bytes[0];
  984. end;
  985. end;
  986. {$ENDIF}
  987. type
  988. TCrcTable = array[Byte] of LongWord;
  989. var
  990. CrcTable: TCrcTable;
  991. procedure InitCrcTable;
  992. const
  993. Polynom = $EDB88320;
  994. var
  995. I, J: LongInt;
  996. C: LongWord;
  997. begin
  998. for I := 0 to 255 do
  999. begin
  1000. C := I;
  1001. for J := 0 to 7 do
  1002. begin
  1003. if (C and $01) <> 0 then
  1004. C := Polynom xor (C shr 1)
  1005. else
  1006. C := C shr 1;
  1007. end;
  1008. CrcTable[I] := C;
  1009. end;
  1010. end;
  1011. procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
  1012. var
  1013. I: LongInt;
  1014. B: PByte;
  1015. begin
  1016. B := Data;
  1017. for I := 0 to Size - 1 do
  1018. begin
  1019. Crc := (Crc shr 8) xor CrcTable[B^ xor Byte(Crc)];
  1020. Inc(B);
  1021. end
  1022. end;
  1023. procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
  1024. {$IFDEF USE_ASM}
  1025. asm
  1026. PUSH EDI
  1027. MOV EDI, EAX
  1028. MOV EAX, ECX
  1029. MOV AH, AL
  1030. MOV CX, AX
  1031. SHL EAX, 16
  1032. MOV AX, CX
  1033. MOV ECX, EDX
  1034. SAR ECX, 2
  1035. JS @Exit
  1036. REP STOSD
  1037. MOV ECX, EDX
  1038. AND ECX, 3
  1039. REP STOSB
  1040. POP EDI
  1041. @Exit:
  1042. end;
  1043. {$ELSE}
  1044. begin
  1045. FillChar(Data^, Size, Value);
  1046. end;
  1047. {$ENDIF}
  1048. procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
  1049. {$IFDEF USE_ASM}
  1050. asm
  1051. PUSH EDI
  1052. PUSH EBX
  1053. MOV EBX, EDX
  1054. MOV EDI, EAX
  1055. MOV EAX, ECX
  1056. MOV CX, AX
  1057. SHL EAX, 16
  1058. MOV AX, CX
  1059. MOV ECX, EDX
  1060. SHR ECX, 2
  1061. JZ @Word
  1062. REP STOSD
  1063. @Word:
  1064. MOV ECX, EBX
  1065. AND ECX, 2
  1066. JZ @Byte
  1067. MOV [EDI], AX
  1068. ADD EDI, 2
  1069. @Byte:
  1070. MOV ECX, EBX
  1071. AND ECX, 1
  1072. JZ @Exit
  1073. MOV [EDI], AL
  1074. @Exit:
  1075. POP EBX
  1076. POP EDI
  1077. end;
  1078. {$ELSE}
  1079. var
  1080. I, V: LongWord;
  1081. begin
  1082. V := Value * $10000 + Value;
  1083. for I := 0 to Size div 4 - 1 do
  1084. PLongWordArray(Data)[I] := V;
  1085. case Size mod 4 of
  1086. 1: PByteArray(Data)[Size - 1] := Lo(Value);
  1087. 2: PWordArray(Data)[Size div 2] := Value;
  1088. 3:
  1089. begin
  1090. PWordArray(Data)[Size div 2 - 1] := Value;
  1091. PByteArray(Data)[Size - 1] := Lo(Value);
  1092. end;
  1093. end;
  1094. end;
  1095. {$ENDIF}
  1096. procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
  1097. {$IFDEF USE_ASM}
  1098. asm
  1099. PUSH EDI
  1100. PUSH EBX
  1101. MOV EBX, EDX
  1102. MOV EDI, EAX
  1103. MOV EAX, ECX
  1104. MOV ECX, EDX
  1105. SHR ECX, 2
  1106. JZ @Word
  1107. REP STOSD
  1108. @Word:
  1109. MOV ECX, EBX
  1110. AND ECX, 2
  1111. JZ @Byte
  1112. MOV [EDI], AX
  1113. ADD EDI, 2
  1114. @Byte:
  1115. MOV ECX, EBX
  1116. AND ECX, 1
  1117. JZ @Exit
  1118. MOV [EDI], AL
  1119. @Exit:
  1120. POP EBX
  1121. POP EDI
  1122. end;
  1123. {$ELSE}
  1124. var
  1125. I: LongInt;
  1126. begin
  1127. for I := 0 to Size div 4 - 1 do
  1128. PLongWordArray(Data)[I] := Value;
  1129. case Size mod 4 of
  1130. 1: PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
  1131. 2: PWordArray(Data)[Size div 2] := TLongWordRec(Value).Words[0];
  1132. 3:
  1133. begin
  1134. PWordArray(Data)[Size div 2 - 1] := TLongWordRec(Value).Words[0];
  1135. PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
  1136. end;
  1137. end;
  1138. end;
  1139. {$ENDIF}
  1140. function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
  1141. begin
  1142. Result := 0;
  1143. if (Width > 0) and (Height > 0) then
  1144. begin
  1145. Result := 1;
  1146. while (Width <> 1) or (Height <> 1) do
  1147. begin
  1148. Width := Width div 2;
  1149. Height := Height div 2;
  1150. if Width < 1 then Width := 1;
  1151. if Height < 1 then Height := 1;
  1152. Inc(Result);
  1153. end;
  1154. end;
  1155. end;
  1156. function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
  1157. var
  1158. I: LongInt;
  1159. begin
  1160. Result := Depth;
  1161. for I := 1 to MipMaps - 1 do
  1162. Inc(Result, ClampInt(Depth shr I, 1, Depth));
  1163. end;
  1164. function BoundsToRect(X, Y, Width, Height: LongInt): TRect;
  1165. begin
  1166. Result.Left := X;
  1167. Result.Top := Y;
  1168. Result.Right := X + Width;
  1169. Result.Bottom := Y + Height;
  1170. end;
  1171. function BoundsToRect(const R: TRect): TRect;
  1172. begin
  1173. Result.Left := R.Left;
  1174. Result.Top := R.Top;
  1175. Result.Right := R.Left + R.Right;
  1176. Result.Bottom := R.Top + R.Bottom;
  1177. end;
  1178. function RectToBounds(const R: TRect): TRect;
  1179. begin
  1180. Result.Left := R.Left;
  1181. Result.Top := R.Top;
  1182. Result.Right := R.Right - R.Left;
  1183. Result.Bottom := R.Bottom - R.Top;
  1184. end;
  1185. procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
  1186. procedure ClipDim(var AStart, ALength: LongInt; ClipMin, ClipMax: LongInt);
  1187. begin
  1188. if AStart < ClipMin then
  1189. begin
  1190. ALength := ALength - (ClipMin - AStart);
  1191. AStart := ClipMin;
  1192. end;
  1193. if AStart + ALength > ClipMax then ALength := Max(0, ClipMax - AStart);
  1194. end;
  1195. begin
  1196. ClipDim(X, Width, Clip.Left, Clip.Right);
  1197. ClipDim(Y, Height, Clip.Top, Clip.Bottom);
  1198. end;
  1199. procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
  1200. procedure ClipDim(var SrcPos, DstPos, Size: LongInt; SrcClipMax,
  1201. DstClipMin, DstClipMax: LongInt);
  1202. var
  1203. OldDstPos: LongInt;
  1204. Diff: LongInt;
  1205. begin
  1206. OldDstPos := Iff(DstPos < 0, DstPos, 0);
  1207. if DstPos < DstClipMin then
  1208. begin
  1209. Diff := DstClipMin - DstPos;
  1210. Size := Size - Diff;
  1211. SrcPos := SrcPos + Diff;
  1212. DstPos := DstClipMin;
  1213. end;
  1214. if SrcPos < 0 then
  1215. begin
  1216. Size := Size + SrcPos - OldDstPos;
  1217. DstPos := DstPos - SrcPos + OldDstPos;
  1218. SrcPos := 0;
  1219. end;
  1220. if SrcPos + Size > SrcClipMax then Size := SrcClipMax - SrcPos;
  1221. if DstPos + Size > DstClipMax then Size := DstClipMax - DstPos;
  1222. end;
  1223. begin
  1224. ClipDim(SrcX, DstX, Width, SrcImageWidth, DstClip.Left, DstClip.Right);
  1225. ClipDim(SrcY, DstY, Height, SrcImageHeight, DstClip.Top, DstClip.Bottom);
  1226. end;
  1227. procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
  1228. DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
  1229. procedure ClipDim(var SrcPos, DstPos, SrcSize, DstSize: LongInt; SrcClipMax,
  1230. DstClipMin, DstClipMax: LongInt);
  1231. var
  1232. OldSize: LongInt;
  1233. Diff: LongInt;
  1234. Scale: Single;
  1235. begin
  1236. Scale := DstSize / SrcSize;
  1237. if DstPos < DstClipMin then
  1238. begin
  1239. Diff := DstClipMin - DstPos;
  1240. DstSize := DstSize - Diff;
  1241. SrcPos := SrcPos + Round(Diff / Scale);
  1242. SrcSize := SrcSize - Round(Diff / Scale);
  1243. DstPos := DstClipMin;
  1244. end;
  1245. if SrcPos < 0 then
  1246. begin
  1247. SrcSize := SrcSize + SrcPos;
  1248. DstPos := DstPos - Round(SrcPos * Scale);
  1249. DstSize := DstSize + Round(SrcPos * Scale);
  1250. SrcPos := 0;
  1251. end;
  1252. if SrcPos + SrcSize > SrcClipMax then
  1253. begin
  1254. OldSize := SrcSize;
  1255. SrcSize := SrcClipMax - SrcPos;
  1256. DstSize := Round(DstSize * (SrcSize / OldSize));
  1257. end;
  1258. if DstPos + DstSize > DstClipMax then
  1259. begin
  1260. OldSize := DstSize;
  1261. DstSize := DstClipMax - DstPos;
  1262. SrcSize := Round(SrcSize * (DstSize / OldSize));
  1263. end;
  1264. end;
  1265. begin
  1266. ClipDim(SrcX, DstX, SrcWidth, DstWidth, SrcImageWidth, DstClip.Left, DstClip.Right);
  1267. ClipDim(SrcY, DstY, SrcHeight, DstHeight, SrcImageHeight, DstClip.Top, DstClip.Bottom);
  1268. end;
  1269. function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
  1270. var
  1271. SourceWidth: LongInt;
  1272. SourceHeight: LongInt;
  1273. TargetWidth: LongInt;
  1274. TargetHeight: LongInt;
  1275. ScaledWidth: LongInt;
  1276. ScaledHeight: LongInt;
  1277. begin
  1278. SourceWidth := SourceRect.Right - SourceRect.Left;
  1279. SourceHeight := SourceRect.Bottom - SourceRect.Top;
  1280. TargetWidth := TargetRect.Right - TargetRect.Left;
  1281. TargetHeight := TargetRect.Bottom - TargetRect.Top;
  1282. if SourceWidth * TargetHeight < SourceHeight * TargetWidth then
  1283. begin
  1284. ScaledWidth := (SourceWidth * TargetHeight) div SourceHeight;
  1285. Result := BoundsToRect(TargetRect.Left + ((TargetWidth - ScaledWidth) div 2),
  1286. TargetRect.Top, ScaledWidth, TargetHeight);
  1287. end
  1288. else
  1289. begin
  1290. ScaledHeight := (SourceHeight * TargetWidth) div SourceWidth;
  1291. Result := BoundsToRect(TargetRect.Left, TargetRect.Top + ((TargetHeight - ScaledHeight) div 2),
  1292. TargetWidth, ScaledHeight);
  1293. end;
  1294. end;
  1295. function RectInRect(const R1, R2: TRect): Boolean;
  1296. begin
  1297. Result:=
  1298. (R1.Left >= R2.Left) and
  1299. (R1.Top >= R2.Top) and
  1300. (R1.Right <= R2.Right) and
  1301. (R1.Bottom <= R2.Bottom);
  1302. end;
  1303. function RectIntersects(const R1, R2: TRect): Boolean;
  1304. begin
  1305. Result :=
  1306. not (R1.Left > R2.Right) and
  1307. not (R1.Top > R2.Bottom) and
  1308. not (R1.Right < R2.Left) and
  1309. not (R1.Bottom < R2.Top);
  1310. end;
  1311. function FormatExceptMsg(const Msg: string; const Args: array of const): string;
  1312. begin
  1313. Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args);
  1314. end;
  1315. procedure DebugMsg(const Msg: string; const Args: array of const);
  1316. var
  1317. FmtMsg: string;
  1318. begin
  1319. FmtMsg := Format(Msg, Args);
  1320. {$IFDEF MSWINDOWS}
  1321. if IsConsole then
  1322. WriteLn('DebugMsg: ' + FmtMsg)
  1323. else
  1324. MessageBox(GetActiveWindow, PChar(FmtMsg), 'DebugMsg', MB_OK);
  1325. {$ENDIF}
  1326. {$IFDEF UNIX}
  1327. WriteLn('DebugMsg: ' + FmtMsg);
  1328. {$ENDIF}
  1329. {$IFDEF MSDOS}
  1330. WriteLn('DebugMsg: ' + FmtMsg);
  1331. {$ENDIF}
  1332. end;
  1333. initialization
  1334. InitCrcTable;
  1335. {$IFDEF MSWINDOWS}
  1336. QueryPerformanceFrequency(PerfFrequency);
  1337. InvPerfFrequency := 1.0 / PerfFrequency;
  1338. {$ENDIF}
  1339. {$IFDEF MSDOS}
  1340. // reset PIT
  1341. asm
  1342. MOV EAX, $34
  1343. OUT $43, AL
  1344. XOR EAX, EAX
  1345. OUT $40, AL
  1346. OUT $40, AL
  1347. end;
  1348. {$ENDIF}
  1349. {
  1350. File Notes:
  1351. -- TODOS ----------------------------------------------------
  1352. - nothing now
  1353. -- 0.26.1 Changes/Bug Fixes -----------------------------------
  1354. - Some formatting changes.
  1355. - Changed some string functions to work with localized strings.
  1356. - ASM version of PosEx had bugs, removed it.
  1357. - Added StrTokensToList function.
  1358. -- 0.25.0 Changes/Bug Fixes -----------------------------------
  1359. - Fixed error in ClipCopyBounds which was causing ... bad clipping!
  1360. -- 0.24.3 Changes/Bug Fixes -----------------------------------
  1361. - Added GetTimeMilliseconds function.
  1362. - Added IntToStrFmt and FloatToStrFmt helper functions.
  1363. -- 0.23 Changes/Bug Fixes -----------------------------------
  1364. - Added RectInRect and RectIntersects functions
  1365. - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase.
  1366. - Moved BuildFileList here from DemoUtils.
  1367. -- 0.21 Changes/Bug Fixes -----------------------------------
  1368. - Moved GetVolumeLevelCount from ImagingDds here.
  1369. - Renamed FillMemory to FillMemoryByte to avoid name collision in C++ Builder.
  1370. - Added Iff function for Char, Pointer, and Int64 types.
  1371. - Added IsLittleEndian function.
  1372. - Added array types for TWordRec, TLongWordRec, and TInt64Rec.
  1373. - Added MatchFileNameMask function.
  1374. -- 0.19 Changes/Bug Fixes -----------------------------------
  1375. - added ScaleRectToRect (thanks to Paul Michell)
  1376. - added BoundsToRect, ClipBounds, ClipCopyBounds, ClipStretchBounds functions
  1377. - added MulDiv function
  1378. - FreeAndNil is not inline anymore - caused AV in one program
  1379. -- 0.17 Changes/Bug Fixes -----------------------------------
  1380. - GetAppExe didn't return absolute path in FreeBSD, fixed
  1381. - added debug message output
  1382. - fixed Unix compatibility issues (thanks to Ales Katona).
  1383. Imaging now compiles in FreeBSD and maybe in other Unixes as well.
  1384. -- 0.15 Changes/Bug Fixes -----------------------------------
  1385. - added some new utility functions
  1386. -- 0.13 Changes/Bug Fixes -----------------------------------
  1387. - added many new utility functions
  1388. - minor change in SwapEndian to avoid range check error
  1389. }
  1390. end.