From 46bb010ca7c5eb04551c030105f9999ca80e472f Mon Sep 17 00:00:00 2001 From: tobigun Date: Sun, 8 Jun 2008 15:33:48 +0000 Subject: - set svn:eol-style to native - removed some svn:executable properties from non-executable files git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@1144 b956fd51-792f-4845-bead-9b4dfca2ff2c --- Game/Code/Classes/UCommon.pas | 1582 ++++++++++++++++++++--------------------- 1 file changed, 791 insertions(+), 791 deletions(-) (limited to 'Game/Code/Classes/UCommon.pas') diff --git a/Game/Code/Classes/UCommon.pas b/Game/Code/Classes/UCommon.pas index f3edd62a..418c0c1a 100644 --- a/Game/Code/Classes/UCommon.pas +++ b/Game/Code/Classes/UCommon.pas @@ -1,791 +1,791 @@ -unit UCommon; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - Classes, - {$IFDEF MSWINDOWS} - Windows, - Messages, - {$ENDIF} - sdl, - ULog; - -{$IFNDEF DARWIN} -// FIXME: remove this if it is not needed anymore -type - hStream = THandle; - HGLRC = THandle; - TLargeInteger = Int64; - TWin32FindData = LongInt; -{$ENDIF} - -type - TMessageType = ( mtInfo, mtError ); - -procedure ShowMessage( const msg : String; msgType: TMessageType = mtInfo ); - -procedure ConsoleWriteLn(const msg: string); - -function GetResourceStream(const aName, aType : string): TStream; -function RWopsFromStream(Stream: TStream): PSDL_RWops; - -{$IFDEF FPC} -function RandomRange(aMin: Integer; aMax: Integer) : Integer; -{$ENDIF} - -{$IF Defined(MSWINDOWS) and Defined(FPC)} -function AllocateHWnd(Method: TWndMethod): HWND; -procedure DeallocateHWnd(hWnd: HWND); -{$IFEND} - -function StringReplaceW(text : WideString; search, rep: WideChar):WideString; -function AdaptFilePaths( const aPath : widestring ): widestring; - -procedure DisableFloatingPointExceptions(); -procedure SetDefaultNumericLocale(); -procedure RestoreNumericLocale(); - -{$IFNDEF MSWINDOWS} - procedure ZeroMemory( Destination: Pointer; Length: DWORD ); - function MakeLong(a, b: Word): Longint; - (* - #define LOBYTE(a) (BYTE)(a) - #define HIBYTE(a) (BYTE)((a)>>8) - #define LOWORD(a) (WORD)(a) - #define HIWORD(a) (WORD)((a)>>16) - #define MAKEWORD(a,b) (WORD)(((a)&0xff)|((b)<<8)) - *) -{$ENDIF} - -function FileExistsInsensitive(var FileName: string): boolean; - -(* - * Character classes - *) - -function IsAlphaChar(ch: WideChar): boolean; -function IsNumericChar(ch: WideChar): boolean; -function IsAlphaNumericChar(ch: WideChar): boolean; -function IsPunctuationChar(ch: WideChar): boolean; -function IsControlChar(ch: WideChar): boolean; - -// A stable alternative to TList.Sort() (use TList.Sort() if applicable, see below) -procedure MergeSort(List: TList; CompareFunc: TListSortCompare); - - -implementation - -uses - Math, - {$IFDEF Delphi} - Dialogs, - {$ENDIF} - {$IFDEF LINUX} - libc, - {$ENDIF} - UMain, - UConfig; - -var - PrevNumLocale: string; - -// In Linux and maybe MacOSX some units (like cwstring) call setlocale(LC_ALL, '') -// to set the language/country specific locale (e.g. charset) for this application. -// Unfortunately, LC_NUMERIC is set by this call too. -// It defines the decimal-separator and other country-specific numeric settings. -// This parameter is used by the C string-to-float parsing functions atof() and strtod(). -// After changing LC_NUMERIC some external C-based libs (like projectM) are not -// able to parse strings correctly -// (e.g. in Germany "0.9" is not recognized as a valid number anymore but "0,9" is). -// So we reset the numeric settings to the default ('C'). -// Note: The behaviour of Pascal parsing functions (e.g. strtofloat()) is not -// changed by this because it doesn't use the locale-settings. -// TODO: -// - Check if this is needed in MacOSX (at least the locale is set in cwstring) -// - Find out which libs are concerned by this problem. -// If only projectM is concerned by this problem set and restore the numeric locale -// for each call to projectM instead of changing it globally. -procedure SetDefaultNumericLocale(); -begin - {$ifdef LINUX} - PrevNumLocale := setlocale(LC_NUMERIC, nil); - setlocale(LC_NUMERIC, 'C'); - {$endif} -end; - -procedure RestoreNumericLocale(); -begin - {$ifdef LINUX} - setlocale(LC_NUMERIC, PChar(PrevNumLocale)); - {$endif} -end; - -(* - * If an invalid floating point operation was performed the Floating-point unit (FPU) - * generates a Floating-point exception (FPE). Dependending on the settings in - * the FPU's control-register (interrupt mask) the FPE is handled by the FPU itself - * (we will call this as "FPE disabled" later on) or is passed to the application - * (FPE enabled). - * If FPEs are enabled a floating-point division by zero (e.g. 10.0 / 0.0) is - * considered an error and an exception is thrown. Otherwise the FPU will handle - * the error and return the result infinity (INF) (10.0 / 0.0 = INF) without - * throwing an error to the application. - * The same applies to a division by INF that either raises an exception - * (FPE enabled) or returns 0.0 (FPE disabled). - * Normally (as with C-programs), Floating-point exceptions (FPE) are DISABLED - * on program startup (at least with Intel CPUs), but for some strange reasons - * they are ENABLED in pascal (both delphi and FPC) by default. - * Many libs operating with floating-point values rely heavily on the C-specific - * behaviour. So using them in delphi is a ticking time-bomb because sooner or - * later they will crash because of an FPE (this problem occurs massively - * in OpenGL-based libs like projectM). In contrast to this no error will occur - * if the lib is linked to a C-program. - * - * Further info on FPUs: - * For x86 and x86_64 CPUs we have to consider two FPU instruction sets. - * The math co-processor i387 (aka 8087 or x87) set introduced with the i386 - * and SSE (Streaming SIMD Extensions) introduced with the Pentium3. - * Both of them have separate control-registers (x87: FPUControlWord, SSE: MXCSR) - * to control FPEs. Either has (among others) 6bits to enable/disable several - * exception types (Invalid,Denormalized,Zero,Overflow,Underflow,Precision). - * Those exception-types must all be masked (=1) to get the default C behaviour. - * The control-registers can be set with the asm-ops FLDCW (x87) and LDMXCSR (SSE). - * Instead of using assembler code, we can use Set8087CW() provided by delphi and - * FPC to set the x87 control-word. FPC also provides SetSSECSR() for SSE's MXCSR. - * Note that both Delphi and FPC enable FPEs (e.g. for div-by-zero) on program - * startup but only FPC enables FPEs (especially div-by-zero) for SSE too. - * So we have to mask FPEs for x87 in Delphi and FPC and for SSE in FPC only. - * FPC and Delphi both provide a SetExceptionMask() for control of the FPE - * mask. SetExceptionMask() sets the masks for x87 in Delphi and for x87 and SSE - * in FPC (seems as if Delphi [2005] is not SSE aware). So SetExceptionMask() - * is what we need and it even is plattform and CPU independent. - * - * Pascal OpenGL headers (like the Delphi standard ones or JEDI-SDL headers) - * already call Set8087CW() to disable FPEs but due to some bugs in the JEDI-SDL - * headers they do not work properly with FPC. I already patched them, so they - * work at least until they are updated the next time. In addition Set8086CW() - * does not suffice to disable FPEs because the SSE FPEs are not disabled by this. - * FPEs with SSE are a big problem with some libs because many linux distributions - * optimize code for SSE or Pentium3 (for example: int(INF) which convert the - * double value "infinity" to an integer might be automatically optimized by - * using SSE's CVTSD2SI instruction). So SSE FPEs must be turned off in any case - * to make USDX portable. - * - * Summary: - * Call this function on initialization to make sure FPEs are turned off. - * It will solve a lot of errors with FPEs in external libs. - *) -procedure DisableFloatingPointExceptions(); -begin - (* - // We will use SetExceptionMask() instead of Set8087CW()/SetSSECSR(). - // Note: Leave these lines for documentation purposes just in case - // SetExceptionMask() does not work anymore (due to bugs in FPC etc.). - {$IF Defined(CPU386) or Defined(CPUI386) or Defined(CPUX86_64)} - Set8087CW($133F); - {$IFEND} - {$IF Defined(FPC)} - if (has_sse_support) then - SetSSECSR($1F80); - {$IFEND} - *) - - // disable all of the six FPEs (x87 and SSE) to be compatible with C/C++ and - // other libs which rely on the standard FPU behaviour (no div-by-zero FPE anymore). - SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, - exOverflow, exUnderflow, exPrecision]); -end; - -function StringReplaceW(text : WideString; search, rep: WideChar):WideString; -var - iPos : integer; -// sTemp : WideString; -begin -(* - result := text; - iPos := Pos(search, result); - while (iPos > 0) do - begin - sTemp := copy(result, iPos + length(search), length(result)); - result := copy(result, 1, iPos - 1) + rep + sTEmp; - iPos := Pos(search, result); - end; -*) - result := text; - - if search = rep then - exit; - - for iPos := 0 to length( result ) - 1 do - begin - if result[ iPos ] = search then - result[ iPos ] := rep; - end; -end; - -function AdaptFilePaths( const aPath : widestring ): widestring; -begin - result := StringReplaceW( aPath, '\', PathDelim );//, [rfReplaceAll] ); -end; - - -{$IFNDEF MSWINDOWS} -procedure ZeroMemory( Destination: Pointer; Length: DWORD ); -begin - FillChar( Destination^, Length, 0 ); -end; - -function MakeLong(A, B: Word): Longint; -begin - Result := (LongInt(B) shl 16) + A; -end; - -(* -function QueryPerformanceCounter(lpPerformanceCount:TLARGEINTEGER):Bool; - - // From http://en.wikipedia.org/wiki/RDTSC - function RDTSC: Int64; register; - asm - rdtsc - end; - -begin - // Use clock_gettime here maybe ... from libc - lpPerformanceCount := RDTSC(); - result := true; -end; - -function QueryPerformanceFrequency(lpFrequency:TLARGEINTEGER):Bool; -begin - lpFrequency := 0; - result := true; -end; -*) -{$ENDIF} - -// Checks if a regular files or directory with the given name exists. -// The comparison is case insensitive. -function FileExistsInsensitive(var FileName: string): boolean; -var - FilePath, LocalFileName: string; - SearchInfo: TSearchRec; -begin -{$IFDEF LINUX} // eddie: Changed FPC to LINUX: Windows and Mac OS X dont have case sensitive file systems - // speed up standard case - if FileExists(FileName) then - begin - Result := true; - exit; - end; - - Result := false; - - FilePath := ExtractFilePath(FileName); - if (FindFirst(FilePath+'*', faAnyFile, SearchInfo) = 0) then - begin - LocalFileName := ExtractFileName(FileName); - repeat - if (AnsiSameText(LocalFileName, SearchInfo.Name)) then - begin - FileName := FilePath + SearchInfo.Name; - Result := true; - break; - end; - until (FindNext(SearchInfo) <> 0); - end; - FindClose(SearchInfo); -{$ELSE} - Result := FileExists(FileName); -{$ENDIF} -end; - - -{$IFDEF Unix} - // include resource-file info (stored in the constant array "resources") - {$I ../resource.inc} -{$ENDIF} - -function GetResourceStream(const aName, aType: string): TStream; -{$IFDEF Unix} -var - ResIndex: integer; - Filename: string; -{$ENDIF} -begin - Result := nil; - - {$IFDEF Unix} - for ResIndex := 0 to High(resources) do - begin - if (resources[ResIndex][0] = aName ) and - (resources[ResIndex][1] = aType ) then - begin - try - Filename := ResourcesPath + resources[ResIndex][2]; - Result := TFileStream.Create(Filename, fmOpenRead); - except - Log.LogError('Failed to open: "'+ resources[ResIndex][2] +'"', 'GetResourceStream'); - end; - exit; - end; - end; - {$ELSE} - try - Result := TResourceStream.Create(HInstance, aName , PChar(aType)); - except - Log.LogError('Invalid resource: "'+ aType + ':' + aName +'"', 'GetResourceStream'); - end; - {$ENDIF} -end; - -// +++++++++++++++++++++ helpers for RWOpsFromStream() +++++++++++++++ - function SdlStreamSeek( context : PSDL_RWops; offset : Integer; whence : Integer ) : integer; cdecl; - var - stream : TStream; - origin : Word; - begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamSeek on nil' ); - case whence of - 0 : origin := soFromBeginning; // Offset is from the beginning of the resource. Seek moves to the position Offset. Offset must be >= 0. - 1 : origin := soFromCurrent; // Offset is from the current position in the resource. Seek moves to Position + Offset. - 2 : origin := soFromEnd; - else - origin := soFromBeginning; // just in case - end; - Result := stream.Seek( offset, origin ); - end; - - function SdlStreamRead( context : PSDL_RWops; Ptr : Pointer; size : Integer; maxnum: Integer ) : Integer; cdecl; - var - stream : TStream; - begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamRead on nil' ); - try - Result := stream.read( Ptr^, Size * maxnum ) div size; - except - Result := -1; - end; - end; - - function SDLStreamClose( context : PSDL_RWops ) : Integer; cdecl; - var - stream : TStream; - begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamClose on nil' ); - stream.Free; - Result := 1; - end; -// ----------------------------------------------- - -(* - * Creates an SDL_RWops handle from a TStream. - * The stream and RWops must be freed by the user after usage. - * Use SDL_FreeRW(...) to free the RWops data-struct. - *) -function RWopsFromStream(Stream: TStream): PSDL_RWops; -begin - Result := SDL_AllocRW(); - if (Result = nil) then - Exit; - - // set RW-callbacks - with Result^ do - begin - unknown := TUnknown(Stream); - seek := SDLStreamSeek; - read := SDLStreamRead; - write := nil; - close := SDLStreamClose; - type_ := 2; - end; -end; - - - -{$IFDEF FPC} -function RandomRange(aMin: Integer; aMax: Integer) : Integer; -begin - RandomRange := Random(aMax-aMin) + aMin ; -end; -{$ENDIF} - -{$IF Defined(MSWINDOWS) and Defined(FPC)} -function AllocateHWndCallback(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -var - Msg: TMessage; - MethodPtr: ^TWndMethod; -begin - FillChar(Msg, SizeOf(Msg), 0); - Msg.msg := uMsg; - Msg.wParam := wParam; - Msg.lParam := lParam; - - MethodPtr := Pointer(GetWindowLongPtr(hwnd, GWL_USERDATA)); - if Assigned(MethodPtr) then - MethodPtr^(Msg); - - Result := DefWindowProc(hwnd, uMsg, wParam, lParam); -end; - -function AllocateHWnd(Method: TWndMethod): HWND; -var - ClassExists: Boolean; - WndClass, OldClass: TWndClass; - MethodPtr: ^TMethod; -begin - Result := 0; - - // setup class-info - FillChar(WndClass, SizeOf(TWndClass), 0); - WndClass.hInstance := HInstance; - // Important: do not enable AllocateHWndCallback before the msg-handler method is assigned, - // otherwise race-conditions might occur - WndClass.lpfnWndProc := @DefWindowProc; - WndClass.lpszClassName:= 'USDXUtilWindowClass'; - - // check if class is already registered - ClassExists := GetClassInfo(HInstance, WndClass.lpszClassName, OldClass); - // create window-class shared by all windows created by AllocateHWnd() - if (not ClassExists) or (@OldClass.lpfnWndProc <> @DefWindowProc) then - begin - if ClassExists then - UnregisterClass(WndClass.lpszClassName, HInstance); - if (RegisterClass(WndClass) = 0) then - Exit; - end; - // create window - Result := CreateWindowEx(WS_EX_TOOLWINDOW, WndClass.lpszClassName, '', - DWORD(WS_POPUP), 0, 0, 0, 0, 0, 0, HInstance, nil); - if (Result = 0) then - Exit; - // assign individual callback procedure to the window - if Assigned(Method) then - begin - // TMethod contains two pointers but we can pass just one as USERDATA - GetMem(MethodPtr, SizeOf(TMethod)); - MethodPtr^ := TMethod(Method); - SetWindowLongPtr(Result, GWL_USERDATA, LONG_PTR(MethodPtr)); - end; - // now enable AllocateHWndCallback for this window - SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@AllocateHWndCallback)); -end; - -procedure DeallocateHWnd(hWnd: HWND); -var - MethodPtr: ^TMethod; -begin - if (hWnd <> 0) then - begin - MethodPtr := Pointer(GetWindowLongPtr(hWnd, GWL_USERDATA)); - DestroyWindow(hWnd); - if Assigned(MethodPtr) then - FreeMem(MethodPtr); - end; -end; -{$IFEND} - -{$IFDEF FPC} -var - MessageList: TStringList; - ConsoleHandler: TThreadID; - // Note: TRTLCriticalSection is defined in the units System and Libc, use System one - ConsoleCriticalSection: System.TRTLCriticalSection; - ConsoleEvent: PRTLEvent; - ConsoleQuit: boolean; -{$ENDIF} - -(* - * Write to console if one is available. - * It checks if a console is available before output so it will not - * crash on windows if none is available. - * Do not use this function directly because it is not thread-safe, - * use ConsoleWriteLn() instead. - *) -procedure _ConsoleWriteLn(const aString: string); {$IFDEF HasInline}inline;{$ENDIF} -begin - {$IFDEF MSWINDOWS} - // sanity check to avoid crashes with writeln() - if (IsConsole) then - begin - {$ENDIF} - Writeln(aString); - {$IFDEF MSWINDOWS} - end; - {$ENDIF} -end; - -{$IFDEF FPC} -{* - * The console-handlers main-function. - * TODO: create a quit-event on closing. - *} -function ConsoleHandlerFunc(param: pointer): PtrInt; -var - i: integer; - quit: boolean; -begin - quit := false; - while (not quit) do - begin - // wait for new output or quit-request - RTLeventWaitFor(ConsoleEvent); - - System.EnterCriticalSection(ConsoleCriticalSection); - // output pending messages - for i := 0 to MessageList.Count-1 do - begin - _ConsoleWriteLn(MessageList[i]); - end; - MessageList.Clear(); - - // use local quit-variable to avoid accessing - // ConsoleQuit outside of the critical section - if (ConsoleQuit) then - quit := true; - - RTLeventResetEvent(ConsoleEvent); - System.LeaveCriticalSection(ConsoleCriticalSection); - end; - result := 0; -end; -{$ENDIF} - -procedure InitConsoleOutput(); -begin - {$IFDEF FPC} - // init thread-safe output - MessageList := TStringList.Create(); - System.InitCriticalSection(ConsoleCriticalSection); - ConsoleEvent := RTLEventCreate(); - ConsoleQuit := false; - // must be a thread managed by FPC. Otherwise (e.g. SDL-thread) - // it will crash when using Writeln. - ConsoleHandler := BeginThread(@ConsoleHandlerFunc); - {$ENDIF} -end; - -procedure FinalizeConsoleOutput(); -begin - {$IFDEF FPC} - // terminate console-handler - System.EnterCriticalSection(ConsoleCriticalSection); - ConsoleQuit := true; - RTLeventSetEvent(ConsoleEvent); - System.LeaveCriticalSection(ConsoleCriticalSection); - WaitForThreadTerminate(ConsoleHandler, 0); - // free data - System.DoneCriticalsection(ConsoleCriticalSection); - RTLeventDestroy(ConsoleEvent); - MessageList.Free(); - {$ENDIF} -end; - -{* - * With FPC console output is not thread-safe. - * Using WriteLn() from external threads (like in SDL callbacks) - * will damage the heap and crash the program. - * Most probably FPC uses thread-local-data (TLS) to lock a mutex on - * the console-buffer. This does not work with external lib's threads - * because these do not have the TLS data and so it crashes while - * accessing unallocated memory. - * The solution is to create an FPC-managed thread which has the TLS data - * and use it to handle the console-output (hence it is called Console-Handler) - * It should be safe to do so, but maybe FPC requires the main-thread to access - * the console-buffer only. In this case output should be delegated to it. - * - * TODO: - check if it is safe if an FPC-managed thread different than the - * main-thread accesses the console-buffer in FPC. - * - check if Delphi's WriteLn is thread-safe. - * - check if we need to synchronize file-output too - *} -procedure ConsoleWriteLn(const msg: string); -begin -{$IFDEF CONSOLE} - {$IFDEF FPC} - // TODO: check for the main-thread and use a simple _ConsoleWriteLn() then? - //GetCurrentThreadThreadId(); - System.EnterCriticalSection(ConsoleCriticalSection); - MessageList.Add(msg); - RTLeventSetEvent(ConsoleEvent); - System.LeaveCriticalSection(ConsoleCriticalSection); - {$ELSE} - _ConsoleWriteLn(msg); - {$ENDIF} -{$ENDIF} -end; - -procedure ShowMessage(const msg: String; msgType: TMessageType); -{$IFDEF MSWINDOWS} -var Flags: Cardinal; -{$ENDIF} -begin -{$IF Defined(MSWINDOWS)} - case msgType of - mtInfo: Flags := MB_ICONINFORMATION or MB_OK; - mtError: Flags := MB_ICONERROR or MB_OK; - else Flags := MB_OK; - end; - MessageBox(0, PChar(msg), PChar(USDXVersionStr()), Flags); -{$ELSE} - ConsoleWriteln(msg); -{$IFEND} -end; - -function IsAlphaChar(ch: WideChar): boolean; -begin - // TODO: add chars > 255 when unicode-fonts work? - case ch of - 'A'..'Z', // A-Z - 'a'..'z', // a-z - #170,#181,#186, - #192..#214, - #216..#246, - #248..#255: - Result := true; - else - Result := false; - end; -end; - -function IsNumericChar(ch: WideChar): boolean; -begin - case ch of - '0'..'9': - Result := true; - else - Result := false; - end; -end; - -function IsAlphaNumericChar(ch: WideChar): boolean; -begin - Result := (IsAlphaChar(ch) or IsNumericChar(ch)); -end; - -function IsPunctuationChar(ch: WideChar): boolean; -begin - // TODO: add chars outside of Latin1 basic (0..127)? - case ch of - ' '..'/',':'..'@','['..'`','{'..'~': - Result := true; - else - Result := false; - end; -end; - -function IsControlChar(ch: WideChar): boolean; -begin - case ch of - #0..#31, - #127..#159: - Result := true; - else - Result := false; - end; -end; - -(* - * Recursive part of the MergeSort algorithm. - * OutList will be either InList or TempList and will be swapped in each - * depth-level of recursion. By doing this it we can directly merge into the - * output-list. If we only had In- and OutList parameters we had to merge into - * InList after the recursive calls and copy the data to the OutList afterwards. - *) -procedure _MergeSort(InList, TempList, OutList: TList; StartPos, BlockSize: integer; - CompareFunc: TListSortCompare); -var - LeftSize, RightSize: integer; // number of elements in left/right block - LeftEnd, RightEnd: integer; // Index after last element in left/right block - MidPos: integer; // index of first element in right block - Pos: integer; // position in output list -begin - LeftSize := BlockSize div 2; - RightSize := BlockSize - LeftSize; - MidPos := StartPos + LeftSize; - - // sort left and right halves of this block by recursive calls of this function - if (LeftSize >= 2) then - _MergeSort(InList, OutList, TempList, StartPos, LeftSize, CompareFunc) - else - TempList[StartPos] := InList[StartPos]; - if (RightSize >= 2) then - _MergeSort(InList, OutList, TempList, MidPos, RightSize, CompareFunc) - else - TempList[MidPos] := InList[MidPos]; - - // merge sorted left and right sub-lists into output-list - LeftEnd := MidPos; - RightEnd := StartPos + BlockSize; - Pos := StartPos; - while ((StartPos < LeftEnd) and (MidPos < RightEnd)) do - begin - if (CompareFunc(TempList[StartPos], TempList[MidPos]) <= 0) then - begin - OutList[Pos] := TempList[StartPos]; - Inc(StartPos); - end - else - begin - OutList[Pos] := TempList[MidPos]; - Inc(MidPos); - end; - Inc(Pos); - end; - - // copy remaining elements to output-list - while (StartPos < LeftEnd) do - begin - OutList[Pos] := TempList[StartPos]; - Inc(StartPos); - Inc(Pos); - end; - while (MidPos < RightEnd) do - begin - OutList[Pos] := TempList[MidPos]; - Inc(MidPos); - Inc(Pos); - end; -end; - -(* - * Stable alternative to the instable TList.Sort() (uses QuickSort) implementation. - * A stable sorting algorithm preserves preordered items. E.g. if sorting by - * songs by title first and artist afterwards, the songs of each artist will - * be ordered by title. In contrast to this an unstable algorithm (like QuickSort) - * may destroy an existing order, so the songs of an artist will not be ordered - * by title anymore after sorting by artist in the previous example. - * If you do not need a stable algorithm, use TList.Sort() instead. - *) -procedure MergeSort(List: TList; CompareFunc: TListSortCompare); -var - TempList: TList; -begin - TempList := TList.Create(); - TempList.Count := List.Count; - if (List.Count >= 2) then - _MergeSort(List, TempList, List, 0, List.Count, CompareFunc); - TempList.Free; -end; - - -initialization - InitConsoleOutput(); - -finalization - FinalizeConsoleOutput(); - -end. +unit UCommon; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SysUtils, + Classes, + {$IFDEF MSWINDOWS} + Windows, + Messages, + {$ENDIF} + sdl, + ULog; + +{$IFNDEF DARWIN} +// FIXME: remove this if it is not needed anymore +type + hStream = THandle; + HGLRC = THandle; + TLargeInteger = Int64; + TWin32FindData = LongInt; +{$ENDIF} + +type + TMessageType = ( mtInfo, mtError ); + +procedure ShowMessage( const msg : String; msgType: TMessageType = mtInfo ); + +procedure ConsoleWriteLn(const msg: string); + +function GetResourceStream(const aName, aType : string): TStream; +function RWopsFromStream(Stream: TStream): PSDL_RWops; + +{$IFDEF FPC} +function RandomRange(aMin: Integer; aMax: Integer) : Integer; +{$ENDIF} + +{$IF Defined(MSWINDOWS) and Defined(FPC)} +function AllocateHWnd(Method: TWndMethod): HWND; +procedure DeallocateHWnd(hWnd: HWND); +{$IFEND} + +function StringReplaceW(text : WideString; search, rep: WideChar):WideString; +function AdaptFilePaths( const aPath : widestring ): widestring; + +procedure DisableFloatingPointExceptions(); +procedure SetDefaultNumericLocale(); +procedure RestoreNumericLocale(); + +{$IFNDEF MSWINDOWS} + procedure ZeroMemory( Destination: Pointer; Length: DWORD ); + function MakeLong(a, b: Word): Longint; + (* + #define LOBYTE(a) (BYTE)(a) + #define HIBYTE(a) (BYTE)((a)>>8) + #define LOWORD(a) (WORD)(a) + #define HIWORD(a) (WORD)((a)>>16) + #define MAKEWORD(a,b) (WORD)(((a)&0xff)|((b)<<8)) + *) +{$ENDIF} + +function FileExistsInsensitive(var FileName: string): boolean; + +(* + * Character classes + *) + +function IsAlphaChar(ch: WideChar): boolean; +function IsNumericChar(ch: WideChar): boolean; +function IsAlphaNumericChar(ch: WideChar): boolean; +function IsPunctuationChar(ch: WideChar): boolean; +function IsControlChar(ch: WideChar): boolean; + +// A stable alternative to TList.Sort() (use TList.Sort() if applicable, see below) +procedure MergeSort(List: TList; CompareFunc: TListSortCompare); + + +implementation + +uses + Math, + {$IFDEF Delphi} + Dialogs, + {$ENDIF} + {$IFDEF LINUX} + libc, + {$ENDIF} + UMain, + UConfig; + +var + PrevNumLocale: string; + +// In Linux and maybe MacOSX some units (like cwstring) call setlocale(LC_ALL, '') +// to set the language/country specific locale (e.g. charset) for this application. +// Unfortunately, LC_NUMERIC is set by this call too. +// It defines the decimal-separator and other country-specific numeric settings. +// This parameter is used by the C string-to-float parsing functions atof() and strtod(). +// After changing LC_NUMERIC some external C-based libs (like projectM) are not +// able to parse strings correctly +// (e.g. in Germany "0.9" is not recognized as a valid number anymore but "0,9" is). +// So we reset the numeric settings to the default ('C'). +// Note: The behaviour of Pascal parsing functions (e.g. strtofloat()) is not +// changed by this because it doesn't use the locale-settings. +// TODO: +// - Check if this is needed in MacOSX (at least the locale is set in cwstring) +// - Find out which libs are concerned by this problem. +// If only projectM is concerned by this problem set and restore the numeric locale +// for each call to projectM instead of changing it globally. +procedure SetDefaultNumericLocale(); +begin + {$ifdef LINUX} + PrevNumLocale := setlocale(LC_NUMERIC, nil); + setlocale(LC_NUMERIC, 'C'); + {$endif} +end; + +procedure RestoreNumericLocale(); +begin + {$ifdef LINUX} + setlocale(LC_NUMERIC, PChar(PrevNumLocale)); + {$endif} +end; + +(* + * If an invalid floating point operation was performed the Floating-point unit (FPU) + * generates a Floating-point exception (FPE). Dependending on the settings in + * the FPU's control-register (interrupt mask) the FPE is handled by the FPU itself + * (we will call this as "FPE disabled" later on) or is passed to the application + * (FPE enabled). + * If FPEs are enabled a floating-point division by zero (e.g. 10.0 / 0.0) is + * considered an error and an exception is thrown. Otherwise the FPU will handle + * the error and return the result infinity (INF) (10.0 / 0.0 = INF) without + * throwing an error to the application. + * The same applies to a division by INF that either raises an exception + * (FPE enabled) or returns 0.0 (FPE disabled). + * Normally (as with C-programs), Floating-point exceptions (FPE) are DISABLED + * on program startup (at least with Intel CPUs), but for some strange reasons + * they are ENABLED in pascal (both delphi and FPC) by default. + * Many libs operating with floating-point values rely heavily on the C-specific + * behaviour. So using them in delphi is a ticking time-bomb because sooner or + * later they will crash because of an FPE (this problem occurs massively + * in OpenGL-based libs like projectM). In contrast to this no error will occur + * if the lib is linked to a C-program. + * + * Further info on FPUs: + * For x86 and x86_64 CPUs we have to consider two FPU instruction sets. + * The math co-processor i387 (aka 8087 or x87) set introduced with the i386 + * and SSE (Streaming SIMD Extensions) introduced with the Pentium3. + * Both of them have separate control-registers (x87: FPUControlWord, SSE: MXCSR) + * to control FPEs. Either has (among others) 6bits to enable/disable several + * exception types (Invalid,Denormalized,Zero,Overflow,Underflow,Precision). + * Those exception-types must all be masked (=1) to get the default C behaviour. + * The control-registers can be set with the asm-ops FLDCW (x87) and LDMXCSR (SSE). + * Instead of using assembler code, we can use Set8087CW() provided by delphi and + * FPC to set the x87 control-word. FPC also provides SetSSECSR() for SSE's MXCSR. + * Note that both Delphi and FPC enable FPEs (e.g. for div-by-zero) on program + * startup but only FPC enables FPEs (especially div-by-zero) for SSE too. + * So we have to mask FPEs for x87 in Delphi and FPC and for SSE in FPC only. + * FPC and Delphi both provide a SetExceptionMask() for control of the FPE + * mask. SetExceptionMask() sets the masks for x87 in Delphi and for x87 and SSE + * in FPC (seems as if Delphi [2005] is not SSE aware). So SetExceptionMask() + * is what we need and it even is plattform and CPU independent. + * + * Pascal OpenGL headers (like the Delphi standard ones or JEDI-SDL headers) + * already call Set8087CW() to disable FPEs but due to some bugs in the JEDI-SDL + * headers they do not work properly with FPC. I already patched them, so they + * work at least until they are updated the next time. In addition Set8086CW() + * does not suffice to disable FPEs because the SSE FPEs are not disabled by this. + * FPEs with SSE are a big problem with some libs because many linux distributions + * optimize code for SSE or Pentium3 (for example: int(INF) which convert the + * double value "infinity" to an integer might be automatically optimized by + * using SSE's CVTSD2SI instruction). So SSE FPEs must be turned off in any case + * to make USDX portable. + * + * Summary: + * Call this function on initialization to make sure FPEs are turned off. + * It will solve a lot of errors with FPEs in external libs. + *) +procedure DisableFloatingPointExceptions(); +begin + (* + // We will use SetExceptionMask() instead of Set8087CW()/SetSSECSR(). + // Note: Leave these lines for documentation purposes just in case + // SetExceptionMask() does not work anymore (due to bugs in FPC etc.). + {$IF Defined(CPU386) or Defined(CPUI386) or Defined(CPUX86_64)} + Set8087CW($133F); + {$IFEND} + {$IF Defined(FPC)} + if (has_sse_support) then + SetSSECSR($1F80); + {$IFEND} + *) + + // disable all of the six FPEs (x87 and SSE) to be compatible with C/C++ and + // other libs which rely on the standard FPU behaviour (no div-by-zero FPE anymore). + SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, + exOverflow, exUnderflow, exPrecision]); +end; + +function StringReplaceW(text : WideString; search, rep: WideChar):WideString; +var + iPos : integer; +// sTemp : WideString; +begin +(* + result := text; + iPos := Pos(search, result); + while (iPos > 0) do + begin + sTemp := copy(result, iPos + length(search), length(result)); + result := copy(result, 1, iPos - 1) + rep + sTEmp; + iPos := Pos(search, result); + end; +*) + result := text; + + if search = rep then + exit; + + for iPos := 0 to length( result ) - 1 do + begin + if result[ iPos ] = search then + result[ iPos ] := rep; + end; +end; + +function AdaptFilePaths( const aPath : widestring ): widestring; +begin + result := StringReplaceW( aPath, '\', PathDelim );//, [rfReplaceAll] ); +end; + + +{$IFNDEF MSWINDOWS} +procedure ZeroMemory( Destination: Pointer; Length: DWORD ); +begin + FillChar( Destination^, Length, 0 ); +end; + +function MakeLong(A, B: Word): Longint; +begin + Result := (LongInt(B) shl 16) + A; +end; + +(* +function QueryPerformanceCounter(lpPerformanceCount:TLARGEINTEGER):Bool; + + // From http://en.wikipedia.org/wiki/RDTSC + function RDTSC: Int64; register; + asm + rdtsc + end; + +begin + // Use clock_gettime here maybe ... from libc + lpPerformanceCount := RDTSC(); + result := true; +end; + +function QueryPerformanceFrequency(lpFrequency:TLARGEINTEGER):Bool; +begin + lpFrequency := 0; + result := true; +end; +*) +{$ENDIF} + +// Checks if a regular files or directory with the given name exists. +// The comparison is case insensitive. +function FileExistsInsensitive(var FileName: string): boolean; +var + FilePath, LocalFileName: string; + SearchInfo: TSearchRec; +begin +{$IFDEF LINUX} // eddie: Changed FPC to LINUX: Windows and Mac OS X dont have case sensitive file systems + // speed up standard case + if FileExists(FileName) then + begin + Result := true; + exit; + end; + + Result := false; + + FilePath := ExtractFilePath(FileName); + if (FindFirst(FilePath+'*', faAnyFile, SearchInfo) = 0) then + begin + LocalFileName := ExtractFileName(FileName); + repeat + if (AnsiSameText(LocalFileName, SearchInfo.Name)) then + begin + FileName := FilePath + SearchInfo.Name; + Result := true; + break; + end; + until (FindNext(SearchInfo) <> 0); + end; + FindClose(SearchInfo); +{$ELSE} + Result := FileExists(FileName); +{$ENDIF} +end; + + +{$IFDEF Unix} + // include resource-file info (stored in the constant array "resources") + {$I ../resource.inc} +{$ENDIF} + +function GetResourceStream(const aName, aType: string): TStream; +{$IFDEF Unix} +var + ResIndex: integer; + Filename: string; +{$ENDIF} +begin + Result := nil; + + {$IFDEF Unix} + for ResIndex := 0 to High(resources) do + begin + if (resources[ResIndex][0] = aName ) and + (resources[ResIndex][1] = aType ) then + begin + try + Filename := ResourcesPath + resources[ResIndex][2]; + Result := TFileStream.Create(Filename, fmOpenRead); + except + Log.LogError('Failed to open: "'+ resources[ResIndex][2] +'"', 'GetResourceStream'); + end; + exit; + end; + end; + {$ELSE} + try + Result := TResourceStream.Create(HInstance, aName , PChar(aType)); + except + Log.LogError('Invalid resource: "'+ aType + ':' + aName +'"', 'GetResourceStream'); + end; + {$ENDIF} +end; + +// +++++++++++++++++++++ helpers for RWOpsFromStream() +++++++++++++++ + function SdlStreamSeek( context : PSDL_RWops; offset : Integer; whence : Integer ) : integer; cdecl; + var + stream : TStream; + origin : Word; + begin + stream := TStream( context.unknown ); + if ( stream = nil ) then + raise EInvalidContainer.Create( 'SDLStreamSeek on nil' ); + case whence of + 0 : origin := soFromBeginning; // Offset is from the beginning of the resource. Seek moves to the position Offset. Offset must be >= 0. + 1 : origin := soFromCurrent; // Offset is from the current position in the resource. Seek moves to Position + Offset. + 2 : origin := soFromEnd; + else + origin := soFromBeginning; // just in case + end; + Result := stream.Seek( offset, origin ); + end; + + function SdlStreamRead( context : PSDL_RWops; Ptr : Pointer; size : Integer; maxnum: Integer ) : Integer; cdecl; + var + stream : TStream; + begin + stream := TStream( context.unknown ); + if ( stream = nil ) then + raise EInvalidContainer.Create( 'SDLStreamRead on nil' ); + try + Result := stream.read( Ptr^, Size * maxnum ) div size; + except + Result := -1; + end; + end; + + function SDLStreamClose( context : PSDL_RWops ) : Integer; cdecl; + var + stream : TStream; + begin + stream := TStream( context.unknown ); + if ( stream = nil ) then + raise EInvalidContainer.Create( 'SDLStreamClose on nil' ); + stream.Free; + Result := 1; + end; +// ----------------------------------------------- + +(* + * Creates an SDL_RWops handle from a TStream. + * The stream and RWops must be freed by the user after usage. + * Use SDL_FreeRW(...) to free the RWops data-struct. + *) +function RWopsFromStream(Stream: TStream): PSDL_RWops; +begin + Result := SDL_AllocRW(); + if (Result = nil) then + Exit; + + // set RW-callbacks + with Result^ do + begin + unknown := TUnknown(Stream); + seek := SDLStreamSeek; + read := SDLStreamRead; + write := nil; + close := SDLStreamClose; + type_ := 2; + end; +end; + + + +{$IFDEF FPC} +function RandomRange(aMin: Integer; aMax: Integer) : Integer; +begin + RandomRange := Random(aMax-aMin) + aMin ; +end; +{$ENDIF} + +{$IF Defined(MSWINDOWS) and Defined(FPC)} +function AllocateHWndCallback(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; +var + Msg: TMessage; + MethodPtr: ^TWndMethod; +begin + FillChar(Msg, SizeOf(Msg), 0); + Msg.msg := uMsg; + Msg.wParam := wParam; + Msg.lParam := lParam; + + MethodPtr := Pointer(GetWindowLongPtr(hwnd, GWL_USERDATA)); + if Assigned(MethodPtr) then + MethodPtr^(Msg); + + Result := DefWindowProc(hwnd, uMsg, wParam, lParam); +end; + +function AllocateHWnd(Method: TWndMethod): HWND; +var + ClassExists: Boolean; + WndClass, OldClass: TWndClass; + MethodPtr: ^TMethod; +begin + Result := 0; + + // setup class-info + FillChar(WndClass, SizeOf(TWndClass), 0); + WndClass.hInstance := HInstance; + // Important: do not enable AllocateHWndCallback before the msg-handler method is assigned, + // otherwise race-conditions might occur + WndClass.lpfnWndProc := @DefWindowProc; + WndClass.lpszClassName:= 'USDXUtilWindowClass'; + + // check if class is already registered + ClassExists := GetClassInfo(HInstance, WndClass.lpszClassName, OldClass); + // create window-class shared by all windows created by AllocateHWnd() + if (not ClassExists) or (@OldClass.lpfnWndProc <> @DefWindowProc) then + begin + if ClassExists then + UnregisterClass(WndClass.lpszClassName, HInstance); + if (RegisterClass(WndClass) = 0) then + Exit; + end; + // create window + Result := CreateWindowEx(WS_EX_TOOLWINDOW, WndClass.lpszClassName, '', + DWORD(WS_POPUP), 0, 0, 0, 0, 0, 0, HInstance, nil); + if (Result = 0) then + Exit; + // assign individual callback procedure to the window + if Assigned(Method) then + begin + // TMethod contains two pointers but we can pass just one as USERDATA + GetMem(MethodPtr, SizeOf(TMethod)); + MethodPtr^ := TMethod(Method); + SetWindowLongPtr(Result, GWL_USERDATA, LONG_PTR(MethodPtr)); + end; + // now enable AllocateHWndCallback for this window + SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@AllocateHWndCallback)); +end; + +procedure DeallocateHWnd(hWnd: HWND); +var + MethodPtr: ^TMethod; +begin + if (hWnd <> 0) then + begin + MethodPtr := Pointer(GetWindowLongPtr(hWnd, GWL_USERDATA)); + DestroyWindow(hWnd); + if Assigned(MethodPtr) then + FreeMem(MethodPtr); + end; +end; +{$IFEND} + +{$IFDEF FPC} +var + MessageList: TStringList; + ConsoleHandler: TThreadID; + // Note: TRTLCriticalSection is defined in the units System and Libc, use System one + ConsoleCriticalSection: System.TRTLCriticalSection; + ConsoleEvent: PRTLEvent; + ConsoleQuit: boolean; +{$ENDIF} + +(* + * Write to console if one is available. + * It checks if a console is available before output so it will not + * crash on windows if none is available. + * Do not use this function directly because it is not thread-safe, + * use ConsoleWriteLn() instead. + *) +procedure _ConsoleWriteLn(const aString: string); {$IFDEF HasInline}inline;{$ENDIF} +begin + {$IFDEF MSWINDOWS} + // sanity check to avoid crashes with writeln() + if (IsConsole) then + begin + {$ENDIF} + Writeln(aString); + {$IFDEF MSWINDOWS} + end; + {$ENDIF} +end; + +{$IFDEF FPC} +{* + * The console-handlers main-function. + * TODO: create a quit-event on closing. + *} +function ConsoleHandlerFunc(param: pointer): PtrInt; +var + i: integer; + quit: boolean; +begin + quit := false; + while (not quit) do + begin + // wait for new output or quit-request + RTLeventWaitFor(ConsoleEvent); + + System.EnterCriticalSection(ConsoleCriticalSection); + // output pending messages + for i := 0 to MessageList.Count-1 do + begin + _ConsoleWriteLn(MessageList[i]); + end; + MessageList.Clear(); + + // use local quit-variable to avoid accessing + // ConsoleQuit outside of the critical section + if (ConsoleQuit) then + quit := true; + + RTLeventResetEvent(ConsoleEvent); + System.LeaveCriticalSection(ConsoleCriticalSection); + end; + result := 0; +end; +{$ENDIF} + +procedure InitConsoleOutput(); +begin + {$IFDEF FPC} + // init thread-safe output + MessageList := TStringList.Create(); + System.InitCriticalSection(ConsoleCriticalSection); + ConsoleEvent := RTLEventCreate(); + ConsoleQuit := false; + // must be a thread managed by FPC. Otherwise (e.g. SDL-thread) + // it will crash when using Writeln. + ConsoleHandler := BeginThread(@ConsoleHandlerFunc); + {$ENDIF} +end; + +procedure FinalizeConsoleOutput(); +begin + {$IFDEF FPC} + // terminate console-handler + System.EnterCriticalSection(ConsoleCriticalSection); + ConsoleQuit := true; + RTLeventSetEvent(ConsoleEvent); + System.LeaveCriticalSection(ConsoleCriticalSection); + WaitForThreadTerminate(ConsoleHandler, 0); + // free data + System.DoneCriticalsection(ConsoleCriticalSection); + RTLeventDestroy(ConsoleEvent); + MessageList.Free(); + {$ENDIF} +end; + +{* + * With FPC console output is not thread-safe. + * Using WriteLn() from external threads (like in SDL callbacks) + * will damage the heap and crash the program. + * Most probably FPC uses thread-local-data (TLS) to lock a mutex on + * the console-buffer. This does not work with external lib's threads + * because these do not have the TLS data and so it crashes while + * accessing unallocated memory. + * The solution is to create an FPC-managed thread which has the TLS data + * and use it to handle the console-output (hence it is called Console-Handler) + * It should be safe to do so, but maybe FPC requires the main-thread to access + * the console-buffer only. In this case output should be delegated to it. + * + * TODO: - check if it is safe if an FPC-managed thread different than the + * main-thread accesses the console-buffer in FPC. + * - check if Delphi's WriteLn is thread-safe. + * - check if we need to synchronize file-output too + *} +procedure ConsoleWriteLn(const msg: string); +begin +{$IFDEF CONSOLE} + {$IFDEF FPC} + // TODO: check for the main-thread and use a simple _ConsoleWriteLn() then? + //GetCurrentThreadThreadId(); + System.EnterCriticalSection(ConsoleCriticalSection); + MessageList.Add(msg); + RTLeventSetEvent(ConsoleEvent); + System.LeaveCriticalSection(ConsoleCriticalSection); + {$ELSE} + _ConsoleWriteLn(msg); + {$ENDIF} +{$ENDIF} +end; + +procedure ShowMessage(const msg: String; msgType: TMessageType); +{$IFDEF MSWINDOWS} +var Flags: Cardinal; +{$ENDIF} +begin +{$IF Defined(MSWINDOWS)} + case msgType of + mtInfo: Flags := MB_ICONINFORMATION or MB_OK; + mtError: Flags := MB_ICONERROR or MB_OK; + else Flags := MB_OK; + end; + MessageBox(0, PChar(msg), PChar(USDXVersionStr()), Flags); +{$ELSE} + ConsoleWriteln(msg); +{$IFEND} +end; + +function IsAlphaChar(ch: WideChar): boolean; +begin + // TODO: add chars > 255 when unicode-fonts work? + case ch of + 'A'..'Z', // A-Z + 'a'..'z', // a-z + #170,#181,#186, + #192..#214, + #216..#246, + #248..#255: + Result := true; + else + Result := false; + end; +end; + +function IsNumericChar(ch: WideChar): boolean; +begin + case ch of + '0'..'9': + Result := true; + else + Result := false; + end; +end; + +function IsAlphaNumericChar(ch: WideChar): boolean; +begin + Result := (IsAlphaChar(ch) or IsNumericChar(ch)); +end; + +function IsPunctuationChar(ch: WideChar): boolean; +begin + // TODO: add chars outside of Latin1 basic (0..127)? + case ch of + ' '..'/',':'..'@','['..'`','{'..'~': + Result := true; + else + Result := false; + end; +end; + +function IsControlChar(ch: WideChar): boolean; +begin + case ch of + #0..#31, + #127..#159: + Result := true; + else + Result := false; + end; +end; + +(* + * Recursive part of the MergeSort algorithm. + * OutList will be either InList or TempList and will be swapped in each + * depth-level of recursion. By doing this it we can directly merge into the + * output-list. If we only had In- and OutList parameters we had to merge into + * InList after the recursive calls and copy the data to the OutList afterwards. + *) +procedure _MergeSort(InList, TempList, OutList: TList; StartPos, BlockSize: integer; + CompareFunc: TListSortCompare); +var + LeftSize, RightSize: integer; // number of elements in left/right block + LeftEnd, RightEnd: integer; // Index after last element in left/right block + MidPos: integer; // index of first element in right block + Pos: integer; // position in output list +begin + LeftSize := BlockSize div 2; + RightSize := BlockSize - LeftSize; + MidPos := StartPos + LeftSize; + + // sort left and right halves of this block by recursive calls of this function + if (LeftSize >= 2) then + _MergeSort(InList, OutList, TempList, StartPos, LeftSize, CompareFunc) + else + TempList[StartPos] := InList[StartPos]; + if (RightSize >= 2) then + _MergeSort(InList, OutList, TempList, MidPos, RightSize, CompareFunc) + else + TempList[MidPos] := InList[MidPos]; + + // merge sorted left and right sub-lists into output-list + LeftEnd := MidPos; + RightEnd := StartPos + BlockSize; + Pos := StartPos; + while ((StartPos < LeftEnd) and (MidPos < RightEnd)) do + begin + if (CompareFunc(TempList[StartPos], TempList[MidPos]) <= 0) then + begin + OutList[Pos] := TempList[StartPos]; + Inc(StartPos); + end + else + begin + OutList[Pos] := TempList[MidPos]; + Inc(MidPos); + end; + Inc(Pos); + end; + + // copy remaining elements to output-list + while (StartPos < LeftEnd) do + begin + OutList[Pos] := TempList[StartPos]; + Inc(StartPos); + Inc(Pos); + end; + while (MidPos < RightEnd) do + begin + OutList[Pos] := TempList[MidPos]; + Inc(MidPos); + Inc(Pos); + end; +end; + +(* + * Stable alternative to the instable TList.Sort() (uses QuickSort) implementation. + * A stable sorting algorithm preserves preordered items. E.g. if sorting by + * songs by title first and artist afterwards, the songs of each artist will + * be ordered by title. In contrast to this an unstable algorithm (like QuickSort) + * may destroy an existing order, so the songs of an artist will not be ordered + * by title anymore after sorting by artist in the previous example. + * If you do not need a stable algorithm, use TList.Sort() instead. + *) +procedure MergeSort(List: TList; CompareFunc: TListSortCompare); +var + TempList: TList; +begin + TempList := TList.Create(); + TempList.Count := List.Count; + if (List.Count >= 2) then + _MergeSort(List, TempList, List, 0, List.Count, CompareFunc); + TempList.Free; +end; + + +initialization + InitConsoleOutput(); + +finalization + FinalizeConsoleOutput(); + +end. -- cgit v1.2.3