| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566 |
- {
- $Id$
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
- }
- { This unit contains utility functions and types for Imaging library.}
- unit ImagingUtility;
- {$I ImagingOptions.inc}
- interface
- uses
- SysUtils, Classes, Types;
- const
- STrue = 'True';
- SFalse = 'False';
- type
- TByteArray = array[0..MaxInt - 1] of Byte;
- PByteArray = ^TByteArray;
- TWordArray = array[0..MaxInt div 2 - 1] of Word;
- PWordArray = ^TWordArray;
- TLongIntArray = array[0..MaxInt div 4 - 1] of LongInt;
- PLongIntArray = ^TLongIntArray;
- TLongWordArray = array[0..MaxInt div 4 - 1] of LongWord;
- PLongWordArray = ^TLongWordArray;
- TInt64Array = array[0..MaxInt div 8 - 1] of Int64;
- PInt64Array = ^TInt64Array;
- TSingleArray = array[0..MaxInt div 4 - 1] of Single;
- PSingleArray = ^TSingleArray;
- TBooleanArray = array[0..MaxInt - 1] of Boolean;
- PBooleanArray = ^TBooleanArray;
- TWordRec = packed record
- case Integer of
- 0: (WordValue: Word);
- 1: (Low, High: Byte);
- end;
- PWordRec = ^TWordRec;
- TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec;
- PWordRecArray = ^TWordRecArray;
- TLongWordRec = packed record
- case Integer of
- 0: (LongWordValue: LongWord);
- 1: (Low, High: Word);
- { Array variants - Index 0 means lowest significant byte (word, ...).}
- 2: (Words: array[0..1] of Word);
- 3: (Bytes: array[0..3] of Byte);
- end;
- PLongWordRec = ^TLongWordRec;
- TLongWordRecArray = array[0..MaxInt div 4 - 1] of TLongWordRec;
- PLongWordRecArray = ^TLongWordRecArray;
- TInt64Rec = packed record
- case Integer of
- 0: (Int64Value: Int64);
- 1: (Low, High: LongWord);
- { Array variants - Index 0 means lowest significant byte (word, ...).}
- 2: (Words: array[0..3] of Word);
- 3: (Bytes: array[0..7] of Byte);
- end;
- PInt64Rec = ^TInt64Rec;
- TInt64RecArray = array[0..MaxInt div 8 - 1] of TInt64Rec;
- PInt64RecArray = ^TInt64RecArray;
- TFloatHelper = record
- Data1: Int64;
- Data2: Int64;
- end;
- PFloatHelper = ^TFloatHelper;
- TChar2 = array[0..1] of Char;
- TChar3 = array[0..2] of Char;
- TChar4 = array[0..3] of Char;
- TChar8 = array[0..7] of Char;
- { Options for BuildFileList function:
- flFullNames - file names in result will have full path names
- (ExtractFileDir(Path) + FileName)
- flRelNames - file names in result will have names relative to
- ExtractFileDir(Path) dir
- flRecursive - adds files in subdirectories found in Path.}
- TFileListOption = (flFullNames, flRelNames, flRecursive);
- TFileListOptions = set of TFileListOption;
- { Frees class instance and sets its reference to nil.}
- procedure FreeAndNil(var Obj);
- { Frees pointer and sets it to nil.}
- procedure FreeMemNil(var P); {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Replacement of standard System.FreeMem procedure which checks if P is nil
- (this is only needed for Free Pascal, Delphi makes checks in its FreeMem).}
- procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns current exception object. Do not call outside exception handler.}
- function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns time value with microsecond resolution. Use for some time counters.}
- function GetTimeMicroseconds: Int64;
- { Returns file extension (without "." dot)}
- function GetFileExt(const FileName: string): string;
- { Returns file name of application's executable.}
- function GetAppExe: string;
- { Returns directory where application's exceutable is located without
- path delimiter at the end.}
- function GetAppDir:string;
- { Returns True if FileName matches given Mask with optional case sensitivity.
- Mask can contain ? and * special characters: ? matches
- one character, * matches zero or more characters.}
- function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean = False): Boolean;
- { This function fills Files string list with names of files found
- with FindFirst/FindNext functions (See details on Path/Atrr here).
- - BuildFileList('c:\*.*', faAnyFile, List, [flRecursive]) returns
- list of all files (only name.ext - no path) on C drive
- - BuildFileList('d:\*.*', faDirectory, List, [flFullNames]) returns
- list of all directories (d:\dirxxx) in root of D drive.}
- function BuildFileList(Path: string; Attr: LongInt; Files: TStrings;
- Options: TFileListOptions = []): Boolean;
- { Similar to RTL's Pos function but with optional Offset where search will start.
- This function is in the RTL StrUtils unit but }
- function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
- { Same as PosEx but without case sensitivity.}
- function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns a sub-string from S which is followed by
- Sep separator and deletes the sub-string from S including the separator.}
- function StrToken(var S: string; Sep: Char): string;
- { Same as StrToken but searches from the end of S string.}
- function StrTokenEnd(var S: string; Sep: Char): string;
- { Clamps integer value to range <Min, Max>}
- function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Clamps float value to range <Min, Max>}
- function ClampFloat(Number: Single; Min, Max: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Clamps integer value to Byte boundaries.}
- function ClampToByte(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Clamps integer value to Word boundaries.}
- function ClampToWord(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns True if Num is power of 2.}
- function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns next power of 2 greater than or equal to Num
- (if Num itself is power of 2 then it retuns Num).}
- function NextPow2(Num: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Raises 2 to the given integer power (in range [0, 30]).}
- function Pow2Int(Exponent: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Raises Base to any power.}
- function Power(const Base, Exponent: Single): Single;
- { Returns log base 2 of integer X (max 2^30) or -1 if X is not power of 2.}
- function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns log base 2 of X.}
- function Log2(X: Single): Single;
- { Returns largest integer <= Val (for 5.9 returns 5).}
- function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns smallest integer >= Val (for 5.1 returns 6).}
- function Ceil(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns lesser of two integer numbers.}
- function Min(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns lesser of two float numbers.}
- function MinFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns greater of two integer numbers.}
- function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns greater of two float numbers.}
- function MaxFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns result from multiplying Number by Numerator and then dividing by Denominator.
- Denominator must be greater than 0.}
- function MulDiv(Number, Numerator, Denominator: Word): Word; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Switches Boolean value.}
- procedure Switch(var Value: Boolean); {$IFDEF USE_INLINE}inline;{$ENDIF}
- { If Condition is True then TruePart is retured, otherwise
- FalsePart is returned.}
- function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { If Condition is True then TruePart is retured, otherwise
- FalsePart is returned.}
- function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { If Condition is True then TruePart is retured, otherwise
- FalsePart is returned.}
- function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { If Condition is True then TruePart is retured, otherwise
- FalsePart is returned.}
- function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { If Condition is True then TruePart is retured, otherwise
- FalsePart is returned.}
- function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { If Condition is True then TruePart is retured, otherwise
- FalsePart is returned.}
- function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { If Condition is True then TruePart is retured, otherwise
- FalsePart is returned.}
- function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { If Condition is True then TruePart is retured, otherwise
- FalsePart is returned.}
- function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Swaps two Byte values}
- procedure SwapValues(var A, B: Byte); overload;
- { Swaps two Word values}
- procedure SwapValues(var A, B: Word); overload;
- { Swaps two LongInt values}
- procedure SwapValues(var A, B: LongInt); overload;
- { Swaps two Single values}
- procedure SwapValues(var A, B: Single); overload;
- { Swaps two LongInt values if necessary to ensure that Min <= Max.}
- procedure SwapMin(var Min, Max: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
- { This function returns True if running on little endian machine.}
- function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Swaps byte order of Word value.}
- function SwapEndianWord(Value: Word): Word; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Swaps byte order of multiple Word values.}
- procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload;
- { Swaps byte order of LongWord value.}
- function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Swaps byte order of multiple LongWord values.}
- procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload;
- { Calculates CRC32 for the given data.}
- procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
- { Fills given memory with given Byte value. Size is size of buffer in bytes.}
- procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
- { Fills given memory with given Word value. Size is size of buffer in bytes.}
- procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
- { Fills given memory with given LongWord value. Size is size of buffer in bytes.}
- procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
- { Returns how many mipmap levels can be created for image of given size.}
- function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
- { Returns total number of levels of volume texture with given depth and
- mipmap count (this is not depth * mipmaps!).}
- function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
- { Returns rectangle (X, Y, X + Width, Y + Height).}
- function BoundsToRect(X, Y, Width, Height: LongInt): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns rectangle (R.Left, R.Top, R.Left + R.Right, R.Top + R.Bottom).}
- function BoundsToRect(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Returns rectangle (R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top).}
- function RectToBounds(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Clips given bounds to Clip rectangle.}
- procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
- { Clips given source bounds and dest position. It is used by various CopyRect
- functions that copy rect from one image to another. It handles clipping the same way
- as Win32 BitBlt function. }
- procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt;
- SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
- { Clips given source bounds and dest bounds. It is used by various StretchRect
- functions that stretch rectangle of pixels from one image to another.
- It handles clipping the same way as Win32 StretchBlt function. }
- procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
- DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
- { Scales one rectangle to fit into another. Proportions are preserved so
- it could be used for 'Stretch To Fit Window' image drawing for instance.}
- function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
- { Returns True if R1 fits into R2.}
- function RectInRect(const R1, R2: TRect): Boolean;
- { Returns True if R1 and R2 intersects.}
- function RectIntersects(const R1, R2: TRect): Boolean;
- { Formats given message for usage in Exception.Create(..). Use only
- in except block - returned message contains message of last raised exception.}
- function FormatExceptMsg(const Msg: string; const Args: array of const): string;
- { Outputs debug message - shows message dialog in Windows and writes to console
- in Linux/Unix.}
- procedure DebugMsg(const Msg: string; const Args: array of const);
- implementation
- uses
- {$IFDEF MSWINDOWS}
- Windows;
- {$ENDIF}
- {$IFDEF UNIX}
- {$IFDEF KYLIX}
- Libc;
- {$ELSE}
- Dos, BaseUnix, Unix;
- {$ENDIF}
- {$ENDIF}
- procedure FreeAndNil(var Obj);
- var
- Temp: TObject;
- begin
- Temp := TObject(Obj);
- Pointer(Obj) := nil;
- Temp.Free;
- end;
- procedure FreeMemNil(var P);
- begin
- FreeMem(Pointer(P));
- Pointer(P) := nil;
- end;
- procedure FreeMem(P: Pointer);
- begin
- if P <> nil then
- System.FreeMem(P);
- end;
- function GetExceptObject: Exception;
- begin
- Result := Exception(ExceptObject);
- end;
- {$IFDEF MSWINDOWS}
- var
- PerfFrequency: Int64;
- InvPerfFrequency: Single;
- function GetTimeMicroseconds: Int64;
- var
- Time: Int64;
- begin
- QueryPerformanceCounter(Time);
- Result := Round(1000000 * InvPerfFrequency * Time);
- end;
- {$ENDIF}
- {$IFDEF UNIX}
- function GetTimeMicroseconds: Int64;
- var
- TimeVal: TTimeVal;
- begin
- {$IFDEF KYLIX}
- GetTimeOfDay(TimeVal, nil);
- {$ELSE}
- fpGetTimeOfDay(@TimeVal, nil);
- {$ENDIF}
- Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec;
- end;
- {$ENDIF}
- {$IFDEF MSDOS}
- function GetTimeMicroseconds: Int64;
- asm
- XOR EAX, EAX
- CLI
- OUT $43, AL
- MOV EDX, FS:[$46C]
- IN AL, $40
- DB $EB, 0, $EB, 0, $EB, 0
- MOV AH, AL
- IN AL, $40
- DB $EB, 0, $EB, 0, $EB, 0
- XCHG AL, AH
- NEG AX
- MOVZX EDI, AX
- STI
- MOV EBX, $10000
- MOV EAX, EDX
- XOR EDX, EDX
- MUL EBX
- ADD EAX, EDI
- ADC EDX, 0
- PUSH EDX
- PUSH EAX
- MOV ECX, $82BF1000
- MOVZX EAX, WORD PTR FS:[$470]
- MUL ECX
- MOV ECX, EAX
- POP EAX
- POP EDX
- ADD EAX, ECX
- ADC EDX, 0
- end;
- {$ENDIF}
- function GetFileExt(const FileName: string): string;
- begin
- Result := ExtractFileExt(FileName);
- if Length(Result) > 1 then
- Delete(Result, 1, 1);
- end;
- function GetAppExe: string;
- {$IFDEF MSWINDOWS}
- var
- FileName: array[0..MAX_PATH] of Char;
- begin
- SetString(Result, FileName,
- Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
- {$ENDIF}
- {$IFDEF UNIX}
- {$IFDEF KYLIX}
- var
- FileName: array[0..FILENAME_MAX] of Char;
- begin
- SetString(Result, FileName,
- System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
- {$ELSE}
- begin
- Result := FExpand(ParamStr(0));
- {$ENDIF}
- {$ENDIF}
- {$IFDEF MSDOS}
- begin
- Result := ParamStr(0);
- {$ENDIF}
- end;
- function GetAppDir:string;
- begin
- Result := ExtractFileDir(GetAppExe);
- end;
- function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean): Boolean;
- var
- MaskLen, KeyLen : LongInt;
- function CharMatch(A, B: Char): Boolean;
- begin
- if CaseSensitive then
- Result := A = B
- else
- Result := UpCase(A) = UpCase(B);
- end;
- function MatchAt(MaskPos, KeyPos: LongInt): Boolean;
- begin
- while (MaskPos <= MaskLen) and (KeyPos <= KeyLen) do
- begin
- case Mask[MaskPos] of
- '?' :
- begin
- Inc(MaskPos);
- Inc(KeyPos);
- end;
- '*' :
- begin
- while (MaskPos <= MaskLen) and (Mask[MaskPos] = '*') do
- Inc(MaskPos);
- if MaskPos > MaskLen then
- begin
- Result := True;
- Exit;
- end;
- repeat
- if MatchAt(MaskPos, KeyPos) then
- begin
- Result := True;
- Exit;
- end;
- Inc(KeyPos);
- until KeyPos > KeyLen;
- Result := False;
- Exit;
- end;
- else
- if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then
- begin
- Result := False;
- Exit;
- end
- else
- begin
- Inc(MaskPos);
- Inc(KeyPos);
- end;
- end;
- end;
- while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do
- Inc(MaskPos);
- if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then
- begin
- Result := False;
- Exit;
- end;
- Result := True;
- end;
- begin
- MaskLen := Length(Mask);
- KeyLen := Length(FileName);
- if MaskLen = 0 then
- begin
- Result := True;
- Exit;
- end;
- Result := MatchAt(1, 1);
- end;
- function BuildFileList(Path: string; Attr: LongInt;
- Files: TStrings; Options: TFileListOptions): Boolean;
- var
- FileMask: string;
- RootDir: string;
- Folders: TStringList;
- CurrentItem: LongInt;
- Counter: LongInt;
- LocAttr: LongInt;
- procedure BuildFolderList;
- var
- FindInfo: TSearchRec;
- Rslt: LongInt;
- begin
- Counter := Folders.Count - 1;
- CurrentItem := 0;
- while CurrentItem <= Counter do
- begin
- // Searching for subfolders
- Rslt := SysUtils.FindFirst(Folders[CurrentItem] + '*', faDirectory, FindInfo);
- try
- while Rslt = 0 do
- begin
- if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') and
- (FindInfo.Attr and faDirectory = faDirectory) then
- Folders.Add(Folders[CurrentItem] + FindInfo.Name + PathDelim);
- Rslt := SysUtils.FindNext(FindInfo);
- end;
- finally
- SysUtils.FindClose(FindInfo);
- end;
- Counter := Folders.Count - 1;
- Inc(CurrentItem);
- end;
- end;
- procedure FillFileList(CurrentCounter: LongInt);
- var
- FindInfo: TSearchRec;
- Res: LongInt;
- CurrentFolder: string;
- begin
- CurrentFolder := Folders[CurrentCounter];
- Res := SysUtils.FindFirst(CurrentFolder + FileMask, LocAttr, FindInfo);
- if flRelNames in Options then
- CurrentFolder := ExtractRelativePath(RootDir, CurrentFolder);
- try
- while Res = 0 do
- begin
- if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') then
- begin
- if (flFullNames in Options) or (flRelNames in Options) then
- Files.Add(CurrentFolder + FindInfo.Name)
- else
- Files.Add(FindInfo.Name);
- end;
- Res := SysUtils.FindNext(FindInfo);
- end;
- finally
- SysUtils.FindClose(FindInfo);
- end;
- end;
- begin
- FileMask := ExtractFileName(Path);
- RootDir := ExtractFilePath(Path);
- Folders := TStringList.Create;
- Folders.Add(RootDir);
- Files.Clear;
- {$IFDEF DCC}
- {$WARN SYMBOL_PLATFORM OFF}
- {$ENDIF}
- if Attr = faAnyFile then
- LocAttr := faSysFile or faHidden or faArchive or faReadOnly
- else
- LocAttr := Attr;
- {$IFDEF DCC}
- {$WARN SYMBOL_PLATFORM ON}
- {$ENDIF}
- // Here's the recursive search for nested folders
- if flRecursive in Options then
- BuildFolderList;
- if Attr <> faDirectory then
- for Counter := 0 to Folders.Count - 1 do
- FillFileList(Counter)
- else
- Files.AddStrings(Folders);
- Folders.Free;
- Result := True;
- end;
- function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
- {$IFDEF USE_ASM}
- asm
- // The Original ASM Code is (C) Fastcode project.
- test eax, eax
- jz @Nil
- test edx, edx
- jz @Nil
- dec ecx
- jl @Nil
- push esi
- push ebx
- mov esi, [edx-4] //Length(Str)
- mov ebx, [eax-4] //Length(Substr)
- sub esi, ecx //effective length of Str
- add edx, ecx //addr of the first char at starting position
- cmp esi, ebx
- jl @Past //jump if EffectiveLength(Str)<Length(Substr)
- test ebx, ebx
- jle @Past //jump if Length(Substr)<=0
- add esp, -12
- add ebx, -1 //Length(Substr)-1
- add esi, edx //addr of the terminator
- add edx, ebx //addr of the last char at starting position
- mov [esp+8], esi //save addr of the terminator
- add eax, ebx //addr of the last char of Substr
- sub ecx, edx //-@Str[Length(Substr)]
- neg ebx //-(Length(Substr)-1)
- mov [esp+4], ecx //save -@Str[Length(Substr)]
- mov [esp], ebx //save -(Length(Substr)-1)
- movzx ecx, byte ptr [eax] //the last char of Substr
- @Loop:
- cmp cl, [edx]
- jz @Test0
- @AfterTest0:
- cmp cl, [edx+1]
- jz @TestT
- @AfterTestT:
- add edx, 4
- cmp edx, [esp+8]
- jb @Continue
- @EndLoop:
- add edx, -2
- cmp edx, [esp+8]
- jb @Loop
- @Exit:
- add esp, 12
- @Past:
- pop ebx
- pop esi
- @Nil:
- xor eax, eax
- ret
- @Continue:
- cmp cl, [edx-2]
- jz @Test2
- cmp cl, [edx-1]
- jnz @Loop
- @Test1:
- add edx, 1
- @Test2:
- add edx, -2
- @Test0:
- add edx, -1
- @TestT:
- mov esi, [esp]
- test esi, esi
- jz @Found
- @String:
- movzx ebx, word ptr [esi+eax]
- cmp bx, word ptr [esi+edx+1]
- jnz @AfterTestT
- cmp esi, -2
- jge @Found
- movzx ebx, word ptr [esi+eax+2]
- cmp bx, word ptr [esi+edx+3]
- jnz @AfterTestT
- add esi, 4
- jl @String
- @Found:
- mov eax, [esp+4]
- add edx, 2
- cmp edx, [esp+8]
- ja @Exit
- add esp, 12
- add eax, edx
- pop ebx
- pop esi
- end;
- {$ELSE}
- var
- I, X: LongInt;
- Len, LenSubStr: LongInt;
- begin
- I := Offset;
- LenSubStr := Length(SubStr);
- Len := Length(S) - LenSubStr + 1;
- while I <= Len do
- begin
- if S[I] = SubStr[1] then
- begin
- X := 1;
- while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
- Inc(X);
- if (X = LenSubStr) then
- begin
- Result := I;
- Exit;
- end;
- end;
- Inc(I);
- end;
- Result := 0;
- end;
- {$ENDIF}
- function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt;
- begin
- Result := PosEx(LowerCase(SubStr), LowerCase(S), Offset);
- end;
- function StrToken(var S: string; Sep: Char): string;
- var
- I: LongInt;
- begin
- I := Pos(Sep, S);
- if I <> 0 then
- begin
- Result := Copy(S, 1, I - 1);
- Delete(S, 1, I);
- end
- else
- begin
- Result := S;
- S := '';
- end;
- end;
- function StrTokenEnd(var S: string; Sep: Char): string;
- var
- I, J: LongInt;
- begin
- J := 0;
- I := Pos(Sep, S);
- while I <> 0 do
- begin
- J := I;
- I := PosEx(Sep, S, J + 1);
- end;
- if J <> 0 then
- begin
- Result := Copy(S, J + 1, MaxInt);
- Delete(S, J, MaxInt);
- end
- else
- begin
- Result := S;
- S := '';
- end;
- end;
- function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
- begin
- Result := Number;
- if Result < Min then
- Result := Min
- else
- if Result > Max then
- Result := Max;
- end;
- function ClampFloat(Number: Single; Min, Max: Single): Single;
- begin
- Result := Number;
- if Result < Min then
- Result := Min
- else
- if Result > Max then
- Result := Max;
- end;
- function ClampToByte(Value: LongInt): LongInt;
- begin
- Result := Value;
- if Result > 255 then
- Result := 255
- else if Result < 0 then
- Result := 0;
- end;
- function ClampToWord(Value: LongInt): LongInt;
- begin
- Result := Value;
- if Result > 65535 then
- Result := 65535
- else if Result < 0 then
- Result := 0;
- end;
- function IsPow2(Num: LongInt): Boolean;
- begin
- Result := (Num and -Num) = Num;
- end;
- function NextPow2(Num: LongInt): LongInt;
- begin
- Result := Num and -Num;
- while (Result < Num) do
- Result := Result shl 1;
- end;
- function Pow2Int(Exponent: LongInt): LongInt;
- begin
- Result := 1 shl Exponent;
- end;
- function Power(const Base, Exponent: Single): Single;
- begin
- if Exponent = 0.0 then
- Result := 1.0
- else if (Base = 0.0) and (Exponent > 0.0) then
- Result := 0.0
- else
- Result := Exp(Exponent * Ln(Base));
- end;
- function Log2Int(X: LongInt): LongInt;
- begin
- case X of
- 1: Result := 0;
- 2: Result := 1;
- 4: Result := 2;
- 8: Result := 3;
- 16: Result := 4;
- 32: Result := 5;
- 64: Result := 6;
- 128: Result := 7;
- 256: Result := 8;
- 512: Result := 9;
- 1024: Result := 10;
- 2048: Result := 11;
- 4096: Result := 12;
- 8192: Result := 13;
- 16384: Result := 14;
- 32768: Result := 15;
- 65536: Result := 16;
- 131072: Result := 17;
- 262144: Result := 18;
- 524288: Result := 19;
- 1048576: Result := 20;
- 2097152: Result := 21;
- 4194304: Result := 22;
- 8388608: Result := 23;
- 16777216: Result := 24;
- 33554432: Result := 25;
- 67108864: Result := 26;
- 134217728: Result := 27;
- 268435456: Result := 28;
- 536870912: Result := 29;
- 1073741824: Result := 30;
- else
- Result := -1;
- end;
- end;
- function Log2(X: Single): Single;
- const
- Ln2: Single = 0.6931471;
- begin
- Result := Ln(X) / Ln2;
- end;
- function Floor(Value: Single): LongInt;
- begin
- Result := Trunc(Value);
- if Frac(Value) < 0.0 then
- Dec(Result);
- end;
- function Ceil(Value: Single): LongInt;
- begin
- Result := Trunc(Value);
- if Frac(Value) > 0.0 then
- Inc(Result);
- end;
- procedure Switch(var Value: Boolean);
- begin
- Value := not Value;
- end;
- function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt;
- begin
- if Condition then
- Result := TruePart
- else
- Result := FalsePart;
- end;
- function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord;
- begin
- if Condition then
- Result := TruePart
- else
- Result := FalsePart;
- end;
- function Iff(Condition, TruePart, FalsePart: Boolean): Boolean;
- begin
- if Condition then
- Result := TruePart
- else
- Result := FalsePart;
- end;
- function Iff(Condition: Boolean; const TruePart, FalsePart: string): string;
- begin
- if Condition then
- Result := TruePart
- else
- Result := FalsePart;
- end;
- function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char;
- begin
- if Condition then
- Result := TruePart
- else
- Result := FalsePart;
- end;
- function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer;
- begin
- if Condition then
- Result := TruePart
- else
- Result := FalsePart;
- end;
- function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64;
- begin
- if Condition then
- Result := TruePart
- else
- Result := FalsePart;
- end;
- function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single;
- begin
- if Condition then
- Result := TruePart
- else
- Result := FalsePart;
- end;
- procedure SwapValues(var A, B: Byte);
- var
- Tmp: Byte;
- begin
- Tmp := A;
- A := B;
- B := Tmp;
- end;
- procedure SwapValues(var A, B: Word);
- var
- Tmp: Word;
- begin
- Tmp := A;
- A := B;
- B := Tmp;
- end;
- procedure SwapValues(var A, B: LongInt);
- var
- Tmp: LongInt;
- begin
- Tmp := A;
- A := B;
- B := Tmp;
- end;
- procedure SwapValues(var A, B: Single);
- var
- Tmp: Single;
- begin
- Tmp := A;
- A := B;
- B := Tmp;
- end;
- procedure SwapMin(var Min, Max: LongInt);
- var
- Tmp: LongInt;
- begin
- if Min > Max then
- begin
- Tmp := Min;
- Min := Max;
- Max := Tmp;
- end;
- end;
- function Min(A, B: LongInt): LongInt;
- begin
- if A < B then
- Result := A
- else
- Result := B;
- end;
- function MinFloat(A, B: Single): Single;
- begin
- if A < B then
- Result := A
- else
- Result := B;
- end;
- function Max(A, B: LongInt): LongInt;
- begin
- if A > B then
- Result := A
- else
- Result := B;
- end;
- function MaxFloat(A, B: Single): Single;
- begin
- if A > B then
- Result := A
- else
- Result := B;
- end;
- function MulDiv(Number, Numerator, Denominator: Word): Word;
- {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
- asm
- MUL DX
- DIV CX
- end;
- {$ELSE}
- begin
- Result := Number * Numerator div Denominator;
- end;
- {$IFEND}
- function IsLittleEndian: Boolean;
- var
- W: Word;
- begin
- W := $00FF;
- Result := PByte(@W)^ = $FF;
- end;
- function SwapEndianWord(Value: Word): Word;
- {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
- asm
- XCHG AH, AL
- end;
- {$ELSE}
- begin
- TWordRec(Result).Low := TWordRec(Value).High;
- TWordRec(Result).High := TWordRec(Value).Low;
- end;
- {$IFEND}
- procedure SwapEndianWord(P: PWordArray; Count: LongInt);
- {$IFDEF USE_ASM}
- asm
- @Loop:
- MOV CX, [EAX]
- XCHG CH, CL
- MOV [EAX], CX
- ADD EAX, 2
- DEC EDX
- JNZ @Loop
- end;
- {$ELSE}
- var
- I: LongInt;
- Temp: Word;
- begin
- for I := 0 to Count - 1 do
- begin
- Temp := P[I];
- TWordRec(P[I]).Low := TWordRec(Temp).High;
- TWordRec(P[I]).High := TWordRec(Temp).Low;
- end;
- end;
- {$ENDIF}
- function SwapEndianLongWord(Value: LongWord): LongWord;
- {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
- asm
- BSWAP EAX
- end;
- {$ELSE}
- begin
- TLongWordRec(Result).Bytes[0] := TLongWordRec(Value).Bytes[3];
- TLongWordRec(Result).Bytes[1] := TLongWordRec(Value).Bytes[2];
- TLongWordRec(Result).Bytes[2] := TLongWordRec(Value).Bytes[1];
- TLongWordRec(Result).Bytes[3] := TLongWordRec(Value).Bytes[0];
- end;
- {$IFEND}
- procedure SwapEndianLongWord(P: PLongWord; Count: LongInt);
- {$IFDEF USE_ASM}
- asm
- @Loop:
- MOV ECX, [EAX]
- BSWAP ECX
- MOV [EAX], ECX
- ADD EAX, 4
- DEC EDX
- JNZ @Loop
- end;
- {$ELSE}
- var
- I: LongInt;
- Temp: LongWord;
- begin
- for I := 0 to Count - 1 do
- begin
- Temp := PLongWordArray(P)[I];
- TLongWordRec(PLongWordArray(P)[I]).Bytes[0] := TLongWordRec(Temp).Bytes[3];
- TLongWordRec(PLongWordArray(P)[I]).Bytes[1] := TLongWordRec(Temp).Bytes[2];
- TLongWordRec(PLongWordArray(P)[I]).Bytes[2] := TLongWordRec(Temp).Bytes[1];
- TLongWordRec(PLongWordArray(P)[I]).Bytes[3] := TLongWordRec(Temp).Bytes[0];
- end;
- end;
- {$ENDIF}
- type
- TCrcTable = array[Byte] of LongWord;
- var
- CrcTable: TCrcTable;
- procedure InitCrcTable;
- const
- Polynom = $EDB88320;
- var
- I, J: LongInt;
- C: LongWord;
- begin
- for I := 0 to 255 do
- begin
- C := I;
- for J := 0 to 7 do
- begin
- if (C and $01) <> 0 then
- C := Polynom xor (C shr 1)
- else
- C := C shr 1;
- end;
- CrcTable[I] := C;
- end;
- end;
- procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
- var
- I: LongInt;
- B: PByte;
- begin
- B := Data;
- for I := 0 to Size - 1 do
- begin
- Crc := (Crc shr 8) xor CrcTable[B^ xor Byte(Crc)];
- Inc(B);
- end
- end;
- procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
- {$IFDEF USE_ASM}
- asm
- PUSH EDI
- MOV EDI, EAX
- MOV EAX, ECX
- MOV AH, AL
- MOV CX, AX
- SHL EAX, 16
- MOV AX, CX
- MOV ECX, EDX
- SAR ECX, 2
- JS @Exit
- REP STOSD
- MOV ECX, EDX
- AND ECX, 3
- REP STOSB
- POP EDI
- @Exit:
- end;
- {$ELSE}
- begin
- FillChar(Data^, Size, Value);
- end;
- {$ENDIF}
- procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
- {$IFDEF USE_ASM}
- asm
- PUSH EDI
- PUSH EBX
- MOV EBX, EDX
- MOV EDI, EAX
- MOV EAX, ECX
- MOV CX, AX
- SHL EAX, 16
- MOV AX, CX
- MOV ECX, EDX
- SHR ECX, 2
- JZ @Word
- REP STOSD
- @Word:
- MOV ECX, EBX
- AND ECX, 2
- JZ @Byte
- MOV [EDI], AX
- ADD EDI, 2
- @Byte:
- MOV ECX, EBX
- AND ECX, 1
- JZ @Exit
- MOV [EDI], AL
- @Exit:
- POP EBX
- POP EDI
- end;
- {$ELSE}
- var
- I, V: LongWord;
- begin
- V := Value * $10000 + Value;
- for I := 0 to Size div 4 - 1 do
- PLongWordArray(Data)[I] := V;
- case Size mod 4 of
- 1: PByteArray(Data)[Size - 1] := Lo(Value);
- 2: PWordArray(Data)[Size div 2] := Value;
- 3:
- begin
- PWordArray(Data)[Size div 2 - 1] := Value;
- PByteArray(Data)[Size - 1] := Lo(Value);
- end;
- end;
- end;
- {$ENDIF}
- procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
- {$IFDEF USE_ASM}
- asm
- PUSH EDI
- PUSH EBX
- MOV EBX, EDX
- MOV EDI, EAX
- MOV EAX, ECX
- MOV ECX, EDX
- SHR ECX, 2
- JZ @Word
- REP STOSD
- @Word:
- MOV ECX, EBX
- AND ECX, 2
- JZ @Byte
- MOV [EDI], AX
- ADD EDI, 2
- @Byte:
- MOV ECX, EBX
- AND ECX, 1
- JZ @Exit
- MOV [EDI], AL
- @Exit:
- POP EBX
- POP EDI
- end;
- {$ELSE}
- var
- I: LongInt;
- begin
- for I := 0 to Size div 4 - 1 do
- PLongWordArray(Data)[I] := Value;
- case Size mod 4 of
- 1: PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
- 2: PWordArray(Data)[Size div 2] := TLongWordRec(Value).Words[0];
- 3:
- begin
- PWordArray(Data)[Size div 2 - 1] := TLongWordRec(Value).Words[0];
- PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
- end;
- end;
- end;
- {$ENDIF}
- function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
- begin
- Result := 0;
- if (Width > 0) and (Height > 0) then
- begin
- Result := 1;
- while (Width <> 1) or (Height <> 1) do
- begin
- Width := Width div 2;
- Height := Height div 2;
- if Width < 1 then Width := 1;
- if Height < 1 then Height := 1;
- Inc(Result);
- end;
- end;
- end;
- function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
- var
- I: LongInt;
- begin
- Result := Depth;
- for I := 1 to MipMaps - 1 do
- Inc(Result, ClampInt(Depth shr I, 1, Depth));
- end;
- function BoundsToRect(X, Y, Width, Height: LongInt): TRect;
- begin
- Result.Left := X;
- Result.Top := Y;
- Result.Right := X + Width;
- Result.Bottom := Y + Height;
- end;
- function BoundsToRect(const R: TRect): TRect;
- begin
- Result.Left := R.Left;
- Result.Top := R.Top;
- Result.Right := R.Left + R.Right;
- Result.Bottom := R.Top + R.Bottom;
- end;
- function RectToBounds(const R: TRect): TRect;
- begin
- Result.Left := R.Left;
- Result.Top := R.Top;
- Result.Right := R.Right - R.Left;
- Result.Bottom := R.Bottom - R.Top;
- end;
- procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect);
- procedure ClipDim(var AStart, ALength: LongInt; ClipMin, ClipMax: LongInt);
- begin
- if AStart < ClipMin then
- begin
- ALength := ALength - (ClipMin - AStart);
- AStart := ClipMin;
- end;
- if AStart + ALength > ClipMax then ALength := Max(0, ClipMax - AStart);
- end;
- begin
- ClipDim(X, Width, Clip.Left, Clip.Right);
- ClipDim(Y, Height, Clip.Top, Clip.Bottom);
- end;
- procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
- procedure ClipDim(var SrcPos, DstPos, Size: LongInt; SrcClipMax,
- DstClipMin, DstClipMax: LongInt);
- var
- OldDstPos: LongInt;
- Diff: LongInt;
- begin
- OldDstPos := Iff(DstPos < 0, DstPos, 0);
- if DstPos < DstClipMin then
- begin
- Diff := DstClipMin - DstPos;
- Size := Size - Diff;
- if DstPos < SrcPos then
- SrcPos := SrcPos + Diff;
- DstPos := DstClipMin;
- end;
- if SrcPos < 0 then
- begin
- Size := Size + SrcPos - OldDstPos;
- DstPos := DstPos - SrcPos + OldDstPos;
- SrcPos := 0;
- end;
- if SrcPos + Size > SrcClipMax then Size := SrcClipMax - SrcPos;
- if DstPos + Size > DstClipMax then Size := DstClipMax - DstPos;
- end;
- begin
- ClipDim(SrcX, DstX, Width, SrcImageWidth, DstClip.Left, DstClip.Right);
- ClipDim(SrcY, DstY, Height, SrcImageHeight, DstClip.Top, DstClip.Bottom);
- end;
- procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
- DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect);
- procedure ClipDim(var SrcPos, DstPos, SrcSize, DstSize: LongInt; SrcClipMax,
- DstClipMin, DstClipMax: LongInt);
- var
- OldSize: LongInt;
- Diff: LongInt;
- Scale: Single;
- begin
- Scale := DstSize / SrcSize;
- if DstPos < DstClipMin then
- begin
- Diff := DstClipMin - DstPos;
- DstSize := DstSize - Diff;
- SrcPos := SrcPos + Round(Diff / Scale);
- SrcSize := SrcSize - Round(Diff / Scale);
- DstPos := DstClipMin;
- end;
- if SrcPos < 0 then
- begin
- SrcSize := SrcSize + SrcPos;
- DstPos := DstPos - Round(SrcPos * Scale);
- DstSize := DstSize + Round(SrcPos * Scale);
- SrcPos := 0;
- end;
- if SrcPos + SrcSize > SrcClipMax then
- begin
- OldSize := SrcSize;
- SrcSize := SrcClipMax - SrcPos;
- DstSize := Round(DstSize * (SrcSize / OldSize));
- end;
- if DstPos + DstSize > DstClipMax then
- begin
- OldSize := DstSize;
- DstSize := DstClipMax - DstPos;
- SrcSize := Round(SrcSize * (DstSize / OldSize));
- end;
- end;
- begin
- ClipDim(SrcX, DstX, SrcWidth, DstWidth, SrcImageWidth, DstClip.Left, DstClip.Right);
- ClipDim(SrcY, DstY, SrcHeight, DstHeight, SrcImageHeight, DstClip.Top, DstClip.Bottom);
- end;
- function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
- var
- SourceWidth: LongInt;
- SourceHeight: LongInt;
- TargetWidth: LongInt;
- TargetHeight: LongInt;
- ScaledWidth: LongInt;
- ScaledHeight: LongInt;
- begin
- SourceWidth := SourceRect.Right - SourceRect.Left;
- SourceHeight := SourceRect.Bottom - SourceRect.Top;
- TargetWidth := TargetRect.Right - TargetRect.Left;
- TargetHeight := TargetRect.Bottom - TargetRect.Top;
- if SourceWidth * TargetHeight < SourceHeight * TargetWidth then
- begin
- ScaledWidth := (SourceWidth * TargetHeight) div SourceHeight;
- Result := BoundsToRect(TargetRect.Left + ((TargetWidth - ScaledWidth) div 2),
- TargetRect.Top, ScaledWidth, TargetHeight);
- end
- else
- begin
- ScaledHeight := (SourceHeight * TargetWidth) div SourceWidth;
- Result := BoundsToRect(TargetRect.Left, TargetRect.Top + ((TargetHeight - ScaledHeight) div 2),
- TargetWidth, ScaledHeight);
- end;
- end;
- function RectInRect(const R1, R2: TRect): Boolean;
- begin
- Result:=
- (R1.Left >= R2.Left) and
- (R1.Top >= R2.Top) and
- (R1.Right <= R2.Right) and
- (R1.Bottom <= R2.Bottom);
- end;
- function RectIntersects(const R1, R2: TRect): Boolean;
- begin
- Result :=
- not (R1.Left > R2.Right) and
- not (R1.Top > R2.Bottom) and
- not (R1.Right < R2.Left) and
- not (R1.Bottom < R2.Top);
- end;
- function FormatExceptMsg(const Msg: string; const Args: array of const): string;
- begin
- Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args);
- end;
- procedure DebugMsg(const Msg: string; const Args: array of const);
- var
- FmtMsg: string;
- begin
- FmtMsg := Format(Msg, Args);
- {$IFDEF MSWINDOWS}
- if IsConsole then
- WriteLn('DebugMsg: ' + FmtMsg)
- else
- MessageBox(GetActiveWindow, PChar(FmtMsg), 'DebugMsg', MB_OK);
- {$ENDIF}
- {$IFDEF UNIX}
- WriteLn('DebugMsg: ' + FmtMsg);
- {$ENDIF}
- {$IFDEF MSDOS}
- WriteLn('DebugMsg: ' + FmtMsg);
- {$ENDIF}
- end;
- initialization
- InitCrcTable;
- {$IFDEF MSWINDOWS}
- QueryPerformanceFrequency(PerfFrequency);
- InvPerfFrequency := 1.0 / PerfFrequency;
- {$ENDIF}
- {$IFDEF MSDOS}
- // reset PIT
- asm
- MOV EAX, $34
- OUT $43, AL
- XOR EAX, EAX
- OUT $40, AL
- OUT $40, AL
- end;
- {$ENDIF}
- {
- File Notes:
- -- TODOS ----------------------------------------------------
- - nothing now
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Added RectInRect and RectIntersects functions
- - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase.
- - Moved BuildFileList here from DemoUtils.
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Moved GetVolumeLevelCount from ImagingDds here.
- - Renamed FillMemory to FillMemoryByte to avoid name collision in C++ Builder.
- - Added Iff function for Char, Pointer, and Int64 types.
- - Added IsLittleEndian function.
- - Added array types for TWordRec, TLongWordRec, and TInt64Rec.
- - Added MatchFileNameMask function.
- -- 0.19 Changes/Bug Fixes -----------------------------------
- - added ScaleRectToRect (thanks to Paul Michell)
- - added BoundsToRect, ClipBounds, ClipCopyBounds, ClipStretchBounds functions
- - added MulDiv function
- - FreeAndNil is not inline anymore - caused AV in one program
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - GetAppExe didn't return absolute path in FreeBSD, fixed
- - added debug message output
- - fixed Unix compatibility issues (thanks to Ales Katona).
- Imaging now compiles in FreeBSD and maybe in other Unixes as well.
- -- 0.15 Changes/Bug Fixes -----------------------------------
- - added some new utility functions
- -- 0.13 Changes/Bug Fixes -----------------------------------
- - added many new utility functions
- - minor change in SwapEndian to avoid range check error
- }
- end.
|