DEADSOFTWARE

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