ImagingUtility.pas 41 KB

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