DEADSOFTWARE

libs: sync vampimg with d2df-sdl
[d2df-editor.git] / src / lib / vampimg / ImagingUtility.pas
1 {
2 Vampyre Imaging Library
3 by Marek Mauder
4 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
11 Software distributed under the License is distributed on an "AS IS" basis,
12 WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
13 the specific language governing rights and limitations under the License.
15 Alternatively, the contents of this file may be used under the terms of the
16 GNU Lesser General Public License (the "LGPL License"), in which case the
17 provisions of the LGPL License are applicable instead of those above.
18 If you wish to allow use of your version of this file only under the terms
19 of the LGPL License and not to allow others to use your version of this file
20 under the MPL, indicate your decision by deleting the provisions above and
21 replace them with the notice and other provisions required by the LGPL
22 License. If you do not delete the provisions above, a recipient may use
23 your version of this file under either the MPL or the LGPL License.
25 For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
26 }
28 { This unit contains utility functions and types for Imaging library.}
29 unit ImagingUtility;
31 {$I ImagingOptions.inc}
33 interface
35 uses
36 SysUtils, Classes, Types;
38 const
39 STrue = 'True';
40 SFalse = 'False';
42 type
43 TByteArray = array[0..MaxInt - 1] of Byte;
44 PByteArray = ^TByteArray;
45 TWordArray = array[0..MaxInt div 2 - 1] of Word;
46 PWordArray = ^TWordArray;
47 TLongIntArray = array[0..MaxInt div 4 - 1] of LongInt;
48 PLongIntArray = ^TLongIntArray;
49 TLongWordArray = array[0..MaxInt div 4 - 1] of LongWord;
50 PLongWordArray = ^TLongWordArray;
51 TInt64Array = array[0..MaxInt div 8 - 1] of Int64;
52 PInt64Array = ^TInt64Array;
53 TSingleArray = array[0..MaxInt div 4 - 1] of Single;
54 PSingleArray = ^TSingleArray;
55 TBooleanArray = array[0..MaxInt - 1] of Boolean;
56 PBooleanArray = ^TBooleanArray;
58 TDynByteArray = array of Byte;
59 TDynIntegerArray = array of Integer;
60 TDynBooleanArray = array of Boolean;
61 TDynStringArray = array of string;
63 TWordRec = packed record
64 case Integer of
65 0: (WordValue: Word);
66 1: (Low, High: Byte);
67 end;
68 PWordRec = ^TWordRec;
69 TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec;
70 PWordRecArray = ^TWordRecArray;
72 TLongWordRec = packed record
73 case Integer of
74 0: (LongWordValue: LongWord);
75 1: (Low, High: Word);
76 { Array variants - Index 0 means lowest significant byte (word, ...).}
77 2: (Words: array[0..1] of Word);
78 3: (Bytes: array[0..3] of Byte);
79 end;
80 PLongWordRec = ^TLongWordRec;
81 TLongWordRecArray = array[0..MaxInt div 4 - 1] of TLongWordRec;
82 PLongWordRecArray = ^TLongWordRecArray;
84 TInt64Rec = packed record
85 case Integer of
86 0: (Int64Value: Int64);
87 1: (Low, High: LongWord);
88 { Array variants - Index 0 means lowest significant byte (word, ...).}
89 2: (Words: array[0..3] of Word);
90 3: (Bytes: array[0..7] of Byte);
91 end;
92 PInt64Rec = ^TInt64Rec;
93 TInt64RecArray = array[0..MaxInt div 8 - 1] of TInt64Rec;
94 PInt64RecArray = ^TInt64RecArray;
96 TFloatHelper = record
97 Data: Int64;
98 case Integer of
99 0: (Data64: Int64);
100 1: (Data32: LongWord);
101 end;
102 PFloatHelper = ^TFloatHelper;
104 TFloatRect = record
105 Left, Top, Right, Bottom: Single;
106 end;
108 TChar2 = array[0..1] of AnsiChar;
109 TChar3 = array[0..2] of AnsiChar;
110 TChar4 = array[0..3] of AnsiChar;
111 TChar8 = array[0..7] of AnsiChar;
112 TChar16 = array[0..15] of AnsiChar;
113 TAnsiCharSet = set of AnsiChar;
115 ENotImplemented = class(Exception)
116 public
117 constructor Create;
118 end;
120 { Options for BuildFileList function:
121 flFullNames - file names in result will have full path names
122 (ExtractFileDir(Path) + FileName)
123 flRelNames - file names in result will have names relative to
124 ExtractFileDir(Path) dir
125 flRecursive - adds files in subdirectories found in Path.}
126 TFileListOption = (flFullNames, flRelNames, flRecursive);
127 TFileListOptions = set of TFileListOption;
130 { Frees class instance and sets its reference to nil.}
131 procedure FreeAndNil(var Obj);
132 { Frees pointer and sets it to nil.}
133 procedure FreeMemNil(var P); {$IFDEF USE_INLINE}inline;{$ENDIF}
134 { Replacement of standard System.FreeMem procedure which checks if P is nil
135 (this is only needed for Free Pascal, Delphi makes checks in its FreeMem).}
136 procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF}
137 { Returns current exception object. Do not call outside exception handler.}
138 function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF}
139 { Returns time value with microsecond resolution.}
140 function GetTimeMicroseconds: Int64;
141 { Returns time value with milisecond resolution.}
142 function GetTimeMilliseconds: Int64;
144 { Returns file extension (without "." dot)}
145 function GetFileExt(const FileName: string): string;
146 { Returns file name of application's executable.}
147 function GetAppExe: string;
148 { Returns directory where application's exceutable is located without
149 path delimiter at the end.}
150 function GetAppDir: string;
151 { Works like SysUtils.ExtractFileName but supports '/' and '\' dir delimiters
152 at the same time (whereas ExtractFileName supports on default delimiter on current platform).}
153 function GetFileName(const FileName: string): string;
154 { Works like SysUtils.ExtractFileDir but supports '/' and '\' dir delimiters
155 at the same time (whereas ExtractFileDir supports on default delimiter on current platform).}
156 function GetFileDir(const FileName: string): string;
157 { Returns True if Subject matches given Mask with optional case sensitivity.
158 Mask can contain ? and * special characters: ? matches
159 one character, * matches zero or more characters.}
160 function StrMaskMatch(const Subject, Mask: string; CaseSensitive: Boolean = False): Boolean;
161 { This function fills Files string list with names of files found
162 with FindFirst/FindNext functions (See details on Path/Atrr here).
163 - BuildFileList('c:\*.*', faAnyFile, List, [flRecursive]) returns
164 list of all files (only name.ext - no path) on C drive
165 - BuildFileList('d:\*.*', faDirectory, List, [flFullNames]) returns
166 list of all directories (d:\dirxxx) in root of D drive.}
167 function BuildFileList(Path: string; Attr: LongInt; Files: TStrings;
168 Options: TFileListOptions = []): Boolean;
169 { Similar to RTL's Pos function but with optional Offset where search will start.
170 This function is in the RTL StrUtils unit but }
171 function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
172 { Same as PosEx but without case sensitivity.}
173 function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
174 { Returns a sub-string from S which is followed by
175 Sep separator and deletes the sub-string from S including the separator.}
176 function StrToken(var S: string; Sep: Char): string;
177 { Same as StrToken but searches from the end of S string.}
178 function StrTokenEnd(var S: string; Sep: Char): string;
179 { Fills instance of TStrings with tokens from string S where tokens are separated by
180 one of Seps characters.}
181 procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
182 { Returns string representation of integer number (with digit grouping).
183 Uses current locale.}
184 function IntToStrFmt(const I: Int64): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
185 { Returns string representation of float number (with digit grouping).
186 Uses current locale.}
187 function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
188 { Returns format settings for parsing floats (dot as decimal separator).
189 Useful when fomatting/parsing floats etc.}
190 function GetFormatSettingsForFloats: TFormatSettings;
191 { Returns True if S contains at least one of the substrings in SubStrs array. Case sensitive.}
192 function ContainsAnySubStr(const S: string; const SubStrs: array of string): Boolean;
193 { Extracts substring starting at IdxStart ending at IdxEnd.
194 S[IdxEnd] is not included in the result.}
195 function SubString(const S: string; IdxStart, IdxEnd: Integer): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
197 { Clamps integer value to range <Min, Max>}
198 function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
199 { Clamps float value to range <Min, Max>}
200 function ClampFloat(Number: Single; Min, Max: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
201 { Clamps integer value to Byte boundaries.}
202 function ClampToByte(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
203 { Clamps integer value to Word boundaries.}
204 function ClampToWord(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
205 { Returns True if Num is power of 2.}
206 function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
207 { Returns next power of 2 greater than or equal to Num
208 (if Num itself is power of 2 then it retuns Num).}
209 function NextPow2(Num: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
210 { Raises 2 to the given integer power (in range [0, 30]).}
211 function Pow2Int(Exponent: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
212 { Raises Base to any power.}
213 function Power(const Base, Exponent: Single): Single;
214 { Returns log base 2 of integer X (max 2^30) or -1 if X is not power of 2.}
215 function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
216 { Returns log base 2 of X.}
217 function Log2(X: Single): Single;
218 { Returns log base 10 of X.}
219 function Log10(X: Single): Single;
220 { Returns largest integer <= Val (for 5.9 returns 5).}
221 function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
222 { Returns smallest integer >= Val (for 5.1 returns 6).}
223 function Ceil(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
224 { Returns lesser of two integer numbers.}
225 function Min(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
226 { Returns lesser of two float numbers.}
227 function MinFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
228 { Returns greater of two integer numbers.}
229 function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
230 { Returns greater of two float numbers.}
231 function MaxFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
232 { Returns result from multiplying Number by Numerator and then dividing by Denominator.
233 Denominator must be greater than 0.}
234 function MulDiv(Number, Numerator, Denominator: Word): Word; {$IFDEF USE_INLINE}inline;{$ENDIF}
236 { Switches Boolean value.}
237 procedure Switch(var Value: Boolean); {$IFDEF USE_INLINE}inline;{$ENDIF}
238 { If Condition is True then TruePart is retured, otherwise
239 FalsePart is returned.}
240 function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
241 { If Condition is True then TruePart is retured, otherwise
242 FalsePart is returned.}
243 function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
244 { If Condition is True then TruePart is retured, otherwise
245 FalsePart is returned.}
246 function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
247 { If Condition is True then TruePart is retured, otherwise
248 FalsePart is returned.}
249 function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
250 { If Condition is True then TruePart is retured, otherwise
251 FalsePart is returned.}
252 function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
253 { If Condition is True then TruePart is retured, otherwise
254 FalsePart is returned.}
255 function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
256 { If Condition is True then TruePart is retured, otherwise
257 FalsePart is returned.}
258 function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
259 { If Condition is True then TruePart is retured, otherwise
260 FalsePart is returned.}
261 function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
262 { Swaps two Boolean values}
263 procedure SwapValues(var A, B: Boolean); overload;
264 { Swaps two Byte values}
265 procedure SwapValues(var A, B: Byte); overload;
266 { Swaps two Word values}
267 procedure SwapValues(var A, B: Word); overload;
268 { Swaps two LongInt values}
269 procedure SwapValues(var A, B: LongInt); overload;
270 { Swaps two Single values}
271 procedure SwapValues(var A, B: Single); overload;
272 { Swaps two LongInt values if necessary to ensure that Min <= Max.}
273 procedure SwapMin(var Min, Max: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
274 { This function returns True if running on little endian machine.}
275 function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
276 { Swaps byte order of Word value.}
277 function SwapEndianWord(Value: Word): Word; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
278 { Swaps byte order of multiple Word values.}
279 procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload;
280 { Swaps byte order of LongWord value.}
281 function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
282 { Swaps byte order of multiple LongWord values.}
283 procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload;
285 { Calculates CRC32 for the given data.}
286 procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
287 { Fills given memory with given Byte value. Size is size of buffer in bytes.}
288 procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
289 { Fills given memory with given Word value. Size is size of buffer in bytes.}
290 procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
291 { Fills given memory with given LongWord value. Size is size of buffer in bytes.}
292 procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
293 { Fills given memory zeroes.}
294 {$EXTERNALSYM ZeroMemory} // Conflicts with WinAPI ZeroMemory in C++ Builder
295 procedure ZeroMemory(Data: Pointer; Size: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
297 { Returns how many mipmap levels can be created for image of given size.}
298 function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
299 { Returns total number of levels of volume texture with given depth and
300 mipmap count (this is not depth * mipmaps!).}
301 function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
302 { Returns rectangle (X, Y, X + Width, Y + Height).}
303 function BoundsToRect(X, Y, Width, Height: LongInt): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
304 { Returns rectangle (R.Left, R.Top, R.Left + R.Right, R.Top + R.Bottom).}
305 function BoundsToRect(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
306 { Returns rectangle (R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top).}
307 function RectToBounds(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
308 { Clips given bounds to Clip rectangle.}
309 procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
310 { Clips given source bounds and dest position. It is used by various CopyRect
311 functions that copy rect from one image to another. It handles clipping the same way
312 as Win32 BitBlt function. }
313 procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt;
314 SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
315 { Clips given source bounds and dest bounds. It is used by various StretchRect
316 functions that stretch rectangle of pixels from one image to another.
317 It handles clipping the same way as Win32 StretchBlt function. }
318 procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
319 DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
320 { Scales one rectangle to fit into another. Proportions are preserved so
321 it could be used for 'Stretch To Fit Window' image drawing for instance.}
322 function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
323 { Scales given size to fit into max size while keeping the original ascpect ration.
324 Useful for calculating thumbnail dimensions etc.}
325 function ScaleSizeToFit(const CurrentSize, MaxSize: TSize): TSize;
326 { Returns width of given rect. Part of RTL in newer Delphi.}
327 function RectWidth(const Rect: TRect): Integer;
328 { Returns height of given rect. Part of RTL in newer Delphi.}
329 function RectHeight(const Rect: TRect): Integer;
330 { Returns True if R1 fits into R2.}
331 function RectInRect(const R1, R2: TRect): Boolean;
332 { Returns True if R1 and R2 intersects.}
333 function RectIntersects(const R1, R2: TRect): Boolean;
335 { Converts pixel size in micrometers to corrensponding DPI.}
336 function PixelSizeToDpi(SizeInMicroMeters: Single): Single;
337 { Converts DPI to corrensponding pixel size in micrometers.}
338 function DpiToPixelSize(Dpi: Single): Single;
340 function FloatRect(ALeft, ATop, ARight, ABottom: Single): TFloatRect;
341 function FloatRectWidth(const R: TFloatRect): Single;
342 function FloatRectHeight(const R: TFloatRect): Single;
344 { Formats given message for usage in Exception.Create(..). Use only
345 in except block - returned message contains message of last raised exception.}
346 function FormatExceptMsg(const Msg: string; const Args: array of const): string;
347 { Outputs debug message - shows message dialog in Windows and writes to console
348 in Linux/Unix.}
349 procedure DebugMsg(const Msg: string; const Args: array of const);
351 implementation
353 uses
354 {$IF Defined(MSWINDOWS)}
355 Windows;
356 {$ELSEIF Defined(FPC)}
357 Dos, BaseUnix, Unix;
358 {$ELSEIF Defined(DELPHI)}
359 Posix.SysTime;
360 {$IFEND}
362 var
363 FloatFormatSettings: TFormatSettings;
365 constructor ENotImplemented.Create;
366 begin
367 inherited Create('Not implemented');
368 end;
370 procedure FreeAndNil(var Obj);
371 var
372 Temp: TObject;
373 begin
374 Temp := TObject(Obj);
375 Pointer(Obj) := nil;
376 Temp.Free;
377 end;
379 procedure FreeMemNil(var P);
380 begin
381 FreeMem(Pointer(P));
382 Pointer(P) := nil;
383 end;
385 procedure FreeMem(P: Pointer);
386 begin
387 if P <> nil then
388 System.FreeMem(P);
389 end;
391 function GetExceptObject: Exception;
392 begin
393 Result := Exception(ExceptObject);
394 end;
396 {$IF Defined(MSWINDOWS)}
397 var
398 PerfFrequency: Int64;
399 InvPerfFrequency: Single;
401 function GetTimeMicroseconds: Int64;
402 var
403 Time: Int64;
404 begin
405 QueryPerformanceCounter(Time);
406 Result := Round(1000000 * InvPerfFrequency * Time);
407 end;
408 {$ELSEIF Defined(DELPHI)}
409 function GetTimeMicroseconds: Int64;
410 var
411 Time: TimeVal;
412 begin
413 Posix.SysTime.GetTimeOfDay(Time, nil);
414 Result := Int64(Time.tv_sec) * 1000000 + Time.tv_usec;
415 end;
416 {$ELSEIF Defined(FPC)}
417 function GetTimeMicroseconds: Int64;
418 var
419 TimeVal: TTimeVal;
420 begin
421 fpGetTimeOfDay(@TimeVal, nil);
422 Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec;
423 end;
424 {$IFEND}
426 function GetTimeMilliseconds: Int64;
427 begin
428 Result := GetTimeMicroseconds div 1000;
429 end;
431 function GetFileExt(const FileName: string): string;
432 begin
433 Result := ExtractFileExt(FileName);
434 if Length(Result) > 1 then
435 Delete(Result, 1, 1);
436 end;
438 function GetAppExe: string;
439 {$IF Defined(MSWINDOWS)}
440 var
441 FileName: array[0..MAX_PATH] of Char;
442 begin
443 SetString(Result, FileName,
444 Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
445 {$ELSEIF Defined(DELPHI)} // Delphi non Win targets
446 var
447 FileName: array[0..1024] of Char;
448 begin
449 SetString(Result, FileName,
450 System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
451 {$ELSE}
452 begin
453 Result := ParamStr(0);
454 {$IFEND}
455 end;
457 function GetAppDir: string;
458 begin
459 Result := ExtractFileDir(GetAppExe);
460 end;
462 function GetFileName(const FileName: string): string;
463 var
464 I: Integer;
465 begin
466 I := LastDelimiter('\/' + DriveDelim, FileName);
467 Result := Copy(FileName, I + 1, MaxInt);
468 end;
470 function GetFileDir(const FileName: string): string;
471 const
472 Delims = '\/' + DriveDelim;
473 var
474 I: Integer;
475 begin
476 I := LastDelimiter(Delims, Filename);
477 if (I > 1) and
478 ((FileName[I] = Delims[1]) or (FileName[I] = Delims[2])) and
479 (not IsDelimiter(Delims, FileName, I - 1)) then Dec(I);
480 Result := Copy(FileName, 1, I);
481 end;
483 function StrMaskMatch(const Subject, Mask: string; CaseSensitive: Boolean): Boolean;
484 var
485 MaskLen, KeyLen : LongInt;
487 function CharMatch(A, B: Char): Boolean;
488 begin
489 if CaseSensitive then
490 Result := A = B
491 else
492 Result := AnsiUpperCase (A) = AnsiUpperCase (B);
493 end;
495 function MatchAt(MaskPos, KeyPos: LongInt): Boolean;
496 begin
497 while (MaskPos <= MaskLen) and (KeyPos <= KeyLen) do
498 begin
499 case Mask[MaskPos] of
500 '?' :
501 begin
502 Inc(MaskPos);
503 Inc(KeyPos);
504 end;
505 '*' :
506 begin
507 while (MaskPos <= MaskLen) and (Mask[MaskPos] = '*') do
508 Inc(MaskPos);
509 if MaskPos > MaskLen then
510 begin
511 Result := True;
512 Exit;
513 end;
514 repeat
515 if MatchAt(MaskPos, KeyPos) then
516 begin
517 Result := True;
518 Exit;
519 end;
520 Inc(KeyPos);
521 until KeyPos > KeyLen;
522 Result := False;
523 Exit;
524 end;
525 else
526 if not CharMatch(Mask[MaskPos], Subject[KeyPos]) then
527 begin
528 Result := False;
529 Exit;
530 end
531 else
532 begin
533 Inc(MaskPos);
534 Inc(KeyPos);
535 end;
536 end;
537 end;
539 while (MaskPos <= MaskLen) and (AnsiChar(Mask[MaskPos]) in ['?', '*']) do
540 Inc(MaskPos);
541 if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then
542 begin
543 Result := False;
544 Exit;
545 end;
547 Result := True;
548 end;
550 begin
551 MaskLen := Length(Mask);
552 KeyLen := Length(Subject);
553 if MaskLen = 0 then
554 begin
555 Result := True;
556 Exit;
557 end;
558 Result := MatchAt(1, 1);
559 end;
561 function BuildFileList(Path: string; Attr: LongInt;
562 Files: TStrings; Options: TFileListOptions): Boolean;
563 var
564 FileMask: string;
565 RootDir: string;
566 Folders: TStringList;
567 CurrentItem: LongInt;
568 Counter: LongInt;
569 LocAttr: LongInt;
571 procedure BuildFolderList;
572 var
573 FindInfo: TSearchRec;
574 Rslt: LongInt;
575 begin
576 Counter := Folders.Count - 1;
577 CurrentItem := 0;
578 while CurrentItem <= Counter do
579 begin
580 // Searching for subfolders
581 Rslt := SysUtils.FindFirst(Folders[CurrentItem] + '*', faDirectory, FindInfo);
582 try
583 while Rslt = 0 do
584 begin
585 if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') and
586 (FindInfo.Attr and faDirectory = faDirectory) then
587 Folders.Add(Folders[CurrentItem] + FindInfo.Name + PathDelim);
588 Rslt := SysUtils.FindNext(FindInfo);
589 end;
590 finally
591 SysUtils.FindClose(FindInfo);
592 end;
593 Counter := Folders.Count - 1;
594 Inc(CurrentItem);
595 end;
596 end;
598 procedure FillFileList(CurrentCounter: LongInt);
599 var
600 FindInfo: TSearchRec;
601 Res: LongInt;
602 CurrentFolder: string;
603 begin
604 CurrentFolder := Folders[CurrentCounter];
605 Res := SysUtils.FindFirst(CurrentFolder + FileMask, LocAttr, FindInfo);
606 if flRelNames in Options then
607 CurrentFolder := ExtractRelativePath(RootDir, CurrentFolder);
608 try
609 while Res = 0 do
610 begin
611 if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') then
612 begin
613 if (flFullNames in Options) or (flRelNames in Options) then
614 Files.Add(CurrentFolder + FindInfo.Name)
615 else
616 Files.Add(FindInfo.Name);
617 end;
618 Res := SysUtils.FindNext(FindInfo);
619 end;
620 finally
621 SysUtils.FindClose(FindInfo);
622 end;
623 end;
625 begin
626 FileMask := ExtractFileName(Path);
627 RootDir := ExtractFilePath(Path);
628 Folders := TStringList.Create;
629 Folders.Add(RootDir);
630 Files.Clear;
631 {$IFDEF DCC}
632 {$WARN SYMBOL_PLATFORM OFF}
633 {$ENDIF}
634 if Attr = faAnyFile then
635 LocAttr := faSysFile or faHidden or faArchive or faReadOnly
636 else
637 LocAttr := Attr;
638 {$IFDEF DCC}
639 {$WARN SYMBOL_PLATFORM ON}
640 {$ENDIF}
641 // Here's the recursive search for nested folders
642 if flRecursive in Options then
643 BuildFolderList;
644 if Attr <> faDirectory then
645 for Counter := 0 to Folders.Count - 1 do
646 FillFileList(Counter)
647 else
648 Files.AddStrings(Folders);
649 Folders.Free;
650 Result := True;
651 end;
653 function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
654 var
655 I, X: LongInt;
656 Len, LenSubStr: LongInt;
657 begin
658 I := Offset;
659 LenSubStr := Length(SubStr);
660 Len := Length(S) - LenSubStr + 1;
661 while I <= Len do
662 begin
663 if S[I] = SubStr[1] then
664 begin
665 X := 1;
666 while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
667 Inc(X);
668 if (X = LenSubStr) then
669 begin
670 Result := I;
671 Exit;
672 end;
673 end;
674 Inc(I);
675 end;
676 Result := 0;
677 end;
679 function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt;
680 begin
681 Result := PosEx(AnsiLowerCase(SubStr), AnsiLowerCase(S), Offset);
682 end;
684 function StrToken(var S: string; Sep: Char): string;
685 var
686 I: LongInt;
687 begin
688 I := Pos(Sep, S);
689 if I <> 0 then
690 begin
691 Result := Copy(S, 1, I - 1);
692 Delete(S, 1, I);
693 end
694 else
695 begin
696 Result := S;
697 S := '';
698 end;
699 end;
701 function StrTokenEnd(var S: string; Sep: Char): string;
702 var
703 I, J: LongInt;
704 begin
705 J := 0;
706 I := Pos(Sep, S);
707 while I <> 0 do
708 begin
709 J := I;
710 I := PosEx(Sep, S, J + 1);
711 end;
712 if J <> 0 then
713 begin
714 Result := Copy(S, J + 1, MaxInt);
715 Delete(S, J, MaxInt);
716 end
717 else
718 begin
719 Result := S;
720 S := '';
721 end;
722 end;
724 procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
725 var
726 Token, Str: string;
727 begin
728 Tokens.Clear;
729 Str := S;
730 while Str <> '' do
731 begin
732 Token := StrToken(Str, Sep);
733 Tokens.Add(Token);
734 end;
735 end;
737 function IntToStrFmt(const I: Int64): string;
738 begin
739 Result := Format('%.0n', [I * 1.0]);
740 end;
742 function FloatToStrFmt(const F: Double; Precision: Integer): string;
743 begin
744 Result := Format('%.' + IntToStr(Precision) + 'n', [F]);
745 end;
747 function GetFormatSettingsForFloats: TFormatSettings;
748 begin
749 Result := FloatFormatSettings;
750 end;
752 function ContainsAnySubStr(const S: string; const SubStrs: array of string): Boolean;
753 var
754 I: Integer;
755 begin
756 Result := False;
757 for I := 0 to High(SubStrs) do
758 begin
759 Result := Pos(SubStrs[I], S) > 0;
760 if Result then
761 Exit;
762 end;
763 end;
765 function SubString(const S: string; IdxStart, IdxEnd: Integer): string;
766 begin
767 Result := Copy(S, IdxStart, IdxEnd - IdxStart);
768 end;
770 function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
771 begin
772 Result := Number;
773 if Result < Min then
774 Result := Min
775 else if Result > Max then
776 Result := Max;
777 end;
779 function ClampFloat(Number: Single; Min, Max: Single): Single;
780 begin
781 Result := Number;
782 if Result < Min then
783 Result := Min
784 else if Result > Max then
785 Result := Max;
786 end;
788 function ClampToByte(Value: LongInt): LongInt;
789 begin
790 Result := Value;
791 if Result > 255 then
792 Result := 255
793 else if Result < 0 then
794 Result := 0;
795 end;
797 function ClampToWord(Value: LongInt): LongInt;
798 begin
799 Result := Value;
800 if Result > 65535 then
801 Result := 65535
802 else if Result < 0 then
803 Result := 0;
804 end;
806 function IsPow2(Num: LongInt): Boolean;
807 begin
808 Result := (Num and -Num) = Num;
809 end;
811 function NextPow2(Num: LongInt): LongInt;
812 begin
813 Result := Num and -Num;
814 while Result < Num do
815 Result := Result shl 1;
816 end;
818 function Pow2Int(Exponent: LongInt): LongInt;
819 begin
820 Result := 1 shl Exponent;
821 end;
823 function Power(const Base, Exponent: Single): Single;
824 begin
825 if Exponent = 0.0 then
826 Result := 1.0
827 else if (Base = 0.0) and (Exponent > 0.0) then
828 Result := 0.0
829 else
830 Result := Exp(Exponent * Ln(Base));
831 end;
833 function Log2Int(X: LongInt): LongInt;
834 begin
835 case X of
836 1: Result := 0;
837 2: Result := 1;
838 4: Result := 2;
839 8: Result := 3;
840 16: Result := 4;
841 32: Result := 5;
842 64: Result := 6;
843 128: Result := 7;
844 256: Result := 8;
845 512: Result := 9;
846 1024: Result := 10;
847 2048: Result := 11;
848 4096: Result := 12;
849 8192: Result := 13;
850 16384: Result := 14;
851 32768: Result := 15;
852 65536: Result := 16;
853 131072: Result := 17;
854 262144: Result := 18;
855 524288: Result := 19;
856 1048576: Result := 20;
857 2097152: Result := 21;
858 4194304: Result := 22;
859 8388608: Result := 23;
860 16777216: Result := 24;
861 33554432: Result := 25;
862 67108864: Result := 26;
863 134217728: Result := 27;
864 268435456: Result := 28;
865 536870912: Result := 29;
866 1073741824: Result := 30;
867 else
868 Result := -1;
869 end;
870 end;
872 function Log2(X: Single): Single;
873 {$IFDEF USE_ASM}
874 asm
875 FLD1
876 FLD X
877 FYL2X
878 FWAIT
879 end;
880 {$ELSE}
881 const
882 Ln2: Single = 0.6931471;
883 begin
884 Result := Ln(X) / Ln2;
885 end;
886 {$ENDIF}
888 function Log10(X: Single): Single;
889 {$IFDEF USE_ASM}
890 asm
891 FLDLG2
892 FLD X
893 FYL2X
894 FWAIT
895 end;
896 {$ELSE}
897 const
898 Ln10: Single = 2.30258509299405;
899 begin
900 Result := Ln(X) / Ln10;
901 end;
902 {$ENDIF}
904 function Floor(Value: Single): LongInt;
905 begin
906 Result := Trunc(Value);
907 if Frac(Value) < 0.0 then
908 Dec(Result);
909 end;
911 function Ceil(Value: Single): LongInt;
912 begin
913 Result := Trunc(Value);
914 if Frac(Value) > 0.0 then
915 Inc(Result);
916 end;
918 procedure Switch(var Value: Boolean);
919 begin
920 Value := not Value;
921 end;
923 function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt;
924 begin
925 if Condition then
926 Result := TruePart
927 else
928 Result := FalsePart;
929 end;
931 function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord;
932 begin
933 if Condition then
934 Result := TruePart
935 else
936 Result := FalsePart;
937 end;
939 function Iff(Condition, TruePart, FalsePart: Boolean): Boolean;
940 begin
941 if Condition then
942 Result := TruePart
943 else
944 Result := FalsePart;
945 end;
947 function Iff(Condition: Boolean; const TruePart, FalsePart: string): string;
948 begin
949 if Condition then
950 Result := TruePart
951 else
952 Result := FalsePart;
953 end;
955 function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char;
956 begin
957 if Condition then
958 Result := TruePart
959 else
960 Result := FalsePart;
961 end;
963 function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer;
964 begin
965 if Condition then
966 Result := TruePart
967 else
968 Result := FalsePart;
969 end;
971 function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64;
972 begin
973 if Condition then
974 Result := TruePart
975 else
976 Result := FalsePart;
977 end;
979 function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single;
980 begin
981 if Condition then
982 Result := TruePart
983 else
984 Result := FalsePart;
985 end;
987 procedure SwapValues(var A, B: Boolean);
988 var
989 Tmp: Boolean;
990 begin
991 Tmp := A;
992 A := B;
993 B := Tmp;
994 end;
996 procedure SwapValues(var A, B: Byte);
997 var
998 Tmp: Byte;
999 begin
1000 Tmp := A;
1001 A := B;
1002 B := Tmp;
1003 end;
1005 procedure SwapValues(var A, B: Word);
1006 var
1007 Tmp: Word;
1008 begin
1009 Tmp := A;
1010 A := B;
1011 B := Tmp;
1012 end;
1014 procedure SwapValues(var A, B: LongInt);
1015 var
1016 Tmp: LongInt;
1017 begin
1018 Tmp := A;
1019 A := B;
1020 B := Tmp;
1021 end;
1023 procedure SwapValues(var A, B: Single);
1024 var
1025 Tmp: Single;
1026 begin
1027 Tmp := A;
1028 A := B;
1029 B := Tmp;
1030 end;
1032 procedure SwapMin(var Min, Max: LongInt);
1033 var
1034 Tmp: LongInt;
1035 begin
1036 if Min > Max then
1037 begin
1038 Tmp := Min;
1039 Min := Max;
1040 Max := Tmp;
1041 end;
1042 end;
1044 function Min(A, B: LongInt): LongInt;
1045 begin
1046 if A < B then
1047 Result := A
1048 else
1049 Result := B;
1050 end;
1052 function MinFloat(A, B: Single): Single;
1053 begin
1054 if A < B then
1055 Result := A
1056 else
1057 Result := B;
1058 end;
1060 function Max(A, B: LongInt): LongInt;
1061 begin
1062 if A > B then
1063 Result := A
1064 else
1065 Result := B;
1066 end;
1068 function MaxFloat(A, B: Single): Single;
1069 begin
1070 if A > B then
1071 Result := A
1072 else
1073 Result := B;
1074 end;
1076 function MulDiv(Number, Numerator, Denominator: Word): Word;
1077 {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
1078 asm
1079 MUL DX
1080 DIV CX
1081 end;
1082 {$ELSE}
1083 begin
1084 Result := Number * Numerator div Denominator;
1085 end;
1086 {$IFEND}
1088 function IsLittleEndian: Boolean;
1089 var
1090 W: Word;
1091 begin
1092 W := $00FF;
1093 Result := PByte(@W)^ = $FF;
1094 end;
1096 (* Vampimp wrongly use swaps for converting big-endian to little-endian anywhere *)
1097 {$IF DEFINED(FPC_LITTLE_ENDIAN)}
1098 function SwapEndianWord(Value: Word): Word;
1099 {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
1100 asm
1101 XCHG AH, AL
1102 end;
1103 {$ELSE}
1104 begin
1105 TWordRec(Result).Low := TWordRec(Value).High;
1106 TWordRec(Result).High := TWordRec(Value).Low;
1107 end;
1108 {$IFEND}
1110 procedure SwapEndianWord(P: PWordArray; Count: LongInt);
1111 {$IFDEF USE_ASM}
1112 asm
1113 @Loop:
1114 MOV CX, [EAX]
1115 XCHG CH, CL
1116 MOV [EAX], CX
1117 ADD EAX, 2
1118 DEC EDX
1119 JNZ @Loop
1120 end;
1121 {$ELSE}
1122 var
1123 I: LongInt;
1124 Temp: Word;
1125 begin
1126 for I := 0 to Count - 1 do
1127 begin
1128 Temp := P[I];
1129 TWordRec(P[I]).Low := TWordRec(Temp).High;
1130 TWordRec(P[I]).High := TWordRec(Temp).Low;
1131 end;
1132 end;
1133 {$ENDIF}
1135 function SwapEndianLongWord(Value: LongWord): LongWord;
1136 {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
1137 asm
1138 BSWAP EAX
1139 end;
1140 {$ELSE}
1141 begin
1142 TLongWordRec(Result).Bytes[0] := TLongWordRec(Value).Bytes[3];
1143 TLongWordRec(Result).Bytes[1] := TLongWordRec(Value).Bytes[2];
1144 TLongWordRec(Result).Bytes[2] := TLongWordRec(Value).Bytes[1];
1145 TLongWordRec(Result).Bytes[3] := TLongWordRec(Value).Bytes[0];
1146 end;
1147 {$IFEND}
1149 procedure SwapEndianLongWord(P: PLongWord; Count: LongInt);
1150 {$IFDEF USE_ASM}
1151 asm
1152 @Loop:
1153 MOV ECX, [EAX]
1154 BSWAP ECX
1155 MOV [EAX], ECX
1156 ADD EAX, 4
1157 DEC EDX
1158 JNZ @Loop
1159 end;
1160 {$ELSE}
1161 var
1162 I: LongInt;
1163 Temp: LongWord;
1164 begin
1165 for I := 0 to Count - 1 do
1166 begin
1167 Temp := PLongWordArray(P)[I];
1168 TLongWordRec(PLongWordArray(P)[I]).Bytes[0] := TLongWordRec(Temp).Bytes[3];
1169 TLongWordRec(PLongWordArray(P)[I]).Bytes[1] := TLongWordRec(Temp).Bytes[2];
1170 TLongWordRec(PLongWordArray(P)[I]).Bytes[2] := TLongWordRec(Temp).Bytes[1];
1171 TLongWordRec(PLongWordArray(P)[I]).Bytes[3] := TLongWordRec(Temp).Bytes[0];
1172 end;
1173 end;
1174 {$ENDIF}
1175 {$ELSEIF DEFINED(FPC_BIG_ENDIAN)}
1176 function SwapEndianWord(Value: Word): Word;
1177 begin
1178 Result := Value
1179 end;
1181 procedure SwapEndianWord(P: PWordArray; Count: LongInt);
1182 begin
1183 end;
1185 function SwapEndianLongWord(Value: LongWord): LongWord;
1186 begin
1187 Result := Value
1188 end;
1190 procedure SwapEndianLongWord(P: PLongWord; Count: LongInt);
1191 begin
1192 end;
1193 {$ELSE}
1194 {$ERROR Unsupported endianness!}
1195 {$ENDIF}
1197 type
1198 TCrcTable = array[Byte] of LongWord;
1199 var
1200 CrcTable: TCrcTable;
1202 procedure InitCrcTable;
1203 const
1204 Polynom = $EDB88320;
1205 var
1206 I, J: LongInt;
1207 C: LongWord;
1208 begin
1209 for I := 0 to 255 do
1210 begin
1211 C := I;
1212 for J := 0 to 7 do
1213 begin
1214 if (C and $01) <> 0 then
1215 C := Polynom xor (C shr 1)
1216 else
1217 C := C shr 1;
1218 end;
1219 CrcTable[I] := C;
1220 end;
1221 end;
1223 procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
1224 var
1225 I: LongInt;
1226 B: PByte;
1227 begin
1228 B := Data;
1229 for I := 0 to Size - 1 do
1230 begin
1231 Crc := (Crc shr 8) xor CrcTable[B^ xor Byte(Crc)];
1232 Inc(B);
1233 end
1234 end;
1236 procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
1237 {$IFDEF USE_ASM}
1238 asm
1239 PUSH EDI
1240 MOV EDI, EAX
1241 MOV EAX, ECX
1242 MOV AH, AL
1243 MOV CX, AX
1244 SHL EAX, 16
1245 MOV AX, CX
1246 MOV ECX, EDX
1247 SAR ECX, 2
1248 JS @Exit
1249 REP STOSD
1250 MOV ECX, EDX
1251 AND ECX, 3
1252 REP STOSB
1253 POP EDI
1254 @Exit:
1255 end;
1256 {$ELSE}
1257 begin
1258 FillChar(Data^, Size, Value);
1259 end;
1260 {$ENDIF}
1262 procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
1263 {$IFDEF USE_ASM}
1264 asm
1265 PUSH EDI
1266 PUSH EBX
1267 MOV EBX, EDX
1268 MOV EDI, EAX
1269 MOV EAX, ECX
1270 MOV CX, AX
1271 SHL EAX, 16
1272 MOV AX, CX
1273 MOV ECX, EDX
1274 SHR ECX, 2
1275 JZ @Word
1276 REP STOSD
1277 @Word:
1278 MOV ECX, EBX
1279 AND ECX, 2
1280 JZ @Byte
1281 MOV [EDI], AX
1282 ADD EDI, 2
1283 @Byte:
1284 MOV ECX, EBX
1285 AND ECX, 1
1286 JZ @Exit
1287 MOV [EDI], AL
1288 @Exit:
1289 POP EBX
1290 POP EDI
1291 end;
1292 {$ELSE}
1293 var
1294 I, V: LongWord;
1295 begin
1296 V := Value * $10000 + Value;
1297 for I := 0 to Size div 4 - 1 do
1298 PLongWordArray(Data)[I] := V;
1299 case Size mod 4 of
1300 1: PByteArray(Data)[Size - 1] := Lo(Value);
1301 2: PWordArray(Data)[Size div 2] := Value;
1302 3:
1303 begin
1304 PWordArray(Data)[Size div 2 - 1] := Value;
1305 PByteArray(Data)[Size - 1] := Lo(Value);
1306 end;
1307 end;
1308 end;
1309 {$ENDIF}
1311 procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
1312 {$IFDEF USE_ASM}
1313 asm
1314 PUSH EDI
1315 PUSH EBX
1316 MOV EBX, EDX
1317 MOV EDI, EAX
1318 MOV EAX, ECX
1319 MOV ECX, EDX
1320 SHR ECX, 2
1321 JZ @Word
1322 REP STOSD
1323 @Word:
1324 MOV ECX, EBX
1325 AND ECX, 2
1326 JZ @Byte
1327 MOV [EDI], AX
1328 ADD EDI, 2
1329 @Byte:
1330 MOV ECX, EBX
1331 AND ECX, 1
1332 JZ @Exit
1333 MOV [EDI], AL
1334 @Exit:
1335 POP EBX
1336 POP EDI
1337 end;
1338 {$ELSE}
1339 var
1340 I: LongInt;
1341 begin
1342 for I := 0 to Size div 4 - 1 do
1343 PLongWordArray(Data)[I] := Value;
1344 case Size mod 4 of
1345 1: PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
1346 2: PWordArray(Data)[Size div 2] := TLongWordRec(Value).Words[0];
1347 3:
1348 begin
1349 PWordArray(Data)[Size div 2 - 1] := TLongWordRec(Value).Words[0];
1350 PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
1351 end;
1352 end;
1353 end;
1354 {$ENDIF}
1356 procedure ZeroMemory(Data: Pointer; Size: Integer);
1357 begin
1358 FillMemoryByte(Data, Size, 0);
1359 end;
1361 function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
1362 begin
1363 Result := 0;
1364 if (Width > 0) and (Height > 0) then
1365 begin
1366 Result := 1;
1367 while (Width <> 1) or (Height <> 1) do
1368 begin
1369 Width := Width div 2;
1370 Height := Height div 2;
1371 if Width < 1 then Width := 1;
1372 if Height < 1 then Height := 1;
1373 Inc(Result);
1374 end;
1375 end;
1376 end;
1378 function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
1379 var
1380 I: LongInt;
1381 begin
1382 Result := Depth;
1383 for I := 1 to MipMaps - 1 do
1384 Inc(Result, ClampInt(Depth shr I, 1, Depth));
1385 end;
1387 function BoundsToRect(X, Y, Width, Height: LongInt): TRect;
1388 begin
1389 Result.Left := X;
1390 Result.Top := Y;
1391 Result.Right := X + Width;
1392 Result.Bottom := Y + Height;
1393 end;
1395 function BoundsToRect(const R: TRect): TRect;
1396 begin
1397 Result.Left := R.Left;
1398 Result.Top := R.Top;
1399 Result.Right := R.Left + R.Right;
1400 Result.Bottom := R.Top + R.Bottom;
1401 end;
1403 function RectToBounds(const R: TRect): TRect;
1404 begin
1405 Result.Left := R.Left;
1406 Result.Top := R.Top;
1407 Result.Right := R.Right - R.Left;
1408 Result.Bottom := R.Bottom - R.Top;
1409 end;
1411 procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
1413 procedure ClipDim(var AStart, ALength: LongInt; ClipMin, ClipMax: LongInt);
1414 begin
1415 if AStart < ClipMin then
1416 begin
1417 ALength := ALength - (ClipMin - AStart);
1418 AStart := ClipMin;
1419 end;
1420 if AStart + ALength > ClipMax then ALength := Max(0, ClipMax - AStart);
1421 end;
1423 begin
1424 ClipDim(X, Width, Clip.Left, Clip.Right);
1425 ClipDim(Y, Height, Clip.Top, Clip.Bottom);
1426 end;
1428 procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
1430 procedure ClipDim(var SrcPos, DstPos, Size: LongInt; SrcClipMax,
1431 DstClipMin, DstClipMax: LongInt);
1432 var
1433 OldDstPos: LongInt;
1434 Diff: LongInt;
1435 begin
1436 OldDstPos := Iff(DstPos < 0, DstPos, 0);
1437 if DstPos < DstClipMin then
1438 begin
1439 Diff := DstClipMin - DstPos;
1440 Size := Size - Diff;
1441 SrcPos := SrcPos + Diff;
1442 DstPos := DstClipMin;
1443 end;
1444 if SrcPos < 0 then
1445 begin
1446 Size := Size + SrcPos - OldDstPos;
1447 DstPos := DstPos - SrcPos + OldDstPos;
1448 SrcPos := 0;
1449 end;
1450 if SrcPos + Size > SrcClipMax then Size := SrcClipMax - SrcPos;
1451 if DstPos + Size > DstClipMax then Size := DstClipMax - DstPos;
1452 end;
1454 begin
1455 ClipDim(SrcX, DstX, Width, SrcImageWidth, DstClip.Left, DstClip.Right);
1456 ClipDim(SrcY, DstY, Height, SrcImageHeight, DstClip.Top, DstClip.Bottom);
1457 end;
1459 procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
1460 DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
1462 procedure ClipDim(var SrcPos, DstPos, SrcSize, DstSize: LongInt; SrcClipMax,
1463 DstClipMin, DstClipMax: LongInt);
1464 var
1465 OldSize: LongInt;
1466 Diff: LongInt;
1467 Scale: Single;
1468 begin
1469 Scale := DstSize / SrcSize;
1470 if DstPos < DstClipMin then
1471 begin
1472 Diff := DstClipMin - DstPos;
1473 DstSize := DstSize - Diff;
1474 SrcPos := SrcPos + Round(Diff / Scale);
1475 SrcSize := SrcSize - Round(Diff / Scale);
1476 DstPos := DstClipMin;
1477 end;
1478 if SrcPos < 0 then
1479 begin
1480 SrcSize := SrcSize + SrcPos;
1481 DstPos := DstPos - Round(SrcPos * Scale);
1482 DstSize := DstSize + Round(SrcPos * Scale);
1483 SrcPos := 0;
1484 end;
1485 if SrcPos + SrcSize > SrcClipMax then
1486 begin
1487 OldSize := SrcSize;
1488 SrcSize := SrcClipMax - SrcPos;
1489 DstSize := Round(DstSize * (SrcSize / OldSize));
1490 end;
1491 if DstPos + DstSize > DstClipMax then
1492 begin
1493 OldSize := DstSize;
1494 DstSize := DstClipMax - DstPos;
1495 SrcSize := Round(SrcSize * (DstSize / OldSize));
1496 end;
1497 end;
1499 begin
1500 ClipDim(SrcX, DstX, SrcWidth, DstWidth, SrcImageWidth, DstClip.Left, DstClip.Right);
1501 ClipDim(SrcY, DstY, SrcHeight, DstHeight, SrcImageHeight, DstClip.Top, DstClip.Bottom);
1502 end;
1504 function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
1505 var
1506 SourceWidth: LongInt;
1507 SourceHeight: LongInt;
1508 TargetWidth: LongInt;
1509 TargetHeight: LongInt;
1510 ScaledWidth: LongInt;
1511 ScaledHeight: LongInt;
1512 begin
1513 SourceWidth := SourceRect.Right - SourceRect.Left;
1514 SourceHeight := SourceRect.Bottom - SourceRect.Top;
1515 TargetWidth := TargetRect.Right - TargetRect.Left;
1516 TargetHeight := TargetRect.Bottom - TargetRect.Top;
1518 if SourceWidth * TargetHeight < SourceHeight * TargetWidth then
1519 begin
1520 ScaledWidth := (SourceWidth * TargetHeight) div SourceHeight;
1521 Result := BoundsToRect(TargetRect.Left + ((TargetWidth - ScaledWidth) div 2),
1522 TargetRect.Top, ScaledWidth, TargetHeight);
1523 end
1524 else
1525 begin
1526 ScaledHeight := (SourceHeight * TargetWidth) div SourceWidth;
1527 Result := BoundsToRect(TargetRect.Left, TargetRect.Top + ((TargetHeight - ScaledHeight) div 2),
1528 TargetWidth, ScaledHeight);
1529 end;
1530 end;
1532 function ScaleSizeToFit(const CurrentSize, MaxSize: Types.TSize): Types.TSize;
1533 var
1534 SR, TR, ScaledRect: TRect;
1535 begin
1536 SR := Types.Rect(0, 0, CurrentSize.CX, CurrentSize.CY);
1537 TR := Types.Rect(0, 0, MaxSize.CX, MaxSize.CY);
1538 ScaledRect := ScaleRectToRect(SR, TR);
1539 Result.CX := ScaledRect.Right - ScaledRect.Left;
1540 Result.CY := ScaledRect.Bottom - ScaledRect.Top;
1541 end;
1543 function RectWidth(const Rect: TRect): Integer;
1544 begin
1545 Result := Rect.Right - Rect.Left;
1546 end;
1548 function RectHeight(const Rect: TRect): Integer;
1549 begin
1550 Result := Rect.Bottom - Rect.Top;
1551 end;
1553 function RectInRect(const R1, R2: TRect): Boolean;
1554 begin
1555 Result:=
1556 (R1.Left >= R2.Left) and
1557 (R1.Top >= R2.Top) and
1558 (R1.Right <= R2.Right) and
1559 (R1.Bottom <= R2.Bottom);
1560 end;
1562 function RectIntersects(const R1, R2: TRect): Boolean;
1563 begin
1564 Result :=
1565 not (R1.Left > R2.Right) and
1566 not (R1.Top > R2.Bottom) and
1567 not (R1.Right < R2.Left) and
1568 not (R1.Bottom < R2.Top);
1569 end;
1571 function PixelSizeToDpi(SizeInMicroMeters: Single): Single;
1572 begin
1573 Result := 25400 / SizeInMicroMeters;
1574 end;
1576 function DpiToPixelSize(Dpi: Single): Single;
1577 begin
1578 Result := 1e03 / (Dpi / 25.4);
1579 end;
1581 function FloatRect(ALeft, ATop, ARight, ABottom: Single): TFloatRect;
1582 begin
1583 with Result do
1584 begin
1585 Left := ALeft;
1586 Top := ATop;
1587 Right := ARight;
1588 Bottom := ABottom;
1589 end;
1590 end;
1592 function FloatRectWidth(const R: TFloatRect): Single;
1593 begin
1594 Result := R.Right - R.Left;
1595 end;
1597 function FloatRectHeight(const R: TFloatRect): Single;
1598 begin
1599 Result := R.Bottom - R.Top;
1600 end;
1602 function FormatExceptMsg(const Msg: string; const Args: array of const): string;
1603 begin
1604 Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args);
1605 end;
1607 procedure DebugMsg(const Msg: string; const Args: array of const);
1608 var
1609 FmtMsg: string;
1610 begin
1611 FmtMsg := Format(Msg, Args);
1612 {$IFDEF MSWINDOWS}
1613 if IsConsole then
1614 WriteLn('DebugMsg: ' + FmtMsg)
1615 else
1616 MessageBox(GetActiveWindow, PChar(FmtMsg), 'DebugMsg', MB_OK);
1617 {$ENDIF}
1618 {$IFDEF UNIX}
1619 WriteLn('DebugMsg: ' + FmtMsg);
1620 {$ENDIF}
1621 {$IFDEF MSDOS}
1622 WriteLn('DebugMsg: ' + FmtMsg);
1623 {$ENDIF}
1624 end;
1626 initialization
1627 InitCrcTable;
1628 {$IFDEF MSWINDOWS}
1629 QueryPerformanceFrequency(PerfFrequency);
1630 InvPerfFrequency := 1.0 / PerfFrequency;
1631 {$ENDIF}
1633 {$IF Defined(DELPHI)}
1634 {$IF CompilerVersion >= 23}
1635 FloatFormatSettings := TFormatSettings.Create('en-US');
1636 {$ELSE}
1637 GetLocaleFormatSettings(1033, FloatFormatSettings);
1638 {$IFEND}
1639 {$ELSE FPC}
1640 FloatFormatSettings := DefaultFormatSettings;
1641 FloatFormatSettings.DecimalSeparator := '.';
1642 {$IFEND}
1645 File Notes:
1647 -- TODOS ----------------------------------------------------
1648 - nothing now
1650 -- 0.77.1 ----------------------------------------------------
1651 - Added GetFileName, GetFileDir, RectWidth, RectHeight function.
1652 - Added ScaleSizeToFit function.
1653 - Added ZeroMemory and SwapValues for Booleans.
1654 - Added Substring function.
1655 - Renamed MatchFileNameMask to StrMaskMatch (it's for general use not
1656 just filenames).
1657 - Delphi XE2 new targets (Win64, OSX32) compatibility changes.
1658 - Added GetFormatSettingsForFloats function.
1660 -- 0.26.5 Changes/Bug Fixes -----------------------------------
1661 - Added Log10 function.
1662 - Added TFloatRect type and helper functions FloatRect, FloatRectWidth,
1663 FloatRectHeight.
1664 - Added string function ContainsAnySubStr.
1665 - Added functions PixelSizeToDpi, DpiToPixelSize.
1667 -- 0.26.1 Changes/Bug Fixes -----------------------------------
1668 - Some formatting changes.
1669 - Changed some string functions to work with localized strings.
1670 - ASM version of PosEx had bugs, removed it.
1671 - Added StrTokensToList function.
1673 -- 0.25.0 Changes/Bug Fixes -----------------------------------
1674 - Fixed error in ClipCopyBounds which was causing ... bad clipping!
1676 -- 0.24.3 Changes/Bug Fixes -----------------------------------
1677 - Added GetTimeMilliseconds function.
1678 - Added IntToStrFmt and FloatToStrFmt helper functions.
1680 -- 0.23 Changes/Bug Fixes -----------------------------------
1681 - Added RectInRect and RectIntersects functions
1682 - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase.
1683 - Moved BuildFileList here from DemoUtils.
1685 -- 0.21 Changes/Bug Fixes -----------------------------------
1686 - Moved GetVolumeLevelCount from ImagingDds here.
1687 - Renamed FillMemory to FillMemoryByte to avoid name collision in C++ Builder.
1688 - Added Iff function for Char, Pointer, and Int64 types.
1689 - Added IsLittleEndian function.
1690 - Added array types for TWordRec, TLongWordRec, and TInt64Rec.
1691 - Added MatchFileNameMask function.
1693 -- 0.19 Changes/Bug Fixes -----------------------------------
1694 - added ScaleRectToRect (thanks to Paul Michell)
1695 - added BoundsToRect, ClipBounds, ClipCopyBounds, ClipStretchBounds functions
1696 - added MulDiv function
1697 - FreeAndNil is not inline anymore - caused AV in one program
1699 -- 0.17 Changes/Bug Fixes -----------------------------------
1701 - GetAppExe didn't return absolute path in FreeBSD, fixed
1702 - added debug message output
1703 - fixed Unix compatibility issues (thanks to Ales Katona).
1704 Imaging now compiles in FreeBSD and maybe in other Unixes as well.
1706 -- 0.15 Changes/Bug Fixes -----------------------------------
1707 - added some new utility functions
1709 -- 0.13 Changes/Bug Fixes -----------------------------------
1710 - added many new utility functions
1711 - minor change in SwapEndian to avoid range check error
1714 end.